Alternate control of a sliderInput between a derived value and user selected value

Question

I have a very simple Shiny app, wherein I have a set of data on past customers, and a set of data on 3 new customers. All my data consists only of 2 variables: age and score.

The purpose is to select one of the 3 new customers, and see how the past customers of similar ages scored. We do this with a simple scatterplot.

For example, since new customer #1 is 30 years old, we get to see how all the past customers of ages 25 - 35 scored:

(my apologies for the small image)

Everything works fine. The trouble begins when I add an age slider with the intentions of allowing the user to override the default view supplied behind the scenes by the new customer's age.

To continue with the example, say we are curious to see how past customers of, say ages 18 - 40 scored, no longer just ages 25 - 35.

Somehow, I need to implement a two-step process:

1. subsetting of the data needs to BEGIN with a hard coded +- 5 with respect to the selected new customer's age.
2. NEXT -- the subsetting of the data needs to be controlled by the slider on the UI.

I'm facing a fundamental issue of telling Shiny to communicate between the UI and the data two different ways, at different times. Any ideas on how I can get through this?

Full code to follow...but I'm thinking out loud here: I somehow need to 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 the same as 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 someone uses the 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)

Answer 1

I believe this is the code you want. It's not too complicated, I hope it 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)