All geek questions in one place

Multiple Choice Probability Test, sliderInputs sum to 1 constraint

I am developing a small shinyapp for multiple choice probabilistic tests; see Bernardo, 1997 . For each question in the test, 4 possible answers will be said. Each participant must assign som values ​​to each alternative, reflecting their belief that each alternative is the correct answer. I record this input using a function sliderInput. Since the four probabilistic sums must be summed to 1, I scale all four probabilistic values ​​of the current question (the row in the matrix stored as prob <- reactiveValues( )) to satisfy this limitation. It works observeEvent(input$p1, ), etc.

After these probabilities change these triggers, changes in four sliderInputare placed inside renderUI( )inside the server function, so that all the sliders are updated. This, in turn, causes further calls to update the function prob, but since the probabilities at this point are already summed to 1, probthey remain unchanged, so no further changes in the sliders should occur. You can see for yourself by running the application hosted on shinyapps.io.

This usually works very well, except that in some fairly rare cases an infinite loop occurs, so that all four sliders are constantly changing. I believe that this happens if the user makes a second change on one of the sliders before the other three sliders have time to adjust.

So my question really is if there is some way to avoid this cycle or if there is a better way to implement the above idea. I noticed that there is also a function updateSliderInput, but I do not see how this can help solve the problem.

Update: I believe that solving a similar issue involving only two sliders proposed in this thread suffers from the same problem due to the interdependence between slider1and 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)
+3
source share
4 answers

You can suspend()sliders until everything is recounted and resume()then them:

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)
+5
source

, , , updateprob. @AEF , . R- Javascript.

, . R-, , :

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

# Dummy questions and alternatives
num.questions <- 6
num.sliders   <- sample(2:8, num.questions) # Change to, rep(n, num.questions) for same amount of sliders

# Helper function to calculate new values for sliders
updateprob <- function(oldprobs, new, i) {
  oldprobs <- oldprobs + 1e-6 # hack to avoid 0/0 = NaN in special cases
  ret        <- rep(0,length(oldprobs))
  ind.other  <- c(1:length(oldprobs))[! 1:length(oldprobs) %in% i]
  sum.others <- sum( oldprobs[ind.other] )
  range.left <- 1 - new
  ret[i]     <- new
  for( n in ind.other ){
    ret[n] <- ( oldprobs[n] * range.left) /sum.others
  }
  return(ret)
}

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

# Helper function, generates HTML for all sliders
generateSliders <- function(id, n){
  sliders <- lapply(1:n, function(i){
    probsliderInput(sprintf("q%ss%d",id,i),1/n)
  })
  do.call(fluidRow, sliders)
}

# Generate observers for all sliders and bind a callback to them
generateObservers <- function(id, n, input, session, callback){
  lapply(1:n,function(i){
    c.id <- sprintf("q%ss%d",id, i)
    print(sprintf("Observer for slider with id %s generated",c.id))
    observeEvent(input[[ sprintf("q%ss%d",id, i) ]],{
      do.call( callback, list(id, n, i, input, session) )
    })
  })
}

getSlidersValues <- function(id, n, input){ # Get all slider values
  unlist(lapply(1:n,function(i){
    input[[sprintf("q%ss%d",id,i)]]
  }))
}

setSliderValues <-function(id, ns, session, new.vals){ # Set all slider values
  suspendMany(observers)
  for(i in 1:ns){
    local({
      il <- i
      updateSliderInput( session, sprintf("q%ss%d",id,il),value=new.vals[il]) 
    })
  }
  resumeMany(observers)
}

# Callbackfunction for all sliders, triggers the change of all slider values
normalizeSliders <- function(id, nt, nc, input, session){
  print(sprintf("[q%ss%d] Slider %d moved, total: %d, l: %d",id,nc,nc, nt,length(observers)))

  vals     <- getSlidersValues(id, nt, input)
  new.vals <- updateprob(vals, input[[sprintf("q%ss%d",id, nc)]],nc)

  # Not necessary to suspend observers but helps in reducing number of function calls
  suspendMany(observers)
  for(i in 1:nt){
    updateSliderInput( session, sprintf("q%ss%d",id,i),value=new.vals[i]) 
  }
  resumeMany(observers)
}

# Thanks to @AEF
suspendMany <- function(observers) invisible(lapply(observers, function(o) o$suspend()))
resumeMany  <- function(observers) invisible(lapply(observers, function(o) o$resume()))

initiateProbs <- function(ns){
  lapply(ns,function(i){
    rep( 1/i, i) 
  })
}


# server.R
server <- function(input, output, session) {
  # matrix(rep(1/num.sliders,num.sliders*num.questions),num.questions,num.sliders)
  prob <- reactiveValues( prob= initiateProbs(num.sliders) )
  observers <- NULL

  observeEvent(input$questionNum, {
    q.num <- as.character( input$questionNum )
    cns   <- num.sliders[[input$questionNum]]

    sliders   <- generateSliders( q.num, cns ) # Generate sliders
    observers <<- generateObservers( q.num, cns, input, session, normalizeSliders) # Generate observers and bind callbacks to all sliders

    output$sliders <- renderUI({ sliders })
  })

  # ------ Toggle question observers --------
  observeEvent(input$previousquestion,{ 
    cns <- num.sliders[[input$questionNum]]
    if (input$questionNum <= 1) return()
    prob$prob[[input$questionNum]] <- getSlidersValues( as.character( input$questionNum ), cns ,input) # Save probability matrix
    updateNumericInput(session, "questionNum", value=input$questionNum-1) # Update hidden question counter field
  })
  observeEvent(input$nextquestion,{ 
    cns <- num.sliders[[input$questionNum]]
    if (input$questionNum  >= num.questions) return()
    prob$prob[[input$questionNum]] <- getSlidersValues( as.character( input$questionNum ), cns,input)  # Save probability matrix
    updateNumericInput(session, "questionNum", value=input$questionNum+1) # Update hidden question counter field
  })

  # Triggered on changing question number
  observeEvent(input$questionNum,{
    # Not necessary to suspend observers but helps in reducing number of function calls
    suspendMany(observers)
    setSliderValues( as.character( input$questionNum ), num.sliders[[input$questionNum]], session,  prob$prob[[input$questionNum]]) # Update sliders from probability matrix
    resumeMany(observers)
  })

  output$number  <- renderText(paste("Question", input$questionNum)) # Show question number
}

# ui.R
ui <- fluidPage(
  actionButton("previousquestion",icon=icon("angle-left"),label="Previous",
               style="color: #000"),
  actionButton("nextquestion",icon=icon("angle-right"),label="Next",
               style="#000"),
  uiOutput("nextbutton", inline = TRUE),
  textOutput("number"),
  uiOutput('sliders'),
  div(numericInput('questionNum','Hidden',1), style="visibility: hidden;")
)

shinyApp(ui=ui , server=server)

HTML, . , , .

+3

( ) , actionButton . , , , .

, , , .

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 the user presses the actionButton, then recalculate probabilities to satisfy sum to 1 constraint
  observeEvent(input$recalc1, 
               prob$prob[question$i,] <- updateprob(prob$prob[question$i,], input$p1, 1)
  )
  observeEvent(input$recalc2, 
               prob$prob[question$i,] <- updateprob(prob$prob[question$i,], input$p2, 2)
  )
  observeEvent(input$recalc3, 
               prob$prob[question$i,] <- updateprob(prob$prob[question$i,], input$p3, 3)
  )
  observeEvent(input$recalc4, 
               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"),
  actionButton(inputId = "recalc1", label = "Recalculate sliders"),
  uiOutput("p2ui"),
  actionButton(inputId = "recalc2", label = "Recalculate sliders"),
  uiOutput("p3ui"),
  actionButton(inputId = "recalc3", label = "Recalculate sliders"),
  uiOutput("p4ui"),
  actionButton(inputId = "recalc4", label = "Recalculate sliders")
)

shinyApp(ui=ui , server=server)
0

. , updateSelectInput

 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, session) {
  # 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)
  ) 

  observeEvent(prob$prob  ,{  

      if (is.null(input$p1 ) || is.null(input$p2 ) ||  is.null(input$p3 ) ||  is.null(input$p4 ) ) { return(NULL)} 

      if ( prob$prob[question$i,1] != input$p1)  {    
          updateSelectInput(session = session, inputId = 'p1', selected = prob$prob[question$i,1] )
      }  

       if ( prob$prob[question$i,2] != input$p2)  {   
         updateSelectInput(session = session, inputId = 'p2', selected = prob$prob[question$i,2] )
       } 

       if ( prob$prob[question$i,3] != input$p3)  {  
         updateSelectInput(session = session, inputId = 'p3', selected = prob$prob[question$i,3] )
       } 

       if ( prob$prob[question$i,4] != input$p4)  {  
         updateSelectInput(session = session, inputId = 'p4', selected = prob$prob[question$i,4] )
       }
    })


  # If the probabilities change, update the sliders
  output$p1ui <- renderUI({
    isolate(probsliderInput("p1",prob$prob[question$i,1]))
  })
  output$p2ui <- renderUI({
   isolate( probsliderInput("p2",prob$prob[question$i,2]))
  })
  output$p3ui <- renderUI({
    isolate(probsliderInput("p3",prob$prob[question$i,3]))
  })
  output$p4ui <- renderUI({
    isolate(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)
0

Source: https://habr.com/ru/post/1619043/

More articles:


All Articles