I'm developing a small shinyapp for conducting probabilistic multiple choice tests, see Bernardo, 1997. For each question in the test, there will be say 4 possible answers. Each participant should assign som values to each alternative reflecting their degree of belief that each alternative is the correct answer. I'm recording this input using the sliderInput
function. Since the four probabilites must sum to 1, I rescale all four probabilites of the current question (a row in a matrix stored as prob <- reactiveValues( )
) to meet this constraint. This is triggered by observeEvent(input$p1, )
etc.
Once these probabilities changes this triggers changes in the four sliderInput
put inside renderUI( )
inside the server function such that all sliders are updated. This in turn triggers further calls to the function updating prob
but since the probabilities at this point already sum to 1, prob
remain unchanged so no further changes to the sliders should occur. You can see for yourself by running the app hosted on shinyapps.io.
This usually works very well, except that in some quite rare cases an infinite loop is set off such that all four sliders keep changing forever. I believe this happens if the user makes a second change to one of the sliders before the three other sliders have had time to adjust.
So my question is really if there is some way of avoiding this loop or if there is some better way of implementing the above idea. I noticed that there is also a updateSliderInput
function but I don't really see how this might help solve the problem.
Update: I believe the solution to a similar question involving just two sliders proposed in this thread suffers from the same problem due to the mutual dependency between slider1
and 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)