Referencing a dynamic input ID in Shiny - r

Question

In the example below, I am trying to produce a box and plot for each group within a dataset, using lapply within a renderUI function. However, some of these groups require an additional filter as they have sub-groupings.
This means creating a selectInput inside the box for those groups only and having the corresponding chart reference that selectInput only.
Here's the reproducible example... my problem is in the lapply loop creating a selectInput with the inputID of paste("selector_",i) and then immediately referencing this in the data to be output inside the corresponding box with input$(what goes here?)
library(shiny)
library(shinydashboard)
library(tidyverse)
library(nycflights13)
library(DT)
data <- planes %>%
select(manufacturer, type, model, year, seats) %>%
unique() %>%
filter(!is.na(year)) %>%
mutate(year = as.character(year))
ui <- dashboardPage(
dashboardHeader(title = "Testing"),
dashboardSidebar(),
dashboardBody(
fluidRow(
column(12, selectInput("type","Type", choices = unique(data$type)),
uiOutput("mytabs"))
)
)
)
server <- function(input, output) {
data_filtered <- reactive({
req(input$type)
data %>%
filter(type == input$type)
})
mfrs <- reactive({
data_filtered() %>%
select(manufacturer) %>%
unique() %>%
pull()
})
output$mytabs = renderUI({
fluidRow(
lapply(mfrs(), function(i) {
dt <- data_filtered() %>%
filter(manufacturer == i) %>%
arrange(year) %>%
select(model, year, seats)
models <- dt %>%
filter(!is.na(model)) %>%
select(model) %>%
unique() %>%
pull()
if(length(models) > 1) {
box(id = paste0('card', i), title = paste(i),
selectInput(inputId = paste0("selector_",i), "Question",
choices = models, selected = models[1]),
DT::datatable(dt[dt$qntext == input$the_one_above],
width = "100%", rownames = F,
options = list(
columnDefs = list(list(width = '40px', targets = "_all"))
))
)
} else {
box(id = paste0('card', i), title = paste(i),
DT::datatable(dt,
width = "100%", rownames = F,
options = list(
columnDefs = list(list(width = '40px', targets = "_all"))
))
)
}
})
)
})
}
shinyApp(ui, server)

Answer 1

As I am not sure what qns means, I have assigned qns to be models. Try this code:
data <- planes %>%
select(manufacturer, type, model, year, seats) %>%
unique() %>%
filter(!is.na(year)) %>%
mutate(year = as.character(year))
ui <- dashboardPage(
dashboardHeader(title = "Testing"),
dashboardSidebar(uiOutput("myqns")),
dashboardBody(
fluidRow(
column(12, selectInput("type","Type", choices = unique(data$type)), uiOutput("mytabs"))
)
)
)
server <- function(input, output) {
data_filtered <- reactive({
req(input$type)
data %>%
filter(type == input$type)
})
mfrs <- reactive({
req(data_filtered())
data_filtered() %>%
select(manufacturer) %>%
unique() %>%
pull()
})
output$myqns <- renderUI({
req(mfrs())
lapply(1:length(mfrs()), function(i) {
dt <- data_filtered() %>%
filter(manufacturer == mfrs()[i]) %>%
arrange(year) %>%
select(model, year, seats)
models <- dt %>%
filter(!is.na(model)) %>%
select(model) %>%
unique() %>%
pull()
qns <- models
selectInput(inputId = paste0("selector_",i), paste("Question",i), choices = as.list(qns), selected = 1)
})
})
output$mytabs = renderUI({
req(mfrs())
fluidRow(
lapply(1:length(mfrs()), function(i) {
req(input[[paste0("selector_",i)]])
dt <- data_filtered() %>%
filter(manufacturer == mfrs()[i]) %>%
arrange(year) %>%
select(model, year, seats)
models <- dt %>%
filter(!is.na(model)) %>%
select(model) %>%
unique() %>%
pull()
qns <- models
if(length(models) > 1) {
box(id = paste0('card', i), title = paste(mfrs()[i]),
# selectInput(inputId = paste0("selector_",i), "Question",
# choices = qns, selected = qns[1]),
DT::datatable(dt[dt$model == input[[paste0("selector_",i)]], ],
width = "100%", rownames = F,
options = list(
columnDefs = list(list(width = '40px', targets = "_all"))
))
)
} else {
box(id = paste0('card', i), title = paste(mfrs()[i]),
DT::datatable(dt,
width = "100%", rownames = F,
options = list(
columnDefs = list(list(width = '40px', targets = "_all"))
))
)
}
})
)
})
}
shinyApp(ui, server)

Answer 2

Answered by the awesome Paul Campbell... using modules.
library(shinydashboard)
library(tidyverse)
library(highcharter)
library(nycflights13)
# Modules ===============================================
# UI and server module for box with chart
box_chart_UI <- function(id, title) {
ns <- NS(id)
box(
title = title, height = 550,
highcharter::highchartOutput(ns("chart"))
)
}
box_chart <- function(input, output, session, df) {
output$chart <- renderHighchart({
validate(need(nrow(df) > 0, "No data"))
hchart(df, "column", hcaes(year, seats))
})
}
# UI and server module for box with chart and filter
box_chart_filter_UI <- function(id, title, filters, filter_lab = "Model") {
ns <- NS(id)
box(
title = title, height = 550,
selectInput(inputId = ns("selector"), label = filter_lab, choices = filters),
highchartOutput(ns("chart"))
)
}
box_chart_filter <- function(input, output, session, df) {
output$chart <- renderHighchart({
req(input$selector)
df_chart <- df %>% filter(model == input$selector)
validate(need(nrow(df_chart) > 0, "No data"))
hchart(df_chart, "column", hcaes(year, seats))
})
}
# Main App ===============================================
# load app data
data <- planes %>%
select(manufacturer, type, model, year, seats) %>%
unique() %>%
filter(!is.na(year)) %>%
mutate(year = as.character(year))
ui <- dashboardPage(
dashboardHeader(title = "Testing"),
dashboardSidebar(),
dashboardBody(
fluidRow(
column(
width = 12,
selectInput("type", "Type", choices = unique(data$type))
)
),
uiOutput("mytabs")
)
)
server <- function(input, output, session) {
data_filtered <- reactive({
req(input$type)
data %>% filter(type == input$type)
})
mfrs <- reactive({
data_filtered() %>%
distinct(manufacturer) %>%
pull()
})
# first load all the UI module functions
output$mytabs <- renderUI({
fluidRow(
lapply(1:length(mfrs()), function(i) {
models <- data_filtered() %>%
filter(manufacturer == mfrs()[i], !is.na(model)) %>%
distinct(model) %>%
pull() %>%
sort()
# depending on how many models, load the correct UI module
if (length(models) > 1) {
box_chart_filter_UI(id = i, title = mfrs()[i], filters = models)
} else {
box_chart_UI(id = i, title = mfrs()[i])
}
})
)
})
# now separately load the module server functions
# need to do this inside an observe due to reactive objects
observe({
lapply(1:length(mfrs()), function(i) {
dt <- data_filtered() %>%
filter(manufacturer == mfrs()[i]) %>%
arrange(year) %>%
select(model, year, seats)
models <- dt %>%
filter(!is.na(model)) %>%
distinct(model) %>%
pull() %>%
sort()
# depending on how many models, load the correct server module
if (length(models) > 1) {
callModule(box_chart_filter, id = i, df = dt)
} else {
callModule(box_chart, id = i, df = dt)
}
})
})
}
shinyApp(ui, server)