r - 概率多项选择测试，sliderInputs 总和为 1 个约束

Question

我正在开发一个小型 shinyapp进行概率多项选择测试，请参阅 Bernardo, 1997 .对于测试中的每个问题，都会有 4 个可能的答案。每个参与者应该为每个选项分配 som 值，以反射(reflect)他们对每个选项都是正确答案的信念程度。我正在使用 sliderInput 记录此输入功能。由于四个概率之和必须为 1，因此我重新调整当前问题的所有四个概率(存储为 prob <- reactiveValues( ) 的矩阵中的一行)以满足此约束。这是由 observeEvent(input$p1, ) 触发的等等

一旦这些概率发生变化，就会触发四个 sliderInput 的变化。放入renderUI( )在服务器功能内部，以便更新所有 slider 。这反过来又会触发对函数更新 prob 的进一步调用。但由于此时的概率总和为 1，prob保持不变，因此不会对 slider 进行进一步更改。您可以通过运行在 shinyapps.io 上托管的应用程序来亲自查看。

这通常工作得很好，除了在一些非常罕见的情况下会触发无限循环，这样所有四个 slider 都会永远变化。我相信如果用户在其他三个 slider 有时间调整之前对其中一个 slider 进行第二次更改，就会发生这种情况。

所以我的问题是，是否有某种方法可以避免这种循环，或者是否有更好的方法来实现上述想法。我注意到还有一个 updateSliderInput功能，但我真的不明白这如何帮助解决问题。

更新:我相信 solution to a similar question involving just two sliders proposed in this thread由于 slider1 之间的相互依赖，遇到了同样的问题和 slider2 .

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)

Answer 1

您可以suspend() slider 直到重新计算所有内容，然后resume() 它们:

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
    }
}

# new functions to suspend and resume a list of observers
suspendMany <- function(observers) invisible(lapply(observers, function(o) o$suspend()))
resumeMany <- function(observers) invisible(lapply(observers, function(o) o$resume()))

# 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),
                           ready = F) # 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
    # We put all observers in a list to handle them conveniently
    observers <- list(
    observeEvent(input$p1,
                 {
                   suspendMany(observers)
                   prob$prob[question$i,] <- updateprob(prob$prob[question$i,], input$p1, 1)
                   resumeMany(observers)
                 }
    ),
    observeEvent(input$p2,
                 {
                   suspendMany(observers)
                   prob$prob[question$i,] <- updateprob(prob$prob[question$i,], input$p2, 2)
                   resumeMany(observers)
                 }
    ),
    observeEvent(input$p3,
                 {
                   suspendMany(observers)
                   prob$prob[question$i,] <- updateprob(prob$prob[question$i,], input$p3, 3)
                   resumeMany(observers)
                 }
    ),
    observeEvent(input$p4,
                 {
                   suspendMany(observers)
                   prob$prob[question$i,] <- updateprob(prob$prob[question$i,], input$p4, 4)
                   resumeMany(observers)
                 }
    )
    )

    # 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)