r - Alternate control of a sliderInput between a derived value and user selected value -
i have simple shiny app, wherein have set of data on past customers, , set of data on 3 new customers. data consists of 2 variables: age , score.
the purpose select 1 of 3 new customers, , see how past customers of similar ages scored. simple scatterplot.
for example, since new customer #1 30 years old, see how past customers of ages 25 - 35 scored:

(my apologies small image)
everything works fine. trouble begins when add age slider intentions of allowing user override default view supplied behind scenes new customer's age.
to continue example, curious see how past customers of, ages 18 - 40 scored, no longer ages 25 - 35.
somehow, need implement two-step process:
- subsetting of data needs begin hard coded +- 5 respect selected new customer's age.
- next -- subsetting of data needs controlled slider on ui.
i'm facing fundamental issue of telling shiny communicate between ui , data 2 different ways, @ different times. ideas on how can through this?
full code follow...but i'm thinking out loud here: somehow need change:
subset_historic_customers <- reactive({ df <- historic_customers[which((historic_customers$age >= get_selected_customer()$age-5) & (historic_customers$age <= get_selected_customer()$age+5)), ] return(df) })
to
subset_historic_customers <- reactive({ # start same above: df <- historic_customers[which((historic_customers$age >= get_selected_customer()$age-5) & (historic_customers$age <= get_selected_customer()$age+5)), ] return(df) # ...but if uses age selection slider, then: df <- historic_customers[which((historic_customers$age >= input$age[1]) & (historic_customers$age <= input$age[2])), ] })
thanks!
app.r
## app.r ## server <- function(input, output) { new_customers <- data.frame(age=c(30, 35, 40), score=c(-1.80, 1.21, -0.07)) historic_customers <- data.frame(age=sample(18:55, 500, replace=t), score=(rnorm(500))) get_selected_customer <- reactive({cust <- new_customers[input$cust_no, ] return(cust)}) subset_historic_customers <- reactive({ df <- historic_customers[which((historic_customers$age >= get_selected_customer()$age-5) & (historic_customers$age <= get_selected_customer()$age+5)), ] # df <- historic_customers[which((historic_customers$age >= input$age[1]) & (historic_customers$age <= input$age[2])), ] return(df) }) output$distplot <- renderplot({ plotme <<- subset_historic_customers() p <- ggplot(data=plotme, aes(x=plotme$age, y=plotme$score))+ geom_point() my_cust_age <- data.frame(get_selected_customer()) p <- p + geom_vline(data=my_cust_age, aes(xintercept=age)) print(p) }) } ui <- fluidpage( sidebarlayout( sidebarpanel( numericinput(inputid="cust_no", label="select new customer:", value=1), sliderinput(inputid="age", "age of historic customer:", min=18, max = 55, value=c(18, 55), step=1, ticks=true) ), mainpanel(plotoutput("distplot")) ) ) shinyapp(ui = ui, server = server)
i believe code want. it's not complicated, hope helps
new_customers <- data.frame(age=c(30, 35, 40), score=c(-1.80, 1.21, -0.07)) historic_customers <- data.frame(age=sample(18:55, 500, replace=t), score=(rnorm(500))) server <- function(input, output, session) { get_selected_customer <- reactive({ new_customers[input$cust_no, ] }) observe({ cust <- get_selected_customer() updatesliderinput(session, "age", value = c(cust$age - 5, cust$age + 5)) }) subset_historic_customers <- reactive({ df <- historic_customers[which((historic_customers$age >= input$age[1]) & (historic_customers$age <= input$age[2])), ] df }) output$distplot <- renderplot({ plotme <- subset_historic_customers() p <- ggplot(data=plotme, aes(x=age, y=score))+ geom_point() my_cust_age <- data.frame(get_selected_customer()) p <- p + geom_vline(data=my_cust_age, aes(xintercept=age)) p }) } ui <- fluidpage( sidebarlayout( sidebarpanel( numericinput(inputid="cust_no", label="select new customer:", value=1), sliderinput(inputid="age", "age of historic customer:", min=18, max = 55, value=c(18, 55), step=1, ticks=true) ), mainpanel(plotoutput("distplot")) ) ) shinyapp(ui = ui, server = server)
Comments
Post a Comment