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

Question

背景

我正在尝试创建一个多表Shiny应用程序，您可以通过复选框在多个表中选择您喜欢的行。然后应将这些存储在会话中，并在另外的＆＃34;收藏夹中进行渲染。表。不幸的是，我对JavaScript的理解似乎太有限了。

目标

• 通过检查行
选择收藏夹
• 应从复选框value字段
中读取要存储的值
• 多个表应该彼此独立工作
• 通过写入.Rds文件或类似文件
，应在会话之间存储挑选的收藏夹

到目前为止我做了什么

对于单个表格，基本设置可以正常运行，如下所述：RStudio Shiny list from checking rows in dataTables

将此扩展到多个表，在不同的选项卡中分隔，这些表似乎不是独立的。示例：如果我从表1中选择第1行，然后从表2中选择第2行 - 表2的呈现将同时显示第1行和第2行。如果我现在按＆＃34;保存2＆＃34;按钮，它将保存三个记录：第1行（第1行）和第1行第2行（第2行）。

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

修改 回调现在正在工作，收集复选框的值并相互独立地工作。尽管如此，储蓄仍未按预期发挥作用。这可能是一个闪亮/反应性问题？

app.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

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

app.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)