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)
You can suspend() the sliders until everything is recalculated and resume() them afterwards:
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)
The problem you describes comes from a observer loop triggered when updateprob is called. As #AEF is saying you can either suspend the observers in your server.R code or you can disable the event propagation using Javascript.
I see that you do a lot of manually defining sliders in your server.R code so here's a answer where the number of questions and number of sliders are dynamic:
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)
Here I'm simply first looping to create the actual HTML elements, then I'm assigning observers to them. The observers have a callback function which is called each time the observer fires.
(I think) I managed to fix the infinite loop of readjusting by adding an actionButton for each slider. Now the user adjusts a slider, and then hits the appropriate recalculate button at which point the sliders update, instead of the sliders constantly trying to update themselves.
Having the four buttons isn't the prettiest and there might be a way to make it clearer what the user has to do, but all the functionality is there.
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)
This is one option. Update the sliders only when value has changed, using 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)
Related
I am new to Shiny. What I want to do in my application is, running & displaying some part of the code only when a condition on another calculation is met.
The conditionalPanel works fine with the conditions on input values but I could not figure out how to do this with the 'output' values, i.e., conditionally on the output values of the functions. Below is my example code:
library(shiny)
msLocation <- "msLoc"
searchMWText <- "searchMW"
bid <- "2333333"
fulltext <- "fullDisplay"
ui <- fluidPage(
titlePanel("Run server codes conditionally"),
sidebarLayout(
sidebarPanel(
helpText("Evaluate input and run different parts of the code depending on the output functions"),
br(),
sliderInput("rand", "select seed", min = 1, max = 50, step = 1, value = 1)
),
mainPanel(
fluidRow(conditionalPanel("output.rand == 1"),
tags$h4("Here comes the default part"),
br(),
textOutput("defaultCalc")),
fluidRow(conditionalPanel("output.randomint != 1",
tags$h4("I can evaluate if the chosen number is even or odd."),
br(),
textOutput("evenodd")
),
fluidRow(conditionalPanel("output.evenodd == 'Number is even'",
tags$h4("Number even calculation "),
textOutput("msLoc"),
br(),
textOutput("searchMW"),
br(),
textOutput("defaultID"),
br()
),
fluidRow(conditionalPanel("output.evenodd == 'Number is odd'",
tags$h4("Here is some id:", textOutput("id")),
textOutput("displayFull")
)
)
)
)
)))
#
server <- function(input, output) {
rand1 <- reactive({
if(is.null(input$rand)){return(NULL)}
rn <- input$rand
return(rn)
})
randomint <- reactive({
seedn <- rand1()
set.seed(seedn)
rint <- sample(1:50, 1)
return(rint)
})
calc1 <- reactive({
intn <- randomint()
modn <- intn %% 2
return(modn)
})
evenOdd <- reactive({
modn <- calc1()
if(modn == 0){valueText = "Number is even"}
if(modn != 0){valueText = "Number is odd"}
return(valueText)
})
idtext <- reactive({
idint <- sample(1:10000, 3)
idint <- as.character(idint)
idint <- paste(idint, collapse = "")
return(idint)
})
output$defaultCalc <- renderText({
as.character(randomint())
})
output$evenodd <- renderText({
evenOdd()
})
output$searchMW <- renderText({
searchMWText
})
output$defaultID <- renderText({
bid
})
output$id <- renderText({
idtext()
})
output$displayFull <- renderText({
fulltext
})
}
shinyApp(ui = ui, server = server)
The problem is, the parts after default always appear, e..g., 'Here is some id' text always appears and this is not what I want. I want to display 'Here is some id' and run the calculation (idtext) only when the number is odd.The number is not coming from the slider input, the slider input is providing the seed only. The number is also calculated and depends on its value, the other parts should be run and displayed. Until the user selects a slider input value, only the 'default part' should be displayed and nothing else.
I searched a lot and could not find a solution that mentions the conditions on output. What is the best way to solve this?
Do:
randomint <- reactive({
seedn <- rand1()
set.seed(seedn)
rint <- sample(1:50, 1)
return(rint)
})
output$randomint <- reactive(randomint())
outputOptions(output, "randomint", suspendWhenHidden = FALSE)
Then you can use "output.randomint !== 1".
I am trying to create a shiny application which will enable users to add text boxes, or add images and create a document from it. I am able to add one Textbox and display its contents but when I add another textbox, the contents are not displayed. I have used a link as a starting point.
Here is my sample code that I am trying to add more user input text boxes by clicking add button.
library(shiny)
library(shinyjqui)
ui <- shinyUI(fluidPage(
sidebarPanel(
actionButton("add_btn", "Add Textbox"),
actionButton("rm_btn", "Remove Textbox"),
textOutput("counter")
),
mainPanel(
jqui_sortable(
div(id = 'textboxes',
uiOutput("textbox_ui"),
textInput("caption", "Caption", "Insert Text"),
verbatimTextOutput("value")
)
)
)
))
server <- shinyServer(function(input, output, session) {
# Track the number of input boxes to render
counter <- reactiveValues(n = 0)
#Track the number of input boxes previously
prevcount <- reactiveValues(n = 0)
observeEvent(input$add_btn, {
counter$n <- counter$n + 1
prevcount$n <- counter$n - 1})
observeEvent(input$rm_btn, {
if (counter$n > 0) {
counter$n <- counter$n - 1
prevcount$n <- counter$n + 1
}
})
output$value <- renderText({ input$caption })
output$counter <- renderPrint(print(counter$n))
textboxes <- reactive({
n <- counter$n
if (n > 0) {
# If the no. of textboxes previously where more than zero, then
#save the text inputs in those text boxes
if(prevcount$n > 0){
vals = c()
if(prevcount$n > n){
lesscnt <- n
isInc <- FALSE
}else{
lesscnt <- prevcount$n
isInc <- TRUE
}
for(i in 1:lesscnt){
inpid = paste0("textin",i)
vals[i] = input[[inpid]]
}
if(isInc){
vals <- c(vals, "Insert Text")
}
lapply(seq_len(n), function(i) {
textInput(inputId = paste0("textin", i),
label = paste0("Subsection ", i), value = vals[i])
})
}else{
lapply(seq_len(n), function(i) {
textInput(inputId = paste0("textin", i),
label = paste0("Subsection ", i), value = "Insert text")
})
}
}
})
output$textbox_ui <- renderUI({ textboxes() })
})
shinyApp(ui, server)
Any help will be appreciated in this regard. If anyone can point me in how to dynamically capture output$value everytime a new box is added it would push me in the right direction.
Have you tried reactiveValuesToList function ?
Here you have an example that might help
AllInputs <- reactive({
x <- reactiveValuesToList(input) })
textboxes <- reactive({
n <- counter$n
if (n > 0) {
isolate({
lapply(seq_len(n), function(i) {
textInput(inputId = paste0("textin", i),
label = paste0("Textbox", i),
value = AllInputs()[[paste0("textin", i)]])
})
})
}
})
I'm learning shiny and working with a numericInput connected to many selectizeInputs.
if the numeric input equals to 1 or 2, I would like to create respectively 1 and 2 selectizeInputs and select the "i"th modality of a vector called "modalities" for each selectizeInput EDIT : and that choices = modalities[i] only (and not modalities)
if the numeric input equals to 3 or 4, I would like to create respectively 3 and 4 selectizeInputs which are connected with each other (with choices = modalities). In other words : if an item is selected in one of the selectizeinputs i would like that it disappears from the other selectizeinputs' choices.
In addition (and this is what I have trouble with) I would like to "reset" all the selected SelectizeInputs each time I modify the numericInput. I tried with the observeEvent below and I tried to use an isolate(input$ui_number) but I did not find any solution to my question because i don't understand how to do it... !
Thank you for your help !
library(shiny)
modalities <- LETTERS[1:10]
ui = tabPanel("Change modalities",
numericInput("ui_number", label = "Number of modalities",
min = 1, max = 4, value = 3),
uiOutput("renderui")
)
server = function(input, output, session) {
# Generate modalities select lists
output$renderui <- renderUI({
output = tagList()
for (i in seq_len(input$ui_number)) {
output[[i]] = selectizeInput(paste0("ui_mod_choose", i),
label = paste0("Modality ", i),
choices = modalities, multiple = TRUE)
}
return(output)
})
# if input$ui_number is modified to 3 or 4 : set selected to NULL ##### NOT WORKING
observeEvent({input$ui_number},
{
n <- input$ui_number
if(n%in%c(3,4)){
for (i in seq_len(n)) {
updateSelectizeInput(session, paste0("ui_mod_choose",i),selected=NULL)
}
}
}
)
observe({
n <- input$ui_number
if(n%in%c(1,2)){ #if n=1 or 2 => Select the "i"th modality for each selectizeInput
for (i in seq_len(n)) {
updateSelectizeInput(session, paste0("ui_mod_choose",i),
choices = modalities[i],
selected = modalities[i]
)
}
} else{ # if n=3 or 4 => Remove selected modalities from other select lists
for (i in seq_len(n)) {
vecteur <- unlist(lapply((1:n)[-i], function(i)
input[[paste0("ui_mod_choose",i)]]))
updateSelectizeInput(session, paste0("ui_mod_choose",i),
choices = setdiff(modalities, vecteur),
selected = input[[paste0("ui_mod_choose",i)]])
}
}
})
}
runApp(shinyApp(ui, server))
This issue corresponds to the following of this one :
lapply function using a numericInput parameter around an observeEvent in RShiny
EDIT2 : new try thanks to #Aurèle 's tip.
The only problem which remains is the 1:100 in lapply which can take time to load (did not find a solution to add a reactive content such as 1:input&ui_number around a conditional panel)
library(shiny)
modalities <- LETTERS[1:10]
make_conditional_selectizeInputs <- function() {
do.call(
div,
lapply(1:100, function(i)
conditionalPanel(
condition = sprintf("%d <= input.ui_number", i),
selectizeInput(sprintf("ui_mod_choose%d", i),
label = sprintf("Modality %d", i),
choices = character(0), multiple = TRUE, selected = NULL)
)
)
)
}
ui <- tabPanel(
"Change modalities",
uiOutput("rendernumeric"),
#numericInput("ui_number", label = "Number of modalities", min = 1L, max = max, value = 1L),
make_conditional_selectizeInputs()
)
server <- function(input, output, session) {
max <- 4
output$rendernumeric <- renderUI({
numericInput("ui_number", label = "Number of modalities", min = 1L, max = max, value = 1L)
})
n <- reactive({
n <- input$ui_number
if (is.null(n) || is.na(n) || !n >= 0) 0 else n
})
# Reset all
observeEvent(
eventExpr = n(),
handlerExpr = for (i in seq_len(max))
updateSelectizeInput(
session, sprintf("ui_mod_choose%d", i),
choices = if (n() %in% 1:2 && i <= n()) modalities[i] else modalities,
selected = if (n() %in% 1:2 && i <= n()) modalities[i] else NULL
)
)
all_selected <- reactive({
unlist(lapply(seq_len(max), function(i)
input[[sprintf("ui_mod_choose%d", i)]]))
})
# Update available modalities
observeEvent(
eventExpr = all_selected(),
handlerExpr = if (!n() %in% 1:2) for (i in seq_len(n())) {
x <- input[[sprintf("ui_mod_choose%d", i)]]
other_selected <- setdiff(all_selected(), x)
updateSelectizeInput(session, sprintf("ui_mod_choose%d", i),
choices = setdiff(modalities, other_selected),
selected = x)
}
)
}
runApp(shinyApp(ui, server))
Basically, you just need one more line: selected = if (n %in% 1:2) modalities[i] else NULL whenever you regenerate your selectizeInputs.
library(shiny)
modalities <- LETTERS[1:10]
ui = tabPanel("Change modalities",
numericInput("ui_number", label = "Number of modalities",
min = 1, max = 4, value = 3),
uiOutput("renderui"))
server = function(input, output, session) {
# Generate modalities select lists
output$renderui <- renderUI({
output = tagList()
n <- input$ui_number
n <- if (is.null(n) || is.na(n) || ! n >= 0) 0 else n
for (i in seq_len(n)) {
output[[i]] = selectizeInput(paste0("ui_mod_choose", i),
label = paste0("Modality ", i),
choices = if (n %in% 1:2) modalities[i] else modalities,
multiple = TRUE,
# Add this
selected = if (n %in% 1:2) modalities[i] else NULL)
}
output
})
# Remove selected modalities from other select lists
observe({
n <- isolate(input$ui_number)
if (!n %in% 1:2) for (i in seq_len(n)) {
vecteur <- unlist(lapply((1:n)[-i], function(i)
input[[paste0("ui_mod_choose",i)]]))
updateSelectizeInput(session, paste0("ui_mod_choose",i),
choices = setdiff(modalities, vecteur),
selected = input[[paste0("ui_mod_choose",i)]])
}
})
}
runApp(shinyApp(ui, server))
(This is different enough to be a separate answer).
In https://shiny.rstudio.com/articles/dynamic-ui.html, four different approaches to a dynamic UI in Shiny are suggested, ordered by difficulty:
The conditionalPanel function, which is used in ui.R and wraps a set of UI elements that need to be dynamically shown/hidden.
The renderUI function, which is used in server.R in conjunction with the uiOutput function in ui.R, lets you generate calls to UI functions and make the results appear in a predetermined place in the UI.
The insertUI and removeUI functions, which are used in server.R and allow you to add and remove arbitrary chunks of UI code (all independent from one another), as many times as you want, whenever you want, wherever you want.
Use JavaScript to modify the webpage
Your attempts use the second approach, this answer uses the first one (though it should be doable with any of them):
library(shiny)
modalities <- LETTERS[1:10]
max <- 4L
First, a helper function to build the UI. The number of selectizeInputs is no longer dynamic but fixed to max, and they're alternatively shown/hidden based on input$ui_number:
make_conditional_selectizeInputs <- function(max) {
do.call(
div,
lapply(seq_len(max), function(i)
conditionalPanel(
condition = sprintf("%d <= input.ui_number", i),
selectizeInput(sprintf("ui_mod_choose%d", i),
label = sprintf("Modality %d", i),
choices = character(0), multiple = TRUE, selected = NULL)
)
)
)
}
ui <- tabPanel(
"Change modalities",
numericInput("ui_number", label = "Number of modalities",
min = 1L, max = max, value = 1L),
make_conditional_selectizeInputs(max)
)
The server function has two reactive expressions that help modularize code but are not essential to its logic (n() and all_expected()).
There is no longer a renderUI() (the selectizeInputs are already generated once and for all).
There is an observeEvent() that takes a dependency on input$ui_number and resets all selections and choices when it changes.
The last observeEvent() takes a dependency on all input$ui_mod_choose[i] and updates all the choices whenever there is a new selection.
server <- function(input, output, session) {
n <- reactive({
n <- input$ui_number
if (is.null(n) || is.na(n) || !n >= 0) 0 else n
})
# Reset all
observeEvent(
eventExpr = n(),
handlerExpr = for (i in seq_len(max))
updateSelectizeInput(
session, sprintf("ui_mod_choose%d", i),
choices = if (n() %in% 1:2 && i <= n()) modalities[i] else modalities,
selected = if (n() %in% 1:2 && i <= n()) modalities[i] else NULL
)
)
all_selected <- reactive({
unlist(lapply(seq_len(max), function(i)
input[[sprintf("ui_mod_choose%d", i)]]))
})
# Update available modalities
observeEvent(
eventExpr = all_selected(),
handlerExpr = if (!n() %in% 1:2) for (i in seq_len(n())) {
x <- input[[sprintf("ui_mod_choose%d", i)]]
other_selected <- setdiff(all_selected(), x)
updateSelectizeInput(session, sprintf("ui_mod_choose%d", i),
choices = setdiff(modalities, other_selected),
selected = x)
}
)
}
Essentially it differs from the second approach (with renderUI) in that it removes part of the dependency between input$ui_number and the input$ui_mod_choose[i], at least when they're generated (but there's a residual dependency when they're reset because of updateSelectizeInput. I'm not completely clear why I could make it work with this approach and not with renderUI though).
runApp(shinyApp(ui, server))
This is a screenshot of the reactlog, though it doesn't show the whole picture, because of the necessary impurity of updateSelectizeInput() that mixes the UI and server logics, and creates circular dependencies that can be tricky to reason about:
Here's a sample code where I generate random vector and plot its histogram. In addition, there's a numericInput field that I use to clip data, i.e. to assign values lower than a threshold to that threshold. The initial value of the numericInput field is assigned based on data.
The problem is that when I press the button to generate data, the plot is evaluated twice, which I want to avoid. I emphasise this by adding sleep routine in the plotting function.
It seems to me that I'm updating the numericInput incorrectly. When I simply hard-code initial field value of that field, the issue is gone and the plot is evaluated once.
library(shiny)
ui <- shinyUI(fluidPage(
titlePanel("test data clipping"),
sidebarLayout(
sidebarPanel(
actionButton('inDataGen', 'Generate dataset'),
br(),
br(),
uiOutput('resetable_input_clip'),
actionButton('inDataClipReset', 'Reset data clipping')
),
mainPanel(plotOutput("plotHist", width = "100%"))
)
))
server <- shinyServer(function(input, output) {
rValues <- reactiveValues(dataIn = NULL,
dataMin = -10e10)
# generate random dataset
userDataGen <- observeEvent(input$inDataGen, {
cat(file = stderr(), '\nuserDataGen\n')
# assign result to shared 'dataIn' variable
x <- rnorm(1000)
rValues$dataIn = x
rValues$dataMin = min(x)
})
# modify data
userDataProc <- reactive({
cat(file = stderr(), 'userDataProc\n')
dm = rValues$dataIn
if (is.null(rValues$dataIn))
return(NULL)
else {
# Data clipping
dm[dm < input$inDataClipMin] <-
input$inDataClipMin
return(dm)
}
})
output$resetable_input_clip <- renderUI({
cat(file = stderr(), 'output$resetable_input_clip\n')
times <- input$inDataClipReset
div(
id = letters[(times %% length(letters)) + 1],
numericInput(
'inDataClipMin',
'Clip data below threshold:',
value = rValues$dataMin,
width = 200,
step = 100
)
)
})
output$plotHist <- renderPlot({
cat(file = stderr(), 'plotHist \n')
if (is.null(rValues$dataIn))
return(NULL)
else {
plot(hist(userDataProc()))
Sys.sleep(2)
}
})
})
shinyApp(ui = ui, server = server)
The flow after pressing the button to generate data involves two evaluations of plotHist:
output$resetable_input_clip
plotHist
userDataGen
plotHist
userDataProc
output$resetable_input_clip
plotHist
userDataProc
SOLVED ELSWHERE
This issue has been solved on Shiny Google group. The final solution is available here and is a combination of changing observeEvent + reactiveValues to reactive(), and using freezeReactiveValue.
I believe your issue is occurring in
# modify data
userDataProc <- reactive({
cat(file = stderr(), 'userDataProc\n')
dm = rValues$dataIn
if (is.null(df))
return(NULL)
else {
# Data clipping
dm[dm < input$inDataClipMin] <-
input$inDataClipMin
return(dm)
}
})
Since input$inDataClipMin is dependent on the reactive value rValues$dataMin, you end up rendering this for the initial value of rValues$dataMin, the rValues$dataMin is being reevaluated, which triggers a reevaluation of input$inDataClipMin.
If you replace this snippet with what I have below, you should get your desired behavior.
# modify data
userDataProc <- reactive({
cat(file = stderr(), 'userDataProc\n')
dm = rValues$dataIn
if (is.null(df))
return(NULL)
else {
# Data clipping
dm[dm < rValues$dataMin] <-
rValues$dataMin
return(dm)
}
})
As an alternative, you could put the following in your ui
numericInput(
'inDataClipMin',
'Clip data below threshold:',
value = rValues$dataMin,
width = 200,
step = 100
)
And then use updateNumericInput to replace it's value. This would require a lot more tinkering in your current code, however, and depending on what else is happening in your app, may not be the ideal solution anyway.
Here's what I came up with. The key difference is introduction of a shared reactive variable rValues$dataClip that stores clipped data. Previously, data modification was achieved by a reactive function userDataProc. The output of that function was used for plotting which, as suggested by #Benjamin, was the culprit of double evaluation of plotting. In this version, the userDataProc is turned into observeEvent that monitors input$inDataClipMin numeric input field.
library(shiny)
ui <- shinyUI(fluidPage(
titlePanel("test data clipping"),
sidebarLayout(
sidebarPanel(
actionButton('inDataGen', 'Generate dataset'),
br(),
br(),
uiOutput('resetable_input_clip'),
actionButton('inDataClipReset', 'Reset data clipping')
),
mainPanel(plotOutput("plotHist", width = "100%"))
)
))
server <- shinyServer(function(input, output, session) {
rValues <- reactiveValues(dataIn = NULL,
dataClip = NULL,
dataMin = -10e10)
# generate random dataset
userDataGen <- observeEvent(input$inDataGen, {
cat(file = stderr(), '\nuserDataGen\n')
# assign result to shared 'dataIn' variable
x <- rnorm(1000)
rValues$dataIn = x
rValues$dataMin = min(x)
})
# modify data
userDataProc <- observeEvent(input$inDataClipMin, {
cat(file = stderr(), 'userDataProc\n')
dm = rValues$dataIn
if (is.null(rValues$dataIn))
rValues$dataClip = NULL
else {
dm[dm < input$inDataClipMin] <-
input$inDataClipMin
rValues$dataClip <- dm
}
})
output$resetable_input_clip <- renderUI({
cat(file = stderr(), 'output$resetable_input_clip\n')
times <- input$inDataClipReset
div(
id = letters[(times %% length(letters)) + 1],
numericInput(
'inDataClipMin',
'Clip data below threshold:',
value = rValues$dataMin,
width = 200,
step = 100
)
)
})
output$plotHist <- renderPlot({
cat(file = stderr(), 'plotHist \n')
if (is.null(rValues$dataClip))
return(NULL)
else {
plot(hist(rValues$dataClip))
Sys.sleep(2)
}
})
})
shinyApp(ui = ui, server = server)
Now, there's only one evaluation of plotHist after pressing the button to generate data:
output$resetable_input_clip
plotHist
userDataProc
userDataGen
output$resetable_input_clip
userDataProc
plotHist
I am using rhandsontable in a Shiny App and I would like to know how to use the getSelected() method of Handsontable in this case, as I intend to apply changes on the data.frame.
thank you!
You can obtain the selected row, column, range, and cell values, as well as the edited cells using selectCallback=TRUE. You can edit a cell by double-clicking on it, and accept the changes by pressing "return" or "enter".
Minimal example:
library(shiny)
library(rhandsontable)
ui=fluidPage(
rHandsontableOutput('table'),
verbatimTextOutput('selected')
)
server=function(input,output,session)({
df=data.frame(N=c(1:10),L=LETTERS[1:10],M=LETTERS[11:20])
output$table=renderRHandsontable(
rhandsontable(df,selectCallback = TRUE,readOnly = FALSE)
)
output$selected=renderPrint({
cat('Selected Row:',input$table_select$select$r)
cat('\nSelected Column:',input$table_select$select$c)
cat('\nSelected Cell Value:',
input$table_select$data[[
input$table_select$select$r]][[input$table_select$select$c]])
cat('\nSelected Range: R',input$table_select$select$r,
'C',input$table_select$select$c,':R',input$table_select$select$r2,
'C',input$table_select$select$c2,sep="")
cat('\nChanged Cell Row Column:',input$table$changes$changes[[1]][[1]],
input$table$changes$changes[[1]][[2]])
cat('\nChanged Cell Old Value:',input$table$changes$changes[[1]][[3]])
cat('\nChanged Cell New Value:',input$table$changes$changes[[1]][[4]])
})
}) # end server
shinyApp(ui = ui, server = server)
While rhandsontable is a real good implementation of handsontable (credit goes to #jrowen), currently it does not include getSelected().
The event of a user altering any cell (including selecting / deselecting a checkbox) is tracked by shiny. This gives the opportunity to use checkboxes to let the user to select (or de-select) one or more rows.
Unfortunately the logic to understand what has been selected needs to be developed on the server side by your code.
The snippet of code below may give you some idea on how to manage it.
options(warn=-1)
library(rhandsontable)
library(shiny)
options(warn=-1)
quantity <- id <- 1:20
label <- paste0("lab","-",quantity)
pick <- FALSE
iris_ <- data.frame(id=id,pick=pick, quantity=quantity,label=label,iris[1:20,] ,stringsAsFactors = FALSE)
mtcars_ <- data.frame(id=id,pick=pick, quantity=quantity,label=label,mtcars[1:20,] ,stringsAsFactors = FALSE)
iris_$Species <- NULL # i.e. no factors
#---------------------------
ui <- fluidPage(
fluidRow(
column(6,rHandsontableOutput('demTb')),
column(3,uiOutput("demSli")),
column(3, radioButtons("inButtn", label=NULL, choices= c("iris","mtcars"), selected = "iris", inline = TRUE))
)
)
server <- function(session, input, output) {
selData <- ""
output$demSli <- renderUI({
if(is.null(input$demTb) ) return()
isolate({
df_ <- hot_to_r(input$demTb)
index <- which(df_$pick==T)
if(length(index)==0) return()
labs <- iris_$label[index]
pages <- "test"
iter <- length(labs)
buttn <- 1
valLabs <- sapply(1:iter, function(i) {
if(is.null(input[[paste0(pages,"d",labs[i],buttn)]] )) {
0
} else { as.numeric(input[[paste0(pages,"d",labs[i],buttn)]]) }
})
#
toRender <- lapply(1:iter, function(i) {
sliderInput(inputId = paste0(pages,"d",labs[i],buttn),
label = h6(paste0(labs[i],"")),
min = -100,
max = 100,
step = 1,
value = valLabs[i],
post="%",
ticks = FALSE, animate = FALSE)
})
})
return(toRender)
})
#--------------------
rds <- reactive({
# if( is.null(input$demTb) ) {
if( input$inButtn == "iris") {
if(selData == "" | selData == "mtcars") {
selData <<- "iris"
return(iris_) # first time for iris
}
} else {
if(selData == "iris" ) {
selData <<- "mtcars"
return(mtcars_) # first time for mtcars
}
}
df_ <- hot_to_r(input$demTb)
isolate({
index <- which(df_$pick==T)
if(length(index)==0) return(df_)
labs <- iris_$label[index]
pages <- "test"
iter <- length(labs)
buttn <- 1
}) # end isolate
valLabs <- sapply(1:iter, function(i) {
if(is.null(input[[paste0(pages,"d",labs[i],buttn)]] )) {
0
} else {
as.numeric(input[[paste0(pages,"d",labs[i],buttn)]])/100
}
})
dft_ <- data.frame(label=labs, multi=valLabs, stringsAsFactors = FALSE)
dft_ <- merge(iris_,dft_,by="label", all.x=T)
dft_$quantity <- sapply(1:length(dft_$quantity), function(z) {
if( is.na( dft_$multi[z]) ) {
dft_$quantity[z]
} else { iris_$quantity[z]*(1 + dft_$multi[z]) }
})
dft_[with(dft_,order(as.numeric(id))),]
df_[with(df_,order(as.numeric(id))),]
df_$quantity <- df_$quantity
return(df_)
})
output$demTb <- renderRHandsontable({
if(is.null(rds() )) return()
df_ <- rds()
df_ <- df_[with(df_,order(as.numeric(id))),]
rhandsontable(df_, readOnly = FALSE, rowHeaders= NULL, useTypes= TRUE) %>%
hot_table(highlightCol = TRUE, highlightRow = TRUE)
})
}
shinyApp(ui, server)