限制允许在 Shiny 中的数据表上选中的复选框的数量

Question

有没有办法使用 Shiny 来限制允许在

check-boxes

复选框列上检查的

datatable

的数量？

我可以使用以下代码获得所需的结果，但最好限制允许的复选框数量。

library("data.table")
library("ggplot2")
library("rlang")
library("shiny")
library("glue")
library("DT")

Data <- data.table(
  Type = c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width"),
  ID = glue("ID_{1:4}"),
  Plot = glue::glue('<input type="checkbox" name="selected" value="{1:4}"><br>')
)
ui <- fluidPage(
  fluidRow(
    column(
      6,
      DT::dataTableOutput('table'),
      tags$script(
        HTML(
          '$(document).on("click", "input", function () {
              var checkboxes = document.getElementsByName("selected");
              var checkboxesChecked = [];
              for (var i=0; i<checkboxes.length; i++) {
                if (checkboxes[i].checked) {
                  checkboxesChecked.push(checkboxes[i].value);
                }
              }
            Shiny.onInputChange("checked_rows",checkboxesChecked);
          })'
        )
      )
    ),
    column(
      6,
      plotOutput(outputId = "scatterplot")
    )
  )
)

server <- function(input, output) {
  output$value1 <- renderPrint({
    length(input$checked_rows)
  })
  output$table <- DT::renderDataTable({
    datatable(
      Data,
      escape=F,
      rownames=F, 
      class = 'cell-border compact', 
      options=list(
        ordering=T,
        autowidth=F,
        scrollX = TRUE,
        columnDefs = list(list(className = 'dt-center', targets = "_all"))
      ),
      selection="none"
    )
  })
  observe({
    sel_rows <- as.integer(input$checked_rows)
    if (length(sel_rows) == 2) {
      var_x <- rlang::sym(Data[["Type"]][sel_rows[1]])
      var_y <- rlang::sym(Data[["Type"]][sel_rows[2]])
      output$scatterplot <- renderPlot({
        ggplot(iris, aes(x = !!var_x, y = !!var_y)) + 
          geom_point(aes(col = Species), size = 2) +
          scale_color_discrete(name ="Species") +
          geom_smooth(aes(group=Species, color = Species), method='lm')
      })
    }
  })
}

shinyApp(ui = ui, server = server)

有人知道怎么做吗？

谢谢你，

Answer 1

我稍微编辑了你的 JS 代码。 使用示例代码，同时只能进行两个选择，这对于具有两个变量的散点图是有意义的。 如果需要，我们会禁用输入。

library("data.table")
library("ggplot2")
library("rlang")
library("shiny")
library("glue")
library("DT")

Data <- data.table(
  Type = c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width"),
  ID = glue("ID_{1:4}"),
  Plot = glue::glue('<input type="checkbox" name="selected" value="{1:4}"><br>')
)

ui <- fluidPage(
  fluidRow(
    column(
      6,
      DT::dataTableOutput('table'),
      tags$style(".check_disabled {pointer-events:none;color:grey;}"),
      tags$script(
        HTML(
          '$(document).on("click", "input", function () {
              var checkboxes = document.getElementsByName("selected");
              var checkboxesChecked = [];
          
              for (var i=0; i<checkboxes.length; i++) {
                if (checkboxes[i].checked) {
                  checkboxesChecked.push(checkboxes[i].value);
                }
              }
          
                
              for (var i=0; i<checkboxes.length; i++) {
                if (checkboxesChecked.length >= 2 && (!checkboxes[i].checked)) {
                  checkboxes[i].disabled = true;
                } else {
                  checkboxes[i].disabled = false;
                }
              }
          
              Shiny.onInputChange("checked_rows",checkboxesChecked);
          })'
        )
      )
    ),
    column(
      6,
      plotOutput(outputId = "scatterplot")
    )
  )
)

server <- function(input, output) {
  output$value1 <- renderPrint({
    length(input$checked_rows)
  })
  output$table <- DT::renderDataTable({
    datatable(
      Data,
      escape=F,
      rownames=F, 
      class = 'cell-border compact', 
      options=list(
        ordering=T,
        autowidth=F,
        scrollX = TRUE,
        columnDefs = list(list(className = 'dt-center', targets = "_all"))
      ),
      selection="none"
    )
  })
  observe({
    sel_rows <- as.integer(input$checked_rows)
    if (length(sel_rows) == 2) {
      var_x <- rlang::sym(Data[["Type"]][sel_rows[1]])
      var_y <- rlang::sym(Data[["Type"]][sel_rows[2]])
      output$scatterplot <- renderPlot({
        ggplot(iris, aes(x = !!var_x, y = !!var_y)) + 
          geom_point(aes(col = Species), size = 2) +
          scale_color_discrete(name ="Species") +
          geom_smooth(aes(group=Species, color = Species), method='lm')
      })
    }
  })
}

shinyApp(ui = ui, server = server)