小贝子编程

r-从数据表中捕获过滤后的结果，并将其作为新数据集存储在Shiny中



我有一个闪亮的应用程序，它加载了几个数据集(diamonds&mtcar(，并将它们作为数据表显示在主面板中。我正在尝试实现的几个功能

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)

编辑

这里有一个版本，您可以在存储后选择更改后的数据集：

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，这会降低数据来源的清晰度和可调试性；我会直接使用存储数据的列表/反应器来检索数据
  • 表中设置的过滤器有问题；即使当你切换数据集时，它们仍然存在，我认为你必须为此付出一些努力
  • 您有很多类似的列表(如my_df和df((我认为您没有同时使用这两个列表(，这使得您的代码更难理解
  • 尝试使用更多的observeEvent/updateXXInput，因为它比在服务器端使用所有renderUI快一点

相关内容

最新更新


热门标签：

javascript python java c# php android html jquery c++ css ios sql mysql arrays asp.net json python-3.x ruby-on-rails .net sql-server django objective-c excel regex ruby linux ajax iphone xml vba spring asp.net-mvc database wordpress string postgresql wpf windows xcode bash git oracle list vb.net multithreading eclipse algorithm macos powershell visual-studio image forms numpy scala function api selenium