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

Question

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

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

这通常非常有效,除了在一些非常罕见的情况下,无限循环被设置为使得所有四个滑块始终保持变化.我相信如果用户在其他三个滑块有时间调整之前对其中一个滑块进行了第二次更改,则会发生这种情况.

所以我的问题是,如果有某种方法可以避免这种循环,或者是否有更好的方法来实现上述想法.我注意到还有一个updateSliderInput功能,但我真的没有看到这可能有助于解决问题.

更新:我认为在这个线程中提出的仅涉及两个滑块的类似问题的解决方案由于和之间的相互依赖性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()使用滑块直到重新计算所有内容,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)