Here is a solution that recreates the filtering on the original data based on the filter inputs stored in my_state$datatable_search_columns. The strings are turned into the correct filter conditions which are then applied to the data set before saving. Note that I haven’t tested it with a condition in the global search bar:
library(shiny)
library(shinyWidgets)
library(dplyr)
library(tidyverse)
library(shinyjs)
ui <- fluidPage(
titlePanel("Dataset Tool"),
sidebarLayout(
sidebarPanel(width = 3,
conditionalPanel(
condition = "input.tabs=='Datasets'",
uiOutput("ui_datasets"),
uiOutput("ui_storedataset"),
br(), br(),
wellPanel(
checkboxInput("data_remove", "Remove dataset from memory",
FALSE),
conditionalPanel(
condition = "input.data_remove == true",
uiOutput("ui_removedataset"),
actionButton("removeDataSetButton",
"Remove dataset")
)
)
)
),
mainPanel(
tabsetPanel(id = "tabs",
tabPanel("Datasets",
DT::dataTableOutput("datatable")
)
)
)
)
)
server = function(input, output,session) {
my_data <- new.env()
my_state <- list()
my_info <- reactiveValues()
datasetlist <- c()
my_df <- list()
df <- list()
df_names <- c("diamonds", "mtcars")
for (j in df_names) {
df[[j]] <- get(j)
datasetlist <- c(datasetlist, j)
}
my_info[["datasetlist"]] <- datasetlist
my_df[["df"]] <- df
output$ui_datasets <- renderUI({
tagList(
selectInput(
inputId = "dataset",
label = "Datasets:",
choices = my_info[["datasetlist"]],
multiple = FALSE
)
)
})
output$ui_storedataset <- renderUI({
tagList(
wellPanel(
tags$table(
tags$td(textInput("stored_name",
"Store new dataset as:",
"",
placeholder = "name of the dataset")),
tags$td(actionButton("view_store",
"Store"),
style = "padding-right:30px;")
)
)
)
})
observeEvent(input$datatable_search_columns, {
my_state$datatable_search_columns <<- input$datatable_search_columns
})
observeEvent(input$datatable_state, {
my_state$datatable_state <<-
if (is.null(input$datatable_state)) list() else input$datatable_state
})
output$datatable <- DT::renderDataTable({
dat <- df[[(input$dataset)]]
search <- my_state$datatable_state$search$search
if (is.null(search)) search <- ""
fbox <- if (nrow(dat) > 5e6) "none" else list(position = "top")
DT::datatable(
dat,
filter = fbox,
selection = "none",
rownames = FALSE,
fillContainer = FALSE,
escape = FALSE,
style = "bootstrap",
options = list(
stateSave = TRUE,
searchCols = lapply(my_state$datatable_search_columns, function(x) list(search = x)),
search = list(search = search, regex = TRUE),
order = {
if (is.null(my_state$datatable_state$order)) {
list()
} else {
my_state$datatable_state$order
}
},
columnDefs = list(
list(orderSequence = c("desc", "asc"), targets = "_all"),
list(className = "dt-center", targets = "_all")
),
autoWidth = TRUE,
processing = isTRUE(fbox == "none"),
pageLength = {
if (is.null(my_state$datatable_state$length)) 10 else my_state$datatable_state$length
},
lengthMenu = list(c(5, 10, 25, 50, -1), c("5", "10", "25", "50", "All"))
),
callback = DT::JS('$(window).on("unload", function() { table.state.clear(); })')
)
})
observeEvent(input$view_store, {
req(input$stored_name)
dataset <- (input$stored_name)
if (input$stored_name != dataset) {
updateTextInput(session, inputId = "stored_name", value = dataset)
}
# get filter conditions
filter_conditions <- lapply(my_state$datatable_search_columns, function(column) {
# check if it is a numerical filter and extract the values
if (str_detect(column, "\\.\\.\\.")) {
vals <- strsplit(column, " ")
c(as.numeric(vals[[1]][1]), as.numeric(vals[[1]][3])) # min/max values
} else {
if (column == "") {
NA
} else {
vals <- strsplit(column, "\"")
index <- seq(from = 2, to = length(vals[[1]]), by = 2)
as.character(vals[[1]][index])
}
}
})
# do the filtering
temp <- get(input$dataset)
temp <- as.data.frame(temp)
for (i in seq_along(filter_conditions)) {
current_vals <- filter_conditions[[i]]
if (all(is.numeric(current_vals))) {
# it's a numeric column
temp <- temp[temp[, i] >= current_vals[1] & temp[, i] <= current_vals[2], ]
}
if (all(is.character(current_vals))) {
# it's a character column
temp[, i] <- as.character(temp[, i])
temp <- temp[temp[, i] %in% current_vals, ]
}
}
my_data[[dataset]] <- temp
updateSelectInput(session = session, inputId = "dataset",
selected = input$dataset)
})
output$ui_removedataset <- renderUI({
selectInput(
inputId = "removeDataset",
label = NULL,
choices = my_info[["datasetlist"]],
selected = NULL,
multiple = TRUE,
size = length(my_info[["datasetlist"]]),
selectize = FALSE
)
})
observeEvent(input$removeDataSetButton, {
if (is.null(input$removeDataset)) return()
datasets <- my_info[["datasetlist"]]
if (length(datasets) > 1) {
removeDataset <- input$removeDataset
if (length(datasets) == length(removeDataset)) {
removeDataset <- removeDataset[-1]
}
suppressWarnings(rm(list = removeDataset, envir = my_data))
my_info[["datasetlist"]] <- datasets[-which(datasets %in% removeDataset)]
}
})
}
shinyApp(ui = ui, server = server)
Edit
Here is a version where you can select the changed dataset after storing it:
library(shiny)
library(shinyWidgets)
library(dplyr)
library(tidyverse)
library(shinyjs)
ui <- fluidPage(
titlePanel("Dataset Tool"),
sidebarLayout(
sidebarPanel(width = 3,
conditionalPanel(
condition = "input.tabs=='Datasets'",
uiOutput("ui_datasets"),
uiOutput("ui_storedataset"),
br(), br(),
wellPanel(
checkboxInput("data_remove", "Remove dataset from memory",
FALSE),
conditionalPanel(
condition = "input.data_remove == true",
uiOutput("ui_removedataset"),
actionButton("removeDataSetButton",
"Remove dataset")
)
)
)
),
mainPanel(
tabsetPanel(id = "tabs",
tabPanel("Datasets",
DT::dataTableOutput("datatable")
)
)
)
)
)
server = function(input, output,session) {
my_data <- new.env()
my_state <- list()
my_info <- reactiveValues()
datasetlist <- c()
my_df <- list()
df <- list()
df_names <- c("diamonds", "mtcars")
for (j in df_names) {
df[[j]] <- get(j)
datasetlist <- c(datasetlist, j)
}
my_info[["datasetlist"]] <- datasetlist
my_df[["df"]] <- df
output$ui_datasets <- renderUI({
tagList(
selectInput(
inputId = "dataset",
label = "Datasets:",
choices = my_info[["datasetlist"]],
multiple = FALSE
)
)
})
output$ui_storedataset <- renderUI({
tagList(
wellPanel(
tags$table(
tags$td(textInput("stored_name",
"Store new dataset as:",
"",
placeholder = "name of the dataset")),
tags$td(actionButton("view_store",
"Store"),
style = "padding-right:30px;")
)
)
)
})
observeEvent(input$datatable_search_columns, {
my_state$datatable_search_columns <<- input$datatable_search_columns
})
observeEvent(input$datatable_state, {
my_state$datatable_state <<-
if (is.null(input$datatable_state)) list() else input$datatable_state
})
output$datatable <- DT::renderDataTable({
dat <- df[[(input$dataset)]]
search <- my_state$datatable_state$search$search
if (is.null(search)) search <- ""
fbox <- if (nrow(dat) > 5e6) "none" else list(position = "top")
DT::datatable(
dat,
filter = fbox,
selection = "none",
rownames = FALSE,
fillContainer = FALSE,
escape = FALSE,
style = "bootstrap",
options = list(
stateSave = TRUE,
searchCols = lapply(my_state$datatable_search_columns, function(x) list(search = x)),
search = list(search = search, regex = TRUE),
order = {
if (is.null(my_state$datatable_state$order)) {
list()
} else {
my_state$datatable_state$order
}
},
columnDefs = list(
list(orderSequence = c("desc", "asc"), targets = "_all"),
list(className = "dt-center", targets = "_all")
),
autoWidth = TRUE,
processing = isTRUE(fbox == "none"),
pageLength = {
if (is.null(my_state$datatable_state$length)) 10 else my_state$datatable_state$length
},
lengthMenu = list(c(5, 10, 25, 50, -1), c("5", "10", "25", "50", "All"))
),
callback = DT::JS('$(window).on("unload", function() { table.state.clear(); })')
)
})
observeEvent(input$view_store, {
req(input$stored_name)
dataset <- (input$stored_name)
if (input$stored_name != dataset) {
updateTextInput(session, inputId = "stored_name", value = dataset)
}
# get filter conditions
filter_conditions <- lapply(my_state$datatable_search_columns, function(column) {
# check if it is a numerical filter and extract the values
if (str_detect(column, "\\.\\.\\.")) {
vals <- strsplit(column, " ")
c(as.numeric(vals[[1]][1]), as.numeric(vals[[1]][3])) # min/max values
} else {
if (column == "") {
NA
} else {
vals <- strsplit(column, "\"")
index <- seq(from = 2, to = length(vals[[1]]), by = 2)
as.character(vals[[1]][index])
}
}
})
# do the filtering
temp <- get(input$dataset)
temp <- as.data.frame(temp)
for (i in seq_along(filter_conditions)) {
current_vals <- filter_conditions[[i]]
if (all(is.numeric(current_vals))) {
# it's a numeric column
temp <- temp[temp[, i] >= current_vals[1] & temp[, i] <= current_vals[2], ]
}
if (all(is.character(current_vals))) {
# it's a character column
temp[, i] <- as.character(temp[, i])
temp <- temp[temp[, i] %in% current_vals, ]
}
}
df[[dataset]] <<- temp
my_info[["datasetlist"]] <- c(my_info[["datasetlist"]], input$stored_name)
updateSelectInput(session = session, inputId = "dataset",
selected = input$dataset)
})
output$ui_removedataset <- renderUI({
selectInput(
inputId = "removeDataset",
label = NULL,
choices = my_info[["datasetlist"]],
selected = NULL,
multiple = TRUE,
size = length(my_info[["datasetlist"]]),
selectize = FALSE
)
})
observeEvent(input$removeDataSetButton, {
if (is.null(input$removeDataset)) return()
datasets <- my_info[["datasetlist"]]
if (length(datasets) > 1) {
removeDataset <- input$removeDataset
if (length(datasets) == length(removeDataset)) {
removeDataset <- removeDataset[-1]
}
suppressWarnings(rm(list = removeDataset, envir = my_data))
my_info[["datasetlist"]] <- datasets[-which(datasets %in% removeDataset)]
}
})
}
shinyApp(ui = ui, server = server)
A few issues with your code I’ve noticed:
- I recommend not to use
get, this makes it less clear and debuggable where the data comes from; I’d work directly with the lists/reactives where your data is stored to retrieve it - there is something going on with the filters set in the table; they stay even when you switch datasets, I think you have to put some work into that
- you have a lot of similar lists (like
my_dfanddf) (and I think you don’t use both), which makes your code harder to understand - try to use more
observeEvent/updateXXInputas it’s a bit faster than doing all therenderUIon the server side
CLICK HERE to find out more related problems solutions.