如果填充了多个选项（在 Shiny 中），则 selectInput 不会触发
selectInput won't fire if there is more than one option populated (in Shiny)
我有一个运行良好的 Shiny 应用程序，但是当有多个可供选择时 selectInput 值不起作用。
The Shiny 考虑到这一点：
1) 选择一个学生
2) 选择学生参加考试的日期
3) 找出学生的年龄
4) 将学生的分数与过去参加过考试的一组年龄相仿的人作对比。
该应用程序如下所示：
它工作正常，但在创建 selectInput（又名下拉菜单）并根据年龄调整滑块后，当有多个选择时它不会触发：
问题是我不知道将 input$dates 放在哪里才能 select ID。
我之前遇到过一些类似的问题 and 但这是一个新问题。
编辑##
对于通过 Google 或诸如此类的方式来到这里的任何人，我只想说@Andriy Tkachenko 下面的回答是一个很好的工作示例，可以针对您正在进行的任何项目进行扩展。假设您的项目可能需要 selecting 行，其中有多个 ID，并且每个 ID 都有对应的日期。
app.R
library('shiny')
library('plyr')
library('ggplot2')
library('data.table')
server <- function(input, output, session) {
output$distPlot <- renderPlot({
plotme <<- subset_historic_students()
p <- ggplot(data=plotme, aes(x=plotme$age, y=plotme$score))+ geom_point()
my_cust_age <- data.frame(get_selected_student())
p <- p + geom_vline(data=my_cust_age, aes(xintercept=age))
print(p)
})
new_students <- data.frame(id=c(1,2,2,3), date=c('1/1/2011', '2/2/2012', '2/2/2022', '3/3/2013'), age=c(15, 25, 35, 45), score=c(-0.80, 0.21, 1.0, -0.07))
new_students$date <- as.character(new_students$date)
historic_students <- data.frame(age=c(11,12,15,16,19,21,22,25,26,29,31,32,35,36,39,41,42,45,46,49), score=(rnorm(20)))
# we must deal with the fact that Shiny barfs on duplicates.
# we need to append a visit number (eg, 'C1)' ) to the end of the `date` string.
DT_new_students <- data.table(new_students)
DT_new_students[, .id := sequence(.N), by = "id"]
new_students$date <- paste(new_students$date, ' (', DT_new_students$.id, ')', sep='')
get_selected_student <- reactive({student <- new_students[which(new_students$id==input$id), ]
return(student[1,])})
output$dates<-renderUI({
print("HI")
selectInput('dates', 'Select Date', choices=new_students[which(new_students$id == get_selected_student()$id), ]$date, selected=new_students[which(new_students$id == get_selected_student()$id), ]$date, selectize = FALSE)
})
## age text output
output$print_age <- renderText({
selected_student <- get_selected_student()
if (is.numeric((selected_student[1, 'age'])) &&
!is.na((selected_student[1, 'age']))){
paste("Age of selected student: ", selected_student[1, 'age'])
}
})
subset_historic_students <- reactive({
DF <- historic_students[which((input$age[1] <= historic_students$age) & (input$age[2] >= historic_students$age)), ]
return(DF)
})
# this observe block will reset the upper and lower values for the Select Age slider
observe({
new_cust <- get_selected_student()
new_min <- round_any(new_cust$age, 10, floor)
new_max <- new_min+9
if(is.na(new_min)){ # before any PIDN is selected, the observe still runs. Thus we needed to prevent an NA here, which was appearing on the lower bound of the slider.
new_min <- min_age
}
if(is.na(new_max)){
new_max <- max_age
}
updateSliderInput(session, "age", value = c(new_min, new_max))
})
}
ui <- fluidPage( headerPanel(title = ""),
sidebarLayout(
sidebarPanel(
numericInput(inputId="id", label="Select new student:", value=1),
uiOutput("dates"),
textOutput("print_age"),
sliderInput(inputId="age", "Age of historic students:", min=0, max = 55, value=c(18, 100), step=1, ticks=TRUE)
),
mainPanel(plotOutput("distPlot"))
)
)
shinyApp(ui = ui, server = server)
这是修改后的代码。我已经突出显示了我更改内容的部分。看看：
library('shiny')
library('plyr')
library('ggplot2')
library('data.table')
new_students <- data.frame(id=c(1,2,2,3), date=c('1/1/2011', '2/2/2012', '2/2/2022', '3/3/2013')
, age=c(15, 25, 35, 45), score=c(-0.80, 0.21, 1.0, -0.07))
new_students$date <- as.character(new_students$date)
historic_students <-
data.frame(age=c(11,12,15,16,19,21,22,25,26,29,31,32,35,36,39,41,42,45,46,49)
, score=(rnorm(20)))
# we must deal with the fact that Shiny barfs on duplicates.
# we need to append a visit number (eg, 'C1)' ) to the end of the `date` string.
DT_new_students <- data.table(new_students)
DT_new_students[, .id := sequence(.N), by = "id"]
new_students$date <- paste(new_students$date, ' (', DT_new_students$.id, ')', sep='')
server <- function(input, output, session) {
get_selected_student <-
reactive({student <- new_students[which(new_students$id==input$id), ]
#------------------------------------------------!
########## here I return all subseted data
#------------------------------------------------!
return(student)
#------------------------------------------------!
})
output$dates<-renderUI({
# print("HI")
selectInput('dates', 'Select Date'
#------------------------------------------------!
########## here take 1 row from get_selected_student because it is the same in all rows
#------------------------------------------------!
, choices=new_students[new_students$id == input$id, "date"]
, selected = 1
#------------------------------------------------!
, selectize = FALSE)
})
output$age_input <- renderUI({
new_cust <- get_selected_student()
new_cust <- new_cust[new_cust$date == input$dates,]
new_min <- round_any(new_cust$age, 10, floor)
new_max <- new_min+9
if(is.na(new_min)){ # before any PIDN is selected, the observe still runs.
# Thus we needed to prevent an NA here
# , which was appearing on the lower bound of the slider.
new_min <- min_age
}
if(is.na(new_max)){
new_max <- max_age
}
sliderInput(inputId="age", "Age of historic students:", min=0
, max = 55, value=c(new_min, new_max), step=1, ticks=TRUE)
})
subset_historic_students <- reactive({
DF <- historic_students[which((input$age[1] <= historic_students$age) &
(input$age[2] >= historic_students$age)), ]
return(DF)
})
## age text output
output$print_age <- renderText({
selected_student <- get_selected_student()
if (is.numeric((selected_student[1, 'age'])) &&
!is.na((selected_student[1, 'age']))){
paste("Age of selected student: ", selected_student[1, 'age'])
}
})
output$distPlot <- renderPlot({
plotme <<- subset_historic_students()
p <- ggplot(data=plotme, aes(x=plotme$age, y=plotme$score))+ geom_point()
my_cust_age <- data.frame(get_selected_student())
#------------------------------------------------!
########## here is where dates input plays
#------------------------------------------------!
my_cust_age <- my_cust_age[my_cust_age$date == input$dates,]
#------------------------------------------------!
p <- p + geom_vline(data=my_cust_age, aes(xintercept=age))
print(p)
})
}
ui <- fluidPage( headerPanel(title = ""),
sidebarLayout(
sidebarPanel(
#------------------------------------------------!
########## add min and max values to a input
#------------------------------------------------!
numericInput(inputId="id", label="Select new student:", value=1
, min = 1, max = 3),
#------------------------------------------------!
uiOutput("dates"),
textOutput("print_age"),
htmlOutput("age_input")
),
mainPanel(plotOutput("distPlot"))
)
)
shinyApp(ui = ui, server = server)
我有一个运行良好的 Shiny 应用程序，但是当有多个可供选择时 selectInput 值不起作用。
The Shiny 考虑到这一点：
1) 选择一个学生
2) 选择学生参加考试的日期
3) 找出学生的年龄
4) 将学生的分数与过去参加过考试的一组年龄相仿的人作对比。
该应用程序如下所示：
它工作正常，但在创建 selectInput（又名下拉菜单）并根据年龄调整滑块后，当有多个选择时它不会触发：
问题是我不知道将 input$dates 放在哪里才能 select ID。
我之前遇到过一些类似的问题
编辑##
对于通过 Google 或诸如此类的方式来到这里的任何人，我只想说@Andriy Tkachenko 下面的回答是一个很好的工作示例，可以针对您正在进行的任何项目进行扩展。假设您的项目可能需要 selecting 行，其中有多个 ID，并且每个 ID 都有对应的日期。
app.R
library('shiny')
library('plyr')
library('ggplot2')
library('data.table')
server <- function(input, output, session) {
output$distPlot <- renderPlot({
plotme <<- subset_historic_students()
p <- ggplot(data=plotme, aes(x=plotme$age, y=plotme$score))+ geom_point()
my_cust_age <- data.frame(get_selected_student())
p <- p + geom_vline(data=my_cust_age, aes(xintercept=age))
print(p)
})
new_students <- data.frame(id=c(1,2,2,3), date=c('1/1/2011', '2/2/2012', '2/2/2022', '3/3/2013'), age=c(15, 25, 35, 45), score=c(-0.80, 0.21, 1.0, -0.07))
new_students$date <- as.character(new_students$date)
historic_students <- data.frame(age=c(11,12,15,16,19,21,22,25,26,29,31,32,35,36,39,41,42,45,46,49), score=(rnorm(20)))
# we must deal with the fact that Shiny barfs on duplicates.
# we need to append a visit number (eg, 'C1)' ) to the end of the `date` string.
DT_new_students <- data.table(new_students)
DT_new_students[, .id := sequence(.N), by = "id"]
new_students$date <- paste(new_students$date, ' (', DT_new_students$.id, ')', sep='')
get_selected_student <- reactive({student <- new_students[which(new_students$id==input$id), ]
return(student[1,])})
output$dates<-renderUI({
print("HI")
selectInput('dates', 'Select Date', choices=new_students[which(new_students$id == get_selected_student()$id), ]$date, selected=new_students[which(new_students$id == get_selected_student()$id), ]$date, selectize = FALSE)
})
## age text output
output$print_age <- renderText({
selected_student <- get_selected_student()
if (is.numeric((selected_student[1, 'age'])) &&
!is.na((selected_student[1, 'age']))){
paste("Age of selected student: ", selected_student[1, 'age'])
}
})
subset_historic_students <- reactive({
DF <- historic_students[which((input$age[1] <= historic_students$age) & (input$age[2] >= historic_students$age)), ]
return(DF)
})
# this observe block will reset the upper and lower values for the Select Age slider
observe({
new_cust <- get_selected_student()
new_min <- round_any(new_cust$age, 10, floor)
new_max <- new_min+9
if(is.na(new_min)){ # before any PIDN is selected, the observe still runs. Thus we needed to prevent an NA here, which was appearing on the lower bound of the slider.
new_min <- min_age
}
if(is.na(new_max)){
new_max <- max_age
}
updateSliderInput(session, "age", value = c(new_min, new_max))
})
}
ui <- fluidPage( headerPanel(title = ""),
sidebarLayout(
sidebarPanel(
numericInput(inputId="id", label="Select new student:", value=1),
uiOutput("dates"),
textOutput("print_age"),
sliderInput(inputId="age", "Age of historic students:", min=0, max = 55, value=c(18, 100), step=1, ticks=TRUE)
),
mainPanel(plotOutput("distPlot"))
)
)
shinyApp(ui = ui, server = server)
这是修改后的代码。我已经突出显示了我更改内容的部分。看看：
library('shiny')
library('plyr')
library('ggplot2')
library('data.table')
new_students <- data.frame(id=c(1,2,2,3), date=c('1/1/2011', '2/2/2012', '2/2/2022', '3/3/2013')
, age=c(15, 25, 35, 45), score=c(-0.80, 0.21, 1.0, -0.07))
new_students$date <- as.character(new_students$date)
historic_students <-
data.frame(age=c(11,12,15,16,19,21,22,25,26,29,31,32,35,36,39,41,42,45,46,49)
, score=(rnorm(20)))
# we must deal with the fact that Shiny barfs on duplicates.
# we need to append a visit number (eg, 'C1)' ) to the end of the `date` string.
DT_new_students <- data.table(new_students)
DT_new_students[, .id := sequence(.N), by = "id"]
new_students$date <- paste(new_students$date, ' (', DT_new_students$.id, ')', sep='')
server <- function(input, output, session) {
get_selected_student <-
reactive({student <- new_students[which(new_students$id==input$id), ]
#------------------------------------------------!
########## here I return all subseted data
#------------------------------------------------!
return(student)
#------------------------------------------------!
})
output$dates<-renderUI({
# print("HI")
selectInput('dates', 'Select Date'
#------------------------------------------------!
########## here take 1 row from get_selected_student because it is the same in all rows
#------------------------------------------------!
, choices=new_students[new_students$id == input$id, "date"]
, selected = 1
#------------------------------------------------!
, selectize = FALSE)
})
output$age_input <- renderUI({
new_cust <- get_selected_student()
new_cust <- new_cust[new_cust$date == input$dates,]
new_min <- round_any(new_cust$age, 10, floor)
new_max <- new_min+9
if(is.na(new_min)){ # before any PIDN is selected, the observe still runs.
# Thus we needed to prevent an NA here
# , which was appearing on the lower bound of the slider.
new_min <- min_age
}
if(is.na(new_max)){
new_max <- max_age
}
sliderInput(inputId="age", "Age of historic students:", min=0
, max = 55, value=c(new_min, new_max), step=1, ticks=TRUE)
})
subset_historic_students <- reactive({
DF <- historic_students[which((input$age[1] <= historic_students$age) &
(input$age[2] >= historic_students$age)), ]
return(DF)
})
## age text output
output$print_age <- renderText({
selected_student <- get_selected_student()
if (is.numeric((selected_student[1, 'age'])) &&
!is.na((selected_student[1, 'age']))){
paste("Age of selected student: ", selected_student[1, 'age'])
}
})
output$distPlot <- renderPlot({
plotme <<- subset_historic_students()
p <- ggplot(data=plotme, aes(x=plotme$age, y=plotme$score))+ geom_point()
my_cust_age <- data.frame(get_selected_student())
#------------------------------------------------!
########## here is where dates input plays
#------------------------------------------------!
my_cust_age <- my_cust_age[my_cust_age$date == input$dates,]
#------------------------------------------------!
p <- p + geom_vline(data=my_cust_age, aes(xintercept=age))
print(p)
})
}
ui <- fluidPage( headerPanel(title = ""),
sidebarLayout(
sidebarPanel(
#------------------------------------------------!
########## add min and max values to a input
#------------------------------------------------!
numericInput(inputId="id", label="Select new student:", value=1
, min = 1, max = 3),
#------------------------------------------------!
uiOutput("dates"),
textOutput("print_age"),
htmlOutput("age_input")
),
mainPanel(plotOutput("distPlot"))
)
)
shinyApp(ui = ui, server = server)