如果填充了多个选项，则selectInput不会触发（在Shiny中）

时间：2015-07-15 07:12:20

标签： r shiny reactive-programming

我有一个运行良好的Shiny应用程序，但当有多个值可供选择时，selectInput值不起作用。

Shiny以此为依据：
1）选择一名学生 2）选择学生参加考试的日期
3）找到学生的年龄
4）将学生的分数绘制在过去参加考试的同龄人群中。

该应用程序如下所示：

enter image description here

它工作正常，但在创建selectInput（又名下拉列表）并调整滑块的年龄后，当有多个选项时，它不会被激活：

enter image description here

问题在于我不知道在哪里放置input$dates以便选择ID。

我之前遇到过类似问题here和here，但这是一个新问题。

编辑##

对于通过Google或诸如此类来到这里的任何人，我只想说@Andriy Tkachenko的回答是一个很好的工作示例，可以针对您正在进行的任何项目进行扩展。假设您的项目可能需要选择有多个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)

1 个答案:

答案 0 :(得分：2)

这是修改后的代码。我突出了改变了一些东西的部分。看看：

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)
相关问题
最新问题