R Shiny 从已检查的数据表中挑选和存​​储收藏夹

Question

背景

我正在尝试创建一个多表 Shiny 应用程序，您可以在其中通过复选框在多个表中选择您最喜欢的行。然后这些应该跨 session 存储，并呈现在一个额外的“收藏夹”表中。不幸的是，我对 JavaScript 的理解似乎太有限，无法做到这一点。

目标

通过检查行选择收藏夹

要存储的值应从复选框 value 中读取。字段

多个表应该彼此独立工作

选择的收藏夹应通过写入 .Rds 文件或类似文件在 session 之间存储

到目前为止我所做的

对于单个表，基本设置如下所述: RStudio Shiny list from checking rows in dataTables

在将其扩展到多个表时，这些表分隔在不同的选项卡中，这些表似乎并不独立。示例:如果我从表 1 中选择第 1 行，然后从表 2 中选择第 2 行 - 表 2 的渲染将显示第 1 行和第 2 行都被选中。如果我现在按下“保存 2”按钮，它将保存三个记录:第 1 行(table1)和第 1+2 行(table2)。

在表 3 中，我设法返回了复选框的值(实际表中不再需要打印 ID 列)，但现在我只能选择一行。

编辑:
回调现在正在工作，收集复选框的值并彼此独立工作。尽管如此，储蓄并没有像预期的那样奏效。这可能是一个 Shiny / react 性问题？

应用程序.R

mymtcars1 = mtcars
mymtcars2 = mtcars
mymtcars3 = mtcars
mymtcars1$id = 1:nrow(mtcars)
mymtcars2$id = 1:nrow(mtcars)
mymtcars3$id = 1:nrow(mtcars)

server <- function(input, output, session) {
    rowSelect1 <- reactive({
      paste(sort(unique(input[["rows1"]])),sep=',')
    })
    rowSelect2 <- reactive({
      paste(sort(unique(input[["rows2"]])),sep=',')
    })
    rowSelect3 <- reactive({
      paste(sort(unique(input[["rows3"]])),sep=',')
    })
    observe({
      output$favorites_table1 <- renderText(rowSelect1())
      output$favorites_table2 <- renderText(rowSelect2())
      output$favorites_table3 <- renderText(rowSelect3())
    })
    output$mytable1 = renderDataTable({
      mymtcars <- mymtcars1
      addCheckboxButtons <- paste0('<input id="table1" type="checkbox" name="row', mymtcars$id, '" value="op', mymtcars$id, '">',"")
      #Display table with checkbox buttons
      cbind(Pick=addCheckboxButtons, mymtcars)
    }, options = list(orderClasses = TRUE, lengthMenu = c(5, 25, 50), pageLength = 25),
    escape = FALSE,
    callback = "function(table) {
    table.on('change.dt', '#table1:checkbox', function() {
    setTimeout(function () {
    Shiny.onInputChange('rows1', $('#table1:checked').map(function() {
    return $(this).val();
    }).get())
    }, 10); 
    });
  }")

  output$mytable2 = renderDataTable({
    mymtcars <- mymtcars2
    addCheckboxButtons <- paste0('<input id="table2" type="checkbox" name="row', mymtcars$id, '" value="val', mymtcars$id, '">',"")
    #Display table with checkbox buttons
    cbind(Pick=addCheckboxButtons, mymtcars)
    }, options = list(orderClasses = TRUE, lengthMenu = c(5, 25, 50), pageLength = 25),
    escape = FALSE,
    callback = "function(table) {
    table.on('change.dt', '#table2:checkbox', function() {
    setTimeout(function () {
    Shiny.onInputChange('rows2', $('#table2:checked').map(function() {
    return $(this).val();
    }).get())
    }, 10); 
    });
    }")
  output$mytable3 = renderDataTable({
    mymtcars <- mymtcars3
    addCheckboxButtons <- paste0('<input id="table3" type="checkbox" name="row', mymtcars$id, '" value="', mymtcars$id, '">',"")
    #Display table with checkbox buttons
    cbind(Pick=addCheckboxButtons, mymtcars[,-ncol(mymtcars)])
    }, options = list(orderClasses = TRUE, lengthMenu = c(5, 25, 50), pageLength = 25),
    escape = FALSE,
    callback = "function(table) {
    table.on('change.dt', '#table3:checkbox', function() {
    setTimeout(function () {
    Shiny.onInputChange('rows3', $('#table3:checked').map(function() {
    return $(this).val();
    }).get())
    }, 10); 
    });
    }")
  favorites <- reactive({
    input$send_table1
    input$send_table2
    input$send_table3
    if(file.exists("favorites.Rds")) {
      old_favorites <- readRDS("favorites.Rds")
    } else {
      old_favorites <- data.frame()
    }
    isolate({
      new_favorites <- data.frame("Table"=character(0), "Key"=character(0))
      if(length(input$rows1>0)) new_favorites <- rbind(new_favorites, data.frame("Table"="Table1","Key"=input$rows1))
      if(length(input$rows2>0)) new_favorites <- rbind(new_favorites, data.frame("Table"="Table2","Key"=input$rows2))
      if(length(input$rows3>0)) new_favorites <- rbind(new_favorites, data.frame("Table"="Table3","Key"=input$rows3))
      if(nrow(new_favorites)>0){
        saveRDS(new_favorites, "favorites.Rds")
        new_favorites
      } else {
        old_favorites
      }
    })
  })
  output$favorites_table <- renderDataTable({
    validate(
      need(nrow(favorites())>0, paste0("No favorites stored"))
    )
    favorites()
  })
}

ui <- shinyUI(
  pageWithSidebar(
    headerPanel('Examples of DataTables'),
    sidebarPanel(
      inputPanel(
        h5("Selected (table 1)"),br(),
        verbatimTextOutput("favorites_table1"),
        actionButton(inputId = "send_table1", "Save 1", class="btn-mini")
      ),
      inputPanel(
        h5("Selected (table 2)"),br(),
        verbatimTextOutput("favorites_table2"),
        actionButton(inputId = "send_table2", "Save 2", class="btn-mini")
      ),
      inputPanel(
        h5("Selected (table 3)"),br(),
        verbatimTextOutput("favorites_table3"),
        actionButton(inputId = "send_table3", "Save 3", class="btn-mini")
      )
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Table1",
                 dataTableOutput("mytable1")
        ),
        tabPanel("Table2",
                 dataTableOutput("mytable2")
        ),
        tabPanel("Table3",
                 dataTableOutput("mytable3")
        ),
        tabPanel("Favorites",
                 dataTableOutput("favorites_table")
        )
      )
    )
  )
)

shinyApp(ui = ui, server = server)

Answer 1

好的，所以这是一个有效的解决方案 - 对于其他感兴趣的人。
它将读取复选框的值，并在单击时将其发送到收藏夹表。

应用程序.R

mymtcars1 = mtcars
mymtcars2 = mtcars
mymtcars3 = mtcars
mymtcars1$id = 1:nrow(mtcars)
mymtcars2$id = 1:nrow(mtcars)
mymtcars3$id = 1:nrow(mtcars)

server <- function(input, output, session) {
    rowSelect1 <- reactive({
      if(!is.null(input[["rows1"]])) paste(sort(unique(input[["rows1"]])),sep=',')
    })
    rowSelect2 <- reactive({
      if(!is.null(input[["rows2"]])) paste(sort(unique(input[["rows2"]])),sep=',')
    })
    rowSelect3 <- reactive({
      if(!is.null(input[["rows3"]])) paste(sort(unique(input[["rows3"]])),sep=',')
    })
    output$favorites_table1 <- renderText(rowSelect1())
    output$favorites_table2 <- renderText(rowSelect2())
    output$favorites_table3 <- renderText(rowSelect3())

    output$mytable1 = renderDataTable({
      mymtcars <- mymtcars1
      addCheckboxButtons <- paste0('<input id="table1" type="checkbox" name="row', mymtcars$id, '" value="op', mymtcars$id, '">',"")
      #Display table with checkbox buttons
      cbind(Pick=addCheckboxButtons, mymtcars)
    }, options = list(orderClasses = TRUE, lengthMenu = c(5, 25, 50), pageLength = 25),
    escape = FALSE,
    callback = "function(table) {
    table.on('change.dt', '#table1:checkbox', function() {
    setTimeout(function () {
    Shiny.onInputChange('rows1', $('#table1:checked').map(function() {
    return $(this).val();
    }).get())
    }, 10); 
    });
  }")

  output$mytable2 = renderDataTable({
    mymtcars <- mymtcars2
    addCheckboxButtons <- paste0('<input id="table2" type="checkbox" name="row', mymtcars$id, '" value="val', mymtcars$id, '">',"")
    #Display table with checkbox buttons
    cbind(Pick=addCheckboxButtons, mymtcars)
    }, options = list(orderClasses = TRUE, lengthMenu = c(5, 25, 50), pageLength = 25),
    escape = FALSE,
    callback = "function(table) {
    table.on('change.dt', '#table2:checkbox', function() {
    setTimeout(function () {
    Shiny.onInputChange('rows2', $('#table2:checked').map(function() {
    return $(this).val();
    }).get())
    }, 10); 
    });
    }")
  output$mytable3 = renderDataTable({
    mymtcars <- mymtcars3
    addCheckboxButtons <- paste0('<input id="table3" type="checkbox" name="row', mymtcars$id, '" value="', mymtcars$id, '">',"")
    #Display table with checkbox buttons
    cbind(Pick=addCheckboxButtons, mymtcars[,-ncol(mymtcars)])
    }, options = list(orderClasses = TRUE, lengthMenu = c(5, 25, 50), pageLength = 25),
    escape = FALSE,
    callback = "function(table) {
    table.on('change.dt', '#table3:checkbox', function() {
    setTimeout(function () {
    Shiny.onInputChange('rows3', $('#table3:checked').map(function() {
    return $(this).val();
    }).get())
    }, 10); 
    });
    }")

  store_favorites <- function(rds="favorites.Rds", inputidx, name){
      if(file.exists(rds)) favorites <- readRDS(rds) else favorites <- data.frame("Table"=character(0), "Key"=character(0))
      if(length(input[[inputidx]])>0) {
        new_favorites <- unique(rbind(favorites, data.frame("Table"=name,"Key"=input[[inputidx]])))
        saveRDS(new_favorites, rds)
        new_favorites
      } else {
        favorites
      }
  }

  favorites1 <- reactive({
    input$send_table1
    isolate({store_favorites(inputidx="rows1", name="Table1")})
  })
  favorites2 <- reactive({
    input$send_table2
    isolate({store_favorites(inputidx="rows2", name="Table2")})
  })
  favorites3 <- reactive({
    input$send_table3
    isolate({store_favorites(inputidx="rows3", name="Table3")})
  })

  output$favorites_table <- renderDataTable({
    # Re-evaluate favorites each time one of the buttons are pressed
    input$send_table1
    input$send_table2
    input$send_table3
    isolate({
      #Unneccessary to bind the same table 3 times, then unique - but this works
      all_favs <- unique(rbind(favorites1(),favorites2(),favorites3()))
    })
    validate(
      need(nrow(all_favs)>0, paste0("No favorites stored"))
    )
    all_favs
  })
}

ui <- shinyUI(
  pageWithSidebar(
    headerPanel('Examples of DataTables'),
    sidebarPanel(
      inputPanel(
        h5("Selected (table 1)"),br(),
        verbatimTextOutput("favorites_table1"),
        actionButton(inputId = "send_table1", "Save 1", class="btn-mini")
      ),
      inputPanel(
        h5("Selected (table 2)"),br(),
        verbatimTextOutput("favorites_table2"),
        actionButton(inputId = "send_table2", "Save 2", class="btn-mini")
      ),
      inputPanel(
        h5("Selected (table 3)"),br(),
        verbatimTextOutput("favorites_table3"),
        actionButton(inputId = "send_table3", "Save 3", class="btn-mini")
      )
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Table1",
                 dataTableOutput("mytable1")
        ),
        tabPanel("Table2",
                 dataTableOutput("mytable2")
        ),
        tabPanel("Table3",
                 dataTableOutput("mytable3")
        ),
        tabPanel("Favorites",
                 dataTableOutput("favorites_table")
        )
      )
    )
  )
)

shinyApp(ui = ui, server = server)