从数据表中捕获过滤结果并将其作为新数据集存储在 Shiny 中
Capture filtered results from a datatable and store it as a new dataset in Shiny
我有一个闪亮的应用程序，它加载了几个数据集（钻石和 mtcars）并将它们显示为主面板中的数据表。我正在尝试实现一些功能
1. Store datasets: Once the user create filters in the datatable, allow them to store the filtered results as a new dataset.
2. Remove datasets: Allow the users to remove any datasets from the list of created datasets
app.R
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)
}
my_data[[dataset]] <- get(input$dataset)
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)
我认为“删除数据集”功能运行良好。我无法使用“存储数据集”功能。我不确定如何从环境中捕获过滤后的数据表来存储并将其添加到数据集列表中。
如果能提供任何帮助，我将不胜感激。谢谢
这是一个基于 my_state$datatable_search_columns 中存储的过滤器输入重新创建原始数据过滤的解决方案。这些字符串被转换为正确的过滤条件，然后在保存之前将其应用于数据集。请注意，我还没有在全局搜索栏中使用条件对其进行测试：
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)
编辑
这是一个版本，您可以在其中 select 存储更改后的数据集：
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)
我注意到您的代码存在一些问题：
- 我建议不要使用
get，这使得数据的来源变得不那么清晰和难以调试；我会直接使用存储数据的 lists/reactives 来检索它
- table 中设置的过滤器出现问题；即使您切换数据集，它们也会保留，我认为您必须为此付出一些努力
- 你有很多相似的列表（比如
my_df 和 df）（我认为你不会同时使用两者），这让你的代码更难理解
- 尝试使用更多
observeEvent/updateXXInput，因为它比在服务器端执行所有 renderUI 要快一点
我有一个闪亮的应用程序，它加载了几个数据集（钻石和 mtcars）并将它们显示为主面板中的数据表。我正在尝试实现一些功能
1. Store datasets: Once the user create filters in the datatable, allow them to store the filtered results as a new dataset.
2. Remove datasets: Allow the users to remove any datasets from the list of created datasets
app.R
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)
}
my_data[[dataset]] <- get(input$dataset)
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)
我认为“删除数据集”功能运行良好。我无法使用“存储数据集”功能。我不确定如何从环境中捕获过滤后的数据表来存储并将其添加到数据集列表中。
如果能提供任何帮助，我将不胜感激。谢谢
这是一个基于 my_state$datatable_search_columns 中存储的过滤器输入重新创建原始数据过滤的解决方案。这些字符串被转换为正确的过滤条件，然后在保存之前将其应用于数据集。请注意，我还没有在全局搜索栏中使用条件对其进行测试：
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)
编辑
这是一个版本，您可以在其中 select 存储更改后的数据集：
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)
我注意到您的代码存在一些问题：
- 我建议不要使用
get，这使得数据的来源变得不那么清晰和难以调试；我会直接使用存储数据的 lists/reactives 来检索它 - table 中设置的过滤器出现问题；即使您切换数据集，它们也会保留，我认为您必须为此付出一些努力
- 你有很多相似的列表（比如
my_df和df）（我认为你不会同时使用两者），这让你的代码更难理解 - 尝试使用更多
observeEvent/updateXXInput，因为它比在服务器端执行所有renderUI要快一点