我正在尝试使用 Shiny App 动态编辑 data.frame。该表描述了一个项目的实验结构，因此将包括可变的实验因素，每个因素都有不同的水平。对于多级因素，我想允许从下拉菜单中选择值。 出于实际原因，我希望用户也能够在 Excel/任何其他表格编辑器中编辑表格，因此也将其保存为 csv。 所以应用程序应该：
require(shiny)
require(DT)
# Prepare mock data
wd <- getwd()
Factors <- c("Experiment", "Condition", "Replicate", "Genotype")
ExpMapNm <- "Experiment map"
ExpMapPath <- paste0(wd, "/", ExpMapNm, ".csv")
ExpMap <- data.frame(Experiment = "Exp1",
Sample = paste0("Sample", 1:20),
Condition = as.character(sapply(c("Treated", "Mock"), function(x) { rep(x, 10) })),
Genotype = as.character(sapply(c("KO", "WT"), function(x) { rep(x, 5) })),
Replicate = 1:5)
FactorsList <- setNames(lapply(Factors, function(x) { unique(ExpMap[[x]]) }), Factors)
#
# Users should be able to edit this table in two ways:
# - in Excel manually, hence why a local version is saved below and in server when closing the app
# - within the Shiny app
# In either case, the edited table will then be reloaded into r as a data.frame which will guide further data processing
if (!file.exists(ExpMapPath)) { write.csv(ExpMap, ExpMapPath, row.names = FALSE) }
ui <- shiny::fluidPage(shiny::titlePanel(ExpMapNm), # This is the name of the table
shiny::mainPanel(shiny::br(),
shiny::actionButton("saveBtn", "Save"),
DT::dataTableOutput("Data"),
verbatimTextOutput(Factors)
))
server <- function(input, output) {
Data <- read.csv(ExpMapPath)
for (Fact in Factors) {
if (length(FactorsList[[Fact]]) > 1) { # We only want to have a drop-down selection if a factor has more than one level.
# Thus, in this example we do not create a drop-down selection for factor Experiment.
lvls <- FactorsList[[Fact]] # Allowed values
for (i in 1:nrow(Data)) {
val <- Data[[Fact]][i]
dflt <- c(lvls[1], val)[(val %in% lvls)+1] # If the current value is not a valid level, revert to default (1st) level
# Otherwise keep current value, but still apply drop-down selection so choices can be changed
Data[[Fact]][i] <- as.character(selectInput(paste0(Fact, "_", i), NULL, lvls, dflt, width = "100px"))
}
} else { Data[[Fact]] <- FactorsList[[Fact]] }
}
output$Data <- DT::renderDataTable(
Data, escape = FALSE, selection = "none", server = FALSE,
editable = TRUE, # Non-drop-down fields can still be edited: this works
options = list(paging = TRUE, searching = TRUE, fixedColumns = TRUE, autoWidth = TRUE,
ordering = TRUE, dom = "Bfrtip"),
callback = JS("table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-container');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());"),
class = "display")
shiny::observeEvent(input$Data_cell_edit, {
Data[input$Data_cell_edit$row, input$Data_cell_edit$col] <<- input$Data_cell_edit$value
})
shiny::observeEvent(input$saveBtn, {
# Hacky HTML cleanup
# I am not interested in getting cells with html formatting in my table, I just want the value!
# Moreover, this would clash with the code above when initiliazing the table and comparing values.
#print(Data$Condition[[1]])
for (Fact in Factors) {
if (length(FactorsList[[Fact]]) > 1) {
for (i in 1:nrow(Data)) {
val <- Data[[Fact]][i]
val <- gsub("^option value=\"[^\"]+\" selected>", "",
grep("^option value=\"[^\"]+\" selected>", unlist(strsplit(a, " *<|>[\n ]*<|> *$")), value = TRUE))
Data[[Fact]][i] <- val
}
}
}
# Check if I have managed to change from the default value:
print(Data$Condition[[1]])
# When testing, I change from "Treated" to "Mock" in the table, hit save, but it prints "Treated", and sure enough the table saved contains "Treated".
#
write.csv(Data, ExpMapPath, row.names = FALSE)
tstExpMap <<- Data # Another way to check table values
stopApp()
})
}
print(shiny::shinyApp(ui, server, options = list(launch.browser = TRUE)))
> sessionInfo()
R version 4.2.3 (2023-03-15 ucrt)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows Server x64 (build 20348)
Matrix products: default
locale:
[1] LC_COLLATE=English_United Kingdom.utf8 LC_CTYPE=English_United Kingdom.utf8 LC_MONETARY=English_United Kingdom.utf8
[4] LC_NUMERIC=C LC_TIME=English_United Kingdom.utf8
attached base packages:
[1] stats graphics grDevices utils datasets methods base
other attached packages:
[1] DT_0.26 shiny_1.7.4
loaded via a namespace (and not attached):
[1] Rcpp_1.0.9 rstudioapi_0.14 magrittr_2.0.3 xtable_1.8-4 R6_2.5.1 rlang_1.0.6 fastmap_1.1.0 tools_4.2.3
[9] aRmel_4.0.0.13 cli_3.5.0 jquerylib_0.1.4 htmltools_0.5.4 crosstalk_1.2.0 ellipsis_0.3.2 yaml_2.3.6 digest_0.6.31
[17] lifecycle_1.0.3 crayon_1.5.2 later_1.3.0 sass_0.4.4 htmlwidgets_1.6.0 promises_1.2.0.1 memoise_2.0.1 cachem_1.0.6
[25] mime_0.12 compiler_4.2.3 bslib_0.4.2 jsonlite_1.8.4 httpuv_1.6.7
我在 StackOverflow 上看过很多类似的帖子，例如 https://github.com/ejbeaty/CellEdit/tree/master/js，DT: Dynamically change column values based on selectinput from another column in R shiny app 和 使用下拉选择（对于 DT v0.19）编辑闪亮的数据表，我实际上基于这个应用程序，但我一定遗漏了一些东西，因为它对我不起作用。不幸的是，我对 JavaScript 一无所知，所以我很难弄清楚缺少什么。
以下是我的答案here的修改（通用）版本，它读取csv文件并允许将其保存回磁盘。
library(DT)
library(shiny)
# Prepare mock data
wd <- getwd()
Factors <- c("Experiment", "Condition", "Replicate", "Genotype")
ExpMapNm <- "dummy_data"
ExpMapPath <- paste0(wd, "/", ExpMapNm, ".csv")
ExpMap <- data.frame(Experiment = "Exp1",
Sample = paste0("Sample", 1:20),
Condition = as.character(sapply(c("Treated", "Mock"), function(x) { rep(x, 10) })),
Genotype = as.character(sapply(c("KO", "WT"), function(x) { rep(x, 5) })),
Replicate = 1:5)
FactorsList <- setNames(lapply(Factors, function(x) { unique(ExpMap[[x]]) }), Factors)
if (!file.exists(ExpMapPath)) { write.csv(ExpMap, ExpMapPath, row.names = FALSE) }
ui <- fluidPage(
shiny::actionButton("saveBtn", "Save"),
DT::dataTableOutput(outputId = 'my_table'),
)
server <- function(input, output, session) {
resultDF <- displayHTMLDF <- initHTMLDF <- initData <- read.csv(ExpMapPath)
dropdownCols <- names(initData)[3:5]
dropdownIDs <- setNames(lapply(dropdownCols, function(x){paste0(x, seq_len(nrow(initData)))}), dropdownCols)
for(dropdownCol in dropdownCols){
colDropdownIDs <- dropdownIDs[[dropdownCol]]
initHTMLDF[[dropdownCol]] <- sapply(seq_along(colDropdownIDs), function(i){as.character(selectInput(inputId = colDropdownIDs[i], label = "", choices = unique(initData[[dropdownCol]]), selected = initData[[dropdownCol]][i]))})
}
reactiveHTMLDF <- reactive({
for(dropdownCol in dropdownCols){
colDropdownIDs <- dropdownIDs[[dropdownCol]]
displayHTMLDF[[dropdownCol]] <- sapply(seq_along(colDropdownIDs), function(i){as.character(selectInput(inputId = colDropdownIDs[i], label = "", choices = unique(initData[[dropdownCol]]), selected = input[[colDropdownIDs[i]]]))})
}
return(displayHTMLDF)
})
reactiveResultDF <- reactive({
for(dropdownCol in dropdownCols){
colDropdownIDs <- dropdownIDs[[dropdownCol]]
resultDF[[dropdownCol]] <- sapply(seq_along(colDropdownIDs), function(i){input[[colDropdownIDs[i]]]})
}
return(resultDF)
})
output$my_table = DT::renderDataTable({
DT::datatable(
initHTMLDF, escape = FALSE, selection = 'none', rownames = FALSE,
options = list(paging = FALSE, ordering = FALSE, scrollx = TRUE, dom = "t",
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
)
)
}, server = TRUE)
my_table_proxy <- dataTableProxy(outputId = "my_table", session = session)
observeEvent({sapply(unlist(dropdownIDs), function(x){input[[x]]})}, {
replaceData(proxy = my_table_proxy, data = reactiveHTMLDF(), rownames = FALSE) # must repeat rownames = FALSE see ?replaceData and ?dataTableAjax
}, ignoreInit = TRUE)
shiny::observeEvent(input$saveBtn, {
write.csv(reactiveResultDF(), ExpMapPath, row.names = FALSE)
stopApp()
})
}
shinyApp(ui = ui, server = server)
您可能需要根据自己的需要调整一些东西，但是不需要它们来说明原理。