i've got shiny app works fine, selectinput values don't work when there more 1 choose from.
the shiny works in mind:
1) pick student
2) pick date student took test
3) find student's age
4) plot student's score against cohort of aged people took test in past.
the app looks this:
it works fine, after selectinput (aka dropdown) created , slider adjusted age, won't fire when there more 1 choice:
the problem don't know put input$dates in order select id.
i've had similar issues here , here before new one.
edit ##
for got here via google or whatnot, want @andriy tkachenko's answer below great working example can expanded whatever project working on. assuming project may require selecting rows there multiple ids , each of these ids had 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))) # must deal fact shiny barfs on duplicates. # need append visit number (eg, 'c1)' ) end of `date` string. dt_new_students <- data.table(new_students) dt_new_students[, .id := sequence(.n), = "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) }) # observe block reset upper , lower values 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 pidn selected, observe still runs. needed prevent na here, appearing on lower bound of 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)
here modified code. i've highlighted parts changed something. take 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))) # must deal fact shiny barfs on duplicates. # need append visit number (eg, 'c1)' ) end of `date` string. dt_new_students <- data.table(new_students) dt_new_students[, .id := sequence(.n), = "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 return subseted data #------------------------------------------------! return(student) #------------------------------------------------! }) output$dates<-renderui({ # print("hi") selectinput('dates', 'select date' #------------------------------------------------! ########## here take 1 row get_selected_student because same in 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 pidn selected, observe still runs. # needed prevent na here # , appearing on lower bound of 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 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 , max values 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) 
Comments
Post a Comment