更新
ここでShreeから受け入れられた回答と同様に、とを使用shiny
してアプリを作成しようとしています。私は、あなたに、それに以下の追加を加えたいと思います:DT
DT
て、左側(ソース)のアイテムを左右の複数のテーブルに移動して拡張できるようにし、右側に配置するテーブルの数を決定できるようにします。つまり、左側のテーブルとは異なるアイテムを右側の別のテーブルに入れることができます。誰かがこれらを手伝うことができますか?
すでに述べたように、光沢のあるモジュールはこの問題を解決するためのエレガントな方法です。reactives
行を受信するためにいくつかを渡す必要があり、reactives
行を送信するためにいくつかを返す必要があります/送信したばかりの行を削除する必要があることをメインテーブルに伝えます。
完全に機能する例は次のようになります。
library(shiny)
library(DT)
receiver_ui <- function(id, class) {
ns <- NS(id)
fluidRow(
column(width = 1,
actionButton(ns("add"),
label = NULL,
icon("angle-right")),
actionButton(ns("add_all"),
label = NULL,
icon("angle-double-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 contains 2 data.frames:
## send: the data.frame which should be sent back to the source
## receive: the data which should be added to this display
data_exch <- reactiveValues(send = blueprint,
receive = blueprint)
## trigger_delete is used to signal the source to delete the rows whihc just were sent
trigger_delete <- reactiveValues(trigger = NULL, all = FALSE)
## render the table and remove .original_order, which is used to keep always the same order
output$sink_table <- renderDataTable({
dat <- data_exch$receive
dat$.original_order <- NULL
dat
})
## helper function to move selected rows from this display back
## to the source via data_exch
shift_rows <- function(selector) {
data_exch$send <- data_exch$receive[selector, , drop = FALSE]
data_exch$receive <- data_exch$receive[-selector, , drop = FALSE]
}
## helper function to add the relevant rows
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))
})
## return the send reactive to signal the main app which rows to add back
## and the delete trigger to remove rows
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(
column(width = 6, dataTableOutput("source_table")),
column(width = 6, div(id = "container")),
)
)
server <- function(input, output, session) {
orig_data <- mtcars
orig_data$.original_order <- seq(1, NROW(orig_data), 1)
my_data <- reactiveVal(orig_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(
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$.original_order <- NULL
dat
})
}
shinyApp(ui, server)
説明
モジュールにはUIとサーバーが含まれており、名前空間の手法のおかげで、名前は1つのモジュール内で一意である必要があります(各モジュールは後で一意の名前も持つ必要があります)。モジュールはメインアプリと通信できます。メインアプリreactives
は、渡されるかcallModule
(光沢のあるライブラリをまだ更新していないため、古い関数を使用していることに注意してください)、サーバー関数から返されます。
メインアプリには、UIを動的に挿入しcallModule
、ロジックをアクティブ化するための呼び出しを行うボタンがあります。observers
サーバーロジックを機能させるために、同じ呼び出しで生成されます。
この記事はインターネットから収集されたものであり、転載の際にはソースを示してください。
侵害の場合は、連絡してください[email protected]
コメントを追加