Estoy desarrollando un pequeñoshinyapp para realizar pruebas probabilísticas de opción múltiple, veaBernardo, 1997. Para cada pregunta en la prueba, habrá 4 respuestas posibles. Cada participante debe asignar algunos valores a cada alternativa que reflejen su grado de creencia de que cada alternativa es la respuesta correcta. Estoy grabando esta entrada usando elsliderInput función. Como las cuatro probabilidades deben sumar 1, reescala las cuatro probabilidades de la pregunta actual (una fila en una matriz almacenada comoprob <- reactiveValues( )) para cumplir con esta restricción. Esto se desencadena porobserveEvent(input$p1, ) etc.

Una vez que estas probabilidades cambian, esto desencadena cambios en los cuatrosliderInput poner dentrorenderUI( ) dentro de la función del servidor de modo que se actualicen todos los controles deslizantes. Esto a su vez desencadena nuevas llamadas a la actualización de la funciónprob pero como las probabilidades en este punto ya suman 1,prob permanecer sin cambios para que no se produzcan más cambios en los controles deslizantes. Puede verlo usted mismo ejecutando la aplicación alojada en shinyapps.io.

Esto generalmente funciona muy bien, excepto que en algunos casos bastante raros se activa un bucle infinito de manera que los cuatro controles deslizantes cambian para siempre. Creo que esto sucede si el usuario realiza un segundo cambio en uno de los controles deslizantes antes de que los otros tres controles deslizantes hayan tenido tiempo de ajustarse.

Entonces, mi pregunta es realmente si hay alguna forma de evitar este ciclo o si hay una mejor manera de implementar la idea anterior. Me di cuenta de que también hay unupdateSliderInput función, pero realmente no veo cómo esto podría ayudar a resolver el problema.

Actualización: creo que elsolución a una pregunta similar que involucra solo dos controles deslizantes propuestos en este hilo sufre el mismo problema debido a la dependencia mutua entreslider1 yslider2.

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)