Проблемы с существующим кодом
Здесь есть несколько проблем с кодом, и решение позволяет нам ввести концепцию памяти в приложение. Прежде всего, есть две проблемы, которые я хотел бы решить сразу.
c("big", "small", "medium", "big", "medium"), а не c("big", "small", "medium", "big", "miedium")
Комбинация uiOutput() и renderUI() приводит к тому, что сервер обслуживает кнопку new selectInput при каждом изменении входа. Вместо этого мы можем просто создать экземпляр статического элемента пользовательского интерфейса и обновить его, используя updateSelectInput()
Решение
Чтобы решить эту проблему, давайте сначала исправим 1) и 2), описанные выше. Затем нам нужно ввести понятие памяти. Сервер должен знать, что было выбрано ранее, чтобы мы могли установить его как параметр по умолчанию при обновлении selectInput. Мы можем сохранить его как обычный список (переменная для года, месяца, типа и размера) или реактивный список, используя reactiveValues.
Здорово, что вы установили четкую логику для параметров фильтрации, существует четкая иерархия по годам -> месяцам -> типам -> размеру. Однако каждый раз months менялся, например, генерировался новый ввод для type и size.
Теперь мы хотели бы ввести простую логику, в которой выбор входа изменяет только память selected_vals. Затем изменение в памяти запускает другие входные данные для обновления. Это лучше всего видно в приведенном ниже решении.
Кодовое решение
library("shiny")
library("plotly")
library("dplyr")
data <- data.frame(year = rep(c(rep(2018, 6), rep(2019, 11)), each = 5),
month = rep(c(7:12, 1:11), each = 5),
type = rep(c("AGD", "AGD", "AGD", "RTV", "RTV"), 6 + 11),
value = sample(1:100, 85),
size = rep(c("big", "small", "medium", "big", "medium"), 6 + 11))
years = data %>% arrange(year) %>% .$year %>% unique(.)
month = data %>% arrange(month) %>% .$month %>% unique(.)
type = data %>% arrange(type)%>% .$type %>% unique(.)
size = data %>% arrange(size) %>%.$size %>% unique(.)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("year","Year",choices = years,selected = 2018),
selectInput("month","Month",choices = month,selected = 7),
selectInput("type","Type",choices = type,selected = "AGD"),
selectInput("size","Size",choices = size,selected = "big")
),
mainPanel(
)
)
)
server <- function(input, output, session) {
#------- Initialize the Memory ----------
selected_vals = reactiveValues(year = 2019,month = 7, type = "AGD", size = "big")
#------ Whenever any of the inputs are changed, it only modifies the memory----
observe({
req(input$year,input$month,input$type,input$size)
selected_vals$year <- input$year
selected_vals$month <- input$month
selected_vals$type <- input$type
selected_vals$size <- input$size
})
#------ Update all UI elements using the values stored in memory ------
observe({
year <- data %>%
select(year) %>%
unique()
updateSelectInput(session,"year",choices = year$year,selected = selected_vals$year)
})
observe({
month <- data %>%
filter(year == selected_vals$year) %>%
select(month) %>%
unique() %>%
arrange()
#Check if the value is in memory, if not return NULL (it defaults to the first element)
if (selected_vals$month %in% month$month) displayVal = selected_vals$month else displayVal = NULL
updateSelectInput(session,"month",choices = month$month,selected = displayVal)
})
observe({
type <- data %>%
filter(year == selected_vals$year,
month == selected_vals$month) %>%
select(type) %>%
unique() %>%
arrange()
#Check if the value is in memory, if not return NULL (it defaults to the first element)
if (selected_vals$type %in% type$type) displayVal = selected_vals$type else displayVal = NULL
updateSelectInput(session,"type",choices = type$type,selected = displayVal)
})
observe({
size <- data %>%
filter(year == selected_vals$year,
month == selected_vals$month,
type == selected_vals$type) %>%
select(size) %>%
unique() %>%
arrange()
#Check if the value is in memory, if not return NULL (it defaults to the first element)
if(selected_vals$size %in% size$size) displayVal = selected_vals$size else displayVal = NULL
updateSelectInput(session,"size",choices = size$size,selected = displayVal)
})
}
shinyApp(ui = ui, server = server)
Редактировать
Как указано в комментарии ниже, в коде есть ошибка. Это связано с тем, что displayVal = NULL задает значение по умолчанию для отображения в качестве первого элемента в массиве. Однако мы забываем сохранить это в памяти, selected_vals. Код ниже исправляет это.
library("shiny")
library("plotly")
library("dplyr")
data <- data.frame(year = rep(c(rep(2018, 6), rep(2019, 11)), each = 5),
month = rep(c(7:12, 1:11), each = 5),
type = rep(c("AGD", "AGD", "AGD", "RTV", "RTV"), 6 + 11),
value = sample(1:100, 85),
size = rep(c("big", "small", "medium", "big", "medium"), 6 + 11))
years = data %>% arrange(year) %>% .$year %>% unique(.)
month = data %>% arrange(month) %>% .$month %>% unique(.)
type = data %>% arrange(type)%>% .$type %>% unique(.)
size = data %>% arrange(size) %>%.$size %>% unique(.)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("year","Year",choices = years,selected = 2018),
selectInput("month","Month",choices = month,selected = 7),
selectInput("type","Type",choices = type,selected = "AGD"),
selectInput("size","Size",choices = size,selected = "big")
),
mainPanel(
)
)
)
server <- function(input, output, session) {
#------- Initialize the Memory ----------
selected_vals = reactiveValues(year = 2019,month = 7, type = "AGD", size = "big")
#------ Whenever any of the inputs are changed, it only modifies the memory----
observe({
req(input$year,input$month,input$type,input$size)
selected_vals$year <- input$year
selected_vals$month <- input$month
selected_vals$type <- input$type
selected_vals$size <- input$size
})
#------ Update all UI elements using the values stored in memory ------
observe({
year <- data %>%
select(year) %>%
unique()
updateSelectInput(session,"year",choices = year$year,selected = selected_vals$year)
})
observe({
month <- data %>%
filter(year == selected_vals$year) %>%
select(month) %>%
unique() %>%
arrange()
#Check if the value is in memory, if not return NULL (it defaults to the first element)
if (selected_vals$month %in% month$month){
displayVal = selected_vals$month
}else{
displayVal = NULL
selected_vals$month = month$month[1]
}
updateSelectInput(session,"month",choices = month$month,selected = displayVal)
})
observe({
type <- data %>%
filter(year == selected_vals$year,
month == selected_vals$month) %>%
select(type) %>%
unique() %>%
arrange()
#Check if the value is in memory, if not return NULL (it defaults to the first element)
if (selected_vals$type %in% type$type){
displayVal = selected_vals$type
}else{
displayVal = NULL
selected_vals$type = tpye$type[1]
}
updateSelectInput(session,"type",choices = type$type,selected = displayVal)
})
observe({
size <- data %>%
filter(year == selected_vals$year,
month == selected_vals$month,
type == selected_vals$type) %>%
select(size) %>%
unique() %>%
arrange()
#Check if the value is in memory, if not return NULL (it defaults to the first element)
if(selected_vals$size %in% size$size){
displayVal = selected_vals$size
} else{
displayVal = NULL
selected_vals$size = size$size[1]
}
updateSelectInput(session,"size",choices = size$size,selected = displayVal)
})
}
shinyApp(ui = ui, server = server)