2

I've got a Shiny app that works fine, but the selectInput values don't work when there are more than one to choose from.

The Shiny works with this in mind:
1) Pick a student
2) Pick a date that student took a test
3) Find the student's age
4) Plot the student's score against a cohort of similarly aged people who took the test in the past.

The app looks like this:

enter image description here

It works fine, but after the selectInput (aka dropdown) is created and the slider is adjusted for age, it won't fire when there is more than one choice:

enter image description here

The problem is that I don't know where to put the input$dates in order to select the ID.

I've had some similar issues here and here before but this is a new one.

EDIT ##

For anyone who got here via Google or whatnot, I just want to say that @Andriy Tkachenko's answer below is a great working example that can be expanded for whatever project you are working on. Assuming that your project may require selecting rows where there are multiple IDs and each of these IDs had a corresponding date.

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)
Community
  • 1
  • 1
tumultous_rooster
  • 12,150
  • 32
  • 92
  • 149
  • do you say that `select date` input don't work? – Andriy T. Jul 15 '15 at 07:30
  • @Matt O'Brien The above posted code crashes as soon as I try to change the value in 'Select New Student' numericInput object. Are you sure this is the code you are describing the above problem ? I can't change the student! I guess you need to use `updateSelectInput()` for your described problem above! – Shiva Jul 15 '15 at 13:03
  • @AndriyTkachenko, yes, when I try to select the second available date for the first student, the app won't execute. Do you know why this might be happening?` – tumultous_rooster Jul 15 '15 at 15:54
  • @Shiva: can you try again? I copied and pasted the code back into a blank script in RStudio and executed it and it works fine. Do you have `data.table` installed maybe? There should be 3 students to select from...it's the second student that has trouble when selecting his/her second available date. – tumultous_rooster Jul 15 '15 at 15:56
  • @MattO'Brien Try to change the input to the 'Select New Student' field manually, it is crashing. However, if you increment the number in that field using the mouse_click, it is not crashing! Have a look at that once ! – Shiva Jul 15 '15 at 17:16
  • @Shiva I had a look...and I swear it works fine both ways for me. Are we both on `shiny_0.12.1`? – tumultous_rooster Jul 15 '15 at 17:27
  • For me this code works OK. But @Shiva is right, it crashes when I select 0 or 4 students... you should put min and max to that `numericInput`. Another thing, you don't use `input$dates` anywhere, thats why app do nothing when you change `selectInput` value – Andriy T. Jul 16 '15 at 06:49
  • oh...I see what you guys were talking about. Yes I should put a `validate` in to avoid running out of IDs. But this is just a toy example. The real issue is EXACTLY what you just mentioned -- I don't know where to put the `input$dates` – tumultous_rooster Jul 16 '15 at 06:52
  • 1
    OK, I am working on it right now. Hope to post an answer in a few minutes – Andriy T. Jul 16 '15 at 06:55

1 Answers1

2

Here is the modified code. I've highlighted the parts where I changed something. Take a look:

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)
tumultous_rooster
  • 12,150
  • 32
  • 92
  • 149
Andriy T.
  • 2,020
  • 12
  • 23
  • This is really interesting. Turns out there was no need for the `observe` block I had put in. And the `input$dates` showed up in the block where the plotting was done. Thanks!!! – tumultous_rooster Jul 16 '15 at 22:11