我正在开发一个小shinyapp用于进行概率多项选择测试，请参阅Bernardo, 1997。对于测试中的每个问题，将会有4个可能的答案。每个参与者都应该为每个备选方案分配som值，以反映每个备选方案是正确答案的信念程度。我正在使用sliderInput函数录制此输入。由于四个概率必须总和为1，因此我重新调整当前问题的所有四个概率（存储为prob <- reactiveValues( )的矩阵中的一行）以满足此约束。这由observeEvent(input$p1, )等触发。
一旦这些概率发生变化，就会触发服务器功能内sliderInput内的renderUI( )变化，以便更新所有滑块。这又会触发对函数更新prob的进一步调用，但由于此时的概率已经总和为1，prob保持不变，因此不应对滑块进行进一步更改。您可以通过运行shinyapps.io上托管的应用程序来亲眼看到。
这通常非常有效，除了在一些非常罕见的情况下，无限循环被设置为使得所有四个滑块永远保持变化。我相信如果用户在其他三个滑块有时间调整之前对其中一个滑块进行了第二次更改，就会发生这种情况。
所以我的问题是，如果有某种方法可以避免这种循环，或者是否有更好的方法来实现上述想法。我注意到还有一个updateSliderInput函数，但我真的不知道这有助于解决这个问题。
更新：我认为由于slider1和slider2之间的相互依赖，solution to a similar question involving just two sliders proposed in this thread会遇到同样的问题。
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)
答案 0 :(得分：5)
您可以public class TripModel {
public String tripId;
public int opDays;
public TripStopModel[] tripStopModels;
public TripModel() {
}
public TripModel(String tripId) {
this.tripId = tripId;
}
public TripModel(String tripId, TripStopModel[] tripStationHits) {
this.tripStopModels = tripStationHits;
this.tripId = tripId;
}
public TripModel(String tripId, int opDays, TripStopModel[] tripStationHits) {
this.tripId = tripId;
this.opDays = opDays;
this.tripStopModels = tripStationHits;
}
import org.apache.lucene.document.Document;
/**
* Created by User on 09/07/2016.
*/
public class TripStopModel {
public long arrivalTime;
public long departureTime;
public short dropoffType;
public Document stop;
public TripStopModel() {
}
public TripStopModel(long arrivalTime, long departureTime, short dropoffType, Document stop) {
this.arrivalTime = arrivalTime;
this.departureTime = departureTime;
this.dropoffType = dropoffType;
this.stop = stop;
}
}
滑块，直到重新计算所有内容并在之后suspend()：
resume()答案 1 :(得分：3)
您描述的问题来自于调用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元素，然后我将观察者分配给它们。观察者有一个回调函数，每次观察者触发时都会调用它。
答案 2 :(得分：0)
（我认为）我设法通过为每个滑块添加一个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)
答案 3 :(得分：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)