我正在尝试在源数据表和模块中包含的数据表之间移动行。我在过滤 renderDataTable 环境之外的原始表时遇到问题，以便将正确的行传递到模块。现在应用程序正在运行，但使用 _rows_selected 引用了错误的表。
我的计划是使用 .original_order 列作为唯一键。我可以在 UI 中打印此值，但无法在服务器函数中（在 renderDataTable 之外）访问此值。我尝试插入这个：
filtered_df <- reactive({
filtered_data <- my_data() %>% filter(cyl >= input$cyl_slide)
filtered_data
})
然后在renderDataTable函数中引用filtered_df()而不是my_data()，但出现找不到对象“cyl”的错误。我知道该应用程序并不完美，因为这是我第一次尝试使用模块，并且我改编了here找到的代码，但下面的应用程序确实运行，我只需要调整它即可移动正确的行，即使在过滤时也是如此。
library(shiny)
library(DT)
library("shinydashboard")
receiver_ui <- function(id, class) {
ns <- NS(id)
fluidRow(
column(width = 1,
actionButton(ns("add"),
label = NULL,
icon("angle-right")),
actionButton(ns("remove"),
label = NULL,
icon("angle-left")),
actionButton(ns("remove_all"),
label = NULL,
icon("angle-double-left"))),
column(width = 11,
dataTableOutput(ns("sink_table"))),
class = class
)
}
receiver_server <- function(input, output, session, selected_rows, full_page, blueprint) {
data_exch <- reactiveValues(send = blueprint,
receive = blueprint)
trigger_delete <- reactiveValues(trigger = NULL, all = FALSE)
order
output$sink_table <- renderDataTable({
dat <- data_exch$receive
dat$.original_order <- NULL
dat
})
shift_rows <- function(selector) {
data_exch$send <- data_exch$receive[selector, , drop = FALSE]
data_exch$receive <- data_exch$receive[-selector, , drop = FALSE]
}
add_rows <- function(all) {
rel_rows <- if(all) req(full_page()) else req(selected_rows())
data_exch$receive <- rbind(data_exch$receive, rel_rows)
data_exch$receive <- data_exch$receive[order(data_exch$receive$.original_order), ]
## trigger delete, such that the rows are deleted from the source
old_value <- trigger_delete$trigger
trigger_delete$trigger <- ifelse(is.null(old_value), 0, old_value) + 1
trigger_delete$all <- all
}
observeEvent(input$add, {
add_rows(FALSE)
})
observeEvent(input$add_all, {
add_rows(TRUE)
})
observeEvent(input$remove, {
shift_rows(req(input$sink_table_rows_selected))
})
observeEvent(input$remove_all, {
shift_rows(req(input$sink_table_rows_current))
})
## this is the original code, attempts to pass a reactive were unsuccessful
list(send = reactive(data_exch$send),
delete = trigger_delete)
}
ui <- fluidPage(
tags$head(tags$style(HTML(".odd {background: #DDEBF7;}",
".even {background: #BDD7EE;}",
".btn-default {min-width:38.25px;}",
".row {padding-top: 15px;}"))),
fluidRow(
actionButton("add", "Add Table")
),
fluidRow(
sliderInput("cyl_slide", '', min = 4, max = 8, value = 4)
),
fluidRow(
column(width = 6, dataTableOutput("source_table")),
column(width = 6, div(id = "container")),
),
fluidRow(
box(width = 12,title="Selected ID:",textOutput('id_selected'))
)
)
orig_data <- mtcars
orig_data$.original_order <- seq(1, NROW(orig_data), 1)
my_data <- reactiveVal(orig_data)
server <- function(input, output, session) {
#orig_data <- orig_data[orig_data$cyl >= input$cyl_slide,]
cyl_re <- reactive({input$cyl_slide}) #try this?
#{orig_data[orig_data$cyl >= cyl_re(),]} why does it need to be reactiveVal and not reactive?
# filtered_df <- reactive({
# filtered_data <- my_data() %>% filter(cyl >= input$cyl_slide)
#
# filtered_data
# })
handlers <- reactiveVal(list())
selected_rows <- reactive({
my_data()[req(input$source_table_rows_selected), , drop = FALSE]
})
all_rows <- reactive({
my_data()[req(input$source_table_rows_current), , drop = FALSE]
})
observeEvent(input$add, {
old_handles <- handlers()
n <- length(old_handles) + 1
uid <- paste0("row", n)
insertUI("#container", ui = receiver_ui(uid, ifelse(n %% 2, "odd", "even")))
new_handle <- callModule( #I know this is outdated but attempts to reconfigure to moduleServer were unsuccessful because I didn't know where to put the extra arguments (uid, selected_rows,...etc)
receiver_server,
uid,
selected_rows = selected_rows,
full_page = all_rows,
## select 0 rows data.frame to get the structure
blueprint = orig_data[0, ])
observeEvent(new_handle$delete$trigger, {
if (new_handle$delete$all) {
selection <- req(input$source_table_rows_current)
} else {
selection <- req(input$source_table_rows_selected)
}
my_data(my_data()[-selection, , drop = FALSE])
})
observe({
req(NROW(new_handle$send()) > 0)
dat <- rbind(isolate(my_data()), new_handle$send())
my_data(dat[order(dat$.original_order), ])
})
handlers(c(old_handles, setNames(list(new_handle), uid)))
})
output$source_table <- renderDataTable({
dat <- my_data()
dat <- dat[dat$cyl >= input$cyl_slide,]
#dat$.original_order <- NULL
output$id_selected = renderText({
s = input$source_table_rows_selected
if (length(s)>0 & dat$.original_order[s]!="") {
dat$.original_order[s]
}
})
dat
})
}
shinyApp(ui, server)
让我们一步一步来吧，因为我迷路了。这是第一步。现在，你想做什么？
library(shiny)
library(DT)
DATA <- mtcars[, 1:4]
receiver_ui <- function(id) {
ns <- NS(id)
fluidRow(
column(width = 1,
actionButton(ns("add"),
label = NULL,
icon("angle-right"))
),
column(width = 11,
DTOutput(ns("sink_table")))
)
}
receiver_server <- function(id, selectedRows) {
moduleServer(
id,
function(input, output, session) {
Dat <- reactiveVal()
CurrentData <- reactiveVal(DATA)
output$sink_table <- renderDT({
datatable(Dat())
})
missingRows <- reactiveVal(1:nrow(DATA))
observeEvent(input$add, {
missing_rows <- setdiff(1:nrow(CurrentData()), selectedRows())
Dat(rbind(Dat(), CurrentData()[selectedRows(), , drop = FALSE]))
CurrentData(CurrentData()[missing_rows, , drop = FALSE])
missingRows(missing_rows)
})
return(missingRows)
}
)
}
ui <- fluidPage(
fluidRow(
sliderInput("cyl_slide", '', min = 4, max = 8, value = 4)
),
fluidRow(
column(width = 6, DTOutput("source_table")),
column(width = 6, receiver_ui("x"))
)
)
server <- function(input, output, session) {
my_data <- reactiveVal(DATA)
output$source_table <- renderDT({
datatable(my_data())
})
selectedRows <- eventReactive(input$source_table_rows_selected, {
input$source_table_rows_selected
})
# observeEvent(input$source_table_rows_selected, {
missingRows <- receiver_server("x", selectedRows)
# })
observeEvent(missingRows(), {
my_data(my_data()[missingRows(), , drop = FALSE])
})
}
shinyApp(ui, server)