Ich entwickle ein kleines shinyapp zur Durchführung probabilistischer Multiple-Choice-Tests sieheBernardo, 1997. Für jede Frage im Test gibt es 4 mögliche Antworten. Jeder Teilnehmer sollte jeder Alternative einige Werte zuweisen, die den Grad seiner Überzeugung widerspiegeln, dass jede Alternative die richtige Antwort ist. Ich nehme diesen Eingang mit dem @ asliderInput Funktion. Da die vier Wahrscheinlichkeiten 1 ergeben müssen, skaliere ich alle vier Wahrscheinlichkeiten der aktuellen Frage neu (eine Zeile in einer Matrix, die als @ gespeichert istprob <- reactiveValues( )), um diese Einschränkung zu erfüllen. Dies wird ausgelöst durchobserveEvent(input$p1, ) etc

Wenn sich diese Wahrscheinlichkeiten ändern, werden Änderungen in den viersliderInput reintunrenderUI( ) innerhalb der Serverfunktion, sodass alle Schieberegler aktualisiert werden. Dies wiederum löst weitere Aufrufe der Funktion update @ auprob aber da die Wahrscheinlichkeiten zu diesem Zeitpunkt bereits 1 ergeben,prob bleiben unverändert, daher sollten keine weiteren Änderungen an den Schiebereglern vorgenommen werden. Sie können sich selbst davon überzeugen, indem Sie die auf shinyapps.io gehostete App ausführen.

Das funktioniert normalerweise sehr gut, außer dass in einigen seltenen Fällen eine Endlosschleife ausgelöst wird, sodass sich alle vier Schieberegler für immer ändern. Ich glaube, dies passiert, wenn der Benutzer eine zweite Änderung an einem der Schieberegler vornimmt, bevor die drei anderen Schieberegler Zeit zum Einstellen hatten.

So ist meine Frage wirklich, ob es eine Möglichkeit gibt, diese Schleife zu umgehen, oder ob es eine bessere Möglichkeit gibt, die obige Idee umzusetzen. Mir ist aufgefallen, dass es auch ein @ giupdateSliderInput Funktion, aber ich sehe nicht wirklich, wie dies helfen könnte, das Problem zu lösen.

Update: Ich glaube dasLösung zu einer ähnlichen Frage mit nur zwei in diesem Thread vorgeschlagenen Schiebereglern leidet unter dem gleichen Problem aufgrund der gegenseitigen Abhängigkeit zwischenslider1 undslider2.

library(shiny)
digits=3
step <- .1^digits

# Dummy questions and alternatives
n <- 5

# Miscellaneous functions
updateprob <- function(oldprobs, new, i) {
  cat(oldprobs, new, i)
  if (new==oldprobs[i]) {
    cat("-\n")
    oldprobs 
  } else {
    newprobs <- rep(0,4)
    oldprobs <- oldprobs + 1e-6 # hack to avoid 0/0 = NaN in special cases
    newprobs[-i] <- round(oldprobs[-i]/sum(oldprobs[-i])*(1-new),digits=digits)
    newprobs[i] <- new
    cat("*\n")
    newprobs
  }
}
# wrapper function around sliderInput
probsliderInput <- function(inputId,value,submitted=FALSE) {
  if (!submitted)
    sliderInput(inputId=inputId,
                value=value,
                label=NULL,
                min=0,
                max=1,
                step=step,
                round=-digits,
                ticks=FALSE)
}

server <- function(input, output) {
  # Initialize the quiz here, possibly permute the quiz
  prob <- reactiveValues(prob=matrix(rep(.25,4*n),n,4)) # current choice of probabilities
  question <- reactiveValues(i=1) # question number

  # Actions to take if pressing next and previous buttons
  observeEvent(input$nextquestion,{question$i <- min(question$i+1,n)}) 
  observeEvent(input$previousquestion,{question$i <- max(question$i-1,1)}) 

  # If any of the probability sliders change, then recalculate probabilities to satisfy sum to 1 constraint
  observeEvent(input$p1, 
               prob$prob[question$i,] <- updateprob(prob$prob[question$i,], input$p1, 1)
  )
  observeEvent(input$p2, 
               prob$prob[question$i,] <- updateprob(prob$prob[question$i,], input$p2, 2)
  )
  observeEvent(input$p3, 
               prob$prob[question$i,] <- updateprob(prob$prob[question$i,], input$p3, 3)
  )
  observeEvent(input$p4, 
               prob$prob[question$i,] <- updateprob(prob$prob[question$i,], input$p4, 4)
  )

  # If the probabilities change, update the sliders
  output$p1ui <- renderUI({
    probsliderInput("p1",prob$prob[question$i,1])
  })
  output$p2ui <- renderUI({
    probsliderInput("p2",prob$prob[question$i,2])
  })
  output$p3ui <- renderUI({
    probsliderInput("p3",prob$prob[question$i,3])
  })
  output$p4ui <- renderUI({
    probsliderInput("p4",prob$prob[question$i,4])
  })

  # Render the buttons sometimes greyed out
  output$previousbutton <- renderUI({
    actionButton("previousquestion",icon=icon("angle-left"),label="Previous",
                 style=if (question$i > 1) "color: #000" else "color: #aaa")
  })
  output$nextbutton <- renderUI({
    actionButton("nextquestion",icon=icon("angle-right"),label="Next",
                 style=if (question$i < n) "color: #000" else "color: #aaa")
  })

  # Current question number
  output$number <- renderText(paste("Question",question$i))
}

ui <- fluidPage(
  uiOutput("previousbutton", inline = TRUE),
  uiOutput("nextbutton", inline = TRUE),
  textOutput("number"),
  uiOutput("p1ui"),
  uiOutput("p2ui"),
  uiOutput("p3ui"),
  uiOutput("p4ui")
)

shinyApp(ui=ui , server=server)