编辑

Question

我有一个数据表。我希望用户能够从表中选择列（用于各种功能）。我还希望用户能够选中某些框。但是，当用户在我的应用程序中选中一个框时，也会选中该列。我不希望这种情况发生。我该如何阻止

ui.R

ui<-fluidPage(
  # box(width=12,
  h3(strong("My picker"),align="center"),
  hr(),
  # column(6,offset = 6,
  HTML('<div class="btn-group" role="group" aria-label="Basic example">'),
  actionButton(inputId = "Del_row_head",label = "Delete selected rows"),
  HTML('</div>'),
  # ),

  #column(12,dataTableOutput("Main_table")),
  tags$script(HTML('$(document).on("click", "input", function () {
                       var checkboxes = document.getElementsByName("row_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);
                       })')),
  tags$script("$(document).on('click', '#Main_table button', function () {
                  Shiny.onInputChange('lastClickId',this.id);
                  Shiny.onInputChange('lastClick', Math.random())
                  });"),



  dashboardPage(

    dashboardHeader(title = 'My shiny'),

    dashboardSidebar(),
      dashboardBody( DT::dataTableOutput("endotable")))
  )




RV <- reactiveValues(mtcars)

server.R

server <- function(input, output) {
output$endotable = DT::renderDT({
  if (!is.null(mtcars)) {  

    mtcars[["Select"]]<-paste0('<input type="checkbox" name="row_selected" value="Row',1:nrow(mtcars),'"><br>')

    mtcars[["Actions"]]<-
      paste0('
                 <div class="btn-group" role="group" aria-label="Basic example">
                 <button type="button" class="btn btn-secondary delete" id=delete_',1:nrow(mtcars),'>Delete</button>
                 </div>
                 ')
  }

 datatable(mtcars,escape=F,options = list(scrollX = TRUE,pageLength = 5),selection = list(target = 'column'))

},selection = list(target = 'column'),escape=F,options = list(scrollX = TRUE,pageLength = 5))

observeEvent(input$Del_row_head,{
  row_to_del=as.numeric(gsub("Row","",input$checked_rows))

  mtcars=mtcars[-row_to_del]}
)




observeEvent(input$lastClick,
             {
               if (input$lastClickId%like%"delete")
               {
                 row_to_del=as.numeric(gsub("delete_","",input$lastClickId))
                 RV$data=RV$data[-row_to_del]
               }
               else if (input$lastClickId%like%"modify")
               {
                 showModal(modal_modify)
               }
             }
)
}

shinyApp(ui = ui, server = server)

Answer 1

将selection设置为"none"；我们将借助Select扩展名和回调“手动”定义选择行为。启用此扩展，使用选项select = "api"，并将类notselectable赋予第12和13列（“选择”和“操作”）：

datatable(mtcars, escape=FALSE, callback = JS(callback), 
          extensions = "Select", selection = "none",
          options = list(
            scrollX = TRUE, 
            pageLength = 5,
            columnDefs = list(
              list(className = "notselectable", targets = c(12,13))
            ),
            select = "api"))

现在进行回调：

callback <- c(
  "table.on('click', 'tbody td', function(){",
  "  // if the column is already selected, deselect it:",
  "  if(table.column(this, {selected: true}).length){",
  "    table.column(this).deselect();",
  "  // otherwise, select the column unless there's the class 'notselectable':",
  "  } else if(!$(this).hasClass('notselectable')){",
  "    table.column(this).select();",
  "  }",
  "});"
)

编辑

评论中提出的新问题：

真实应用中的表是反应式的，可以添加新列，以便目标= c（12,13）将停止显示该表。我怎么能够将最后两列定义为不可选择，而不是具体的列号？

使用此回调：

callback <- c(
  "var ncols = table.columns().count();",
  "table.on('click', 'tbody td', function(){",
  "  // if the column is selected, deselect it:",
  "  if(table.column(this, {selected: true}).length){",
  "    table.column(this).deselect();",
  "  // otherwise, select the column unless it's among the last two columns:",
  "  } else if([ncols-1, ncols-2].indexOf(table.column(this).index()) === -1){",
  "    table.column(this).select();",
  "  }",
  "});"
)

无需在最后两列中设置类：

datatable(mtcars, escape=FALSE, callback = JS(callback), 
          extensions = "Select", selection = "none",
          options = list(
            scrollX = TRUE, 
            pageLength = 5,
            select = "api"))

编辑2

要获取Shiny中选定列的索引：

callback <- c(
  "var ncols = table.columns().count();",
  "var tbl = table.table().node();",
  "var tblID = $(tbl).closest('.datatables').attr('id');",
  "table.on('click', 'tbody td', function(){",
  "  // if the column is selected, deselect it:",
  "  if(table.column(this, {selected: true}).length){",
  "    table.column(this).deselect();",
  "  // otherwise, select the column unless it's among the last two columns:",
  "  } else if([ncols-1, ncols-2].indexOf(table.column(this).index()) === -1){",
  "    table.column(this).select();",
  "  }",
  "  // send selected columns to Shiny",
  "  var indexes = table.columns({selected:true}).indexes();",
  "  var indices = Array(indexes.length);",
  "  for(var i = 0; i < indices.length; ++i){",
  "    indices[i] = indexes[i];",
  "  }",
  "  Shiny.setInputValue(tblID + '_columns_selected', indices);",
  "});"
)

然后，如果表中有行名，则所选列的索引位于input$endotable_columns_selected中。如果没有行名，则索引为input$endotable_columns_selected + 1。

编辑3

这是删除行的更干净的方法：

callback <- c(
  "var ncols = table.columns().count();",
  "var tbl = table.table().node();",
  "var tblID = $(tbl).closest('.datatables').attr('id');",
  "table.on('click', 'tbody td', function(){",
  "  // if the column is selected, deselect it:",
  "  if(table.column(this, {selected: true}).length){",
  "    table.column(this).deselect();",
  "  // otherwise, select the column unless it's among the last two columns:",
  "  } else if([ncols-2, ncols-3].indexOf(table.column(this).index()) === -1){",
  "    table.column(this).select();",
  "  }",
  "  // send selected columns to Shiny",
  "  var indexes = table.columns({selected:true}).indexes();",
  "  var indices = Array(indexes.length);",
  "  for(var i = 0; i < indices.length; ++i){",
  "    indices[i] = indexes[i];",
  "  }",
  "  Shiny.setInputValue(tblID + '_columns_selected', indices);",
  "});",
  "/* ---------------------------------------------------------- */",
  "// Handler to delete rows",
  "Shiny.addCustomMessageHandler('deleteHandler', function(rowIDs){",
  "  for(var i = 0; i < rowIDs.length; ++i){",
  "    deleteRow(rowIDs[i]);",
  "  }",
  "});"
)

js <- paste0(
  c(
    "function deleteRow(rowID){",
    "  var table = $('#endotable').find('table').DataTable();",
    "  var nrows = table.rows().count();",
    "  for(var i=0; i < nrows; ++i){",
    "    if(table.row(i).id() == rowID){",
    "      table.row(i).remove().draw(false);",
    "      break;",
    "    }",
    "  }",
    "}"
  ), 
  collapse = "\n"
)

ui <- fluidPage(

  tags$head(tags$script(HTML(js))),

  h3(strong("My picker"),align="center"),
  hr(),
  HTML('<div class="btn-group" role="group" aria-label="Basic example">'),
  actionButton(inputId = "Del_row_head",label = "Delete selected rows"),
  HTML('</div>'),
  tags$script(HTML('$(document).on("click", "input", function () {
                   var checkboxes = document.getElementsByName("row_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);
                   })')),
  # tags$script("$(document).on('click', '#Main_table button', function () {
  #             Shiny.onInputChange('lastClickId',this.id);
  #             Shiny.onInputChange('lastClick', Math.random())
  #             });"),

  dashboardPage(
    dashboardHeader(title = 'My shiny'),
    dashboardSidebar(),
    dashboardBody( DT::dataTableOutput("endotable")))
)

mtcars[["Select"]] <- 
  paste0('<input type="checkbox" name="row_selected" value="row_',1:nrow(mtcars),'"><br>')

mtcars[["Actions"]] <-
  paste0('
               <div class="btn-group" role="group" aria-label="Basic example">
               <button type="button" class="btn btn-secondary delete" id=delete_',1:nrow(mtcars),'>Delete</button>
               </div>
               ')

mtcars[["ROWID"]] <- paste0("row_", 1:nrow(mtcars))

server <- function(input, output, session) {

  RV <- reactiveValues(data = mtcars)

  # observe({
  #   print(input$endotable_columns_selected)
  # })

  output$endotable = DT::renderDT({

    datatable(RV$data, escape=FALSE, callback = JS(callback), 
              extensions = "Select", selection = "none",
              options = list(
                scrollX = TRUE, 
                pageLength = 5,
                select = "api",
                rowId = JS(sprintf("function(data){return data[%d];}", ncol(RV$data))),
                columnDefs = list(
                  list(visible = FALSE, targets = -1)
                )
              )
    )

  }, server = FALSE)

  observeEvent(input[["Del_row_head"]], {
    session$sendCustomMessage("deleteHandler", as.list(input$checked_rows))
  })

  # observeEvent(input$Del_row_head,{
  #   row_to_del <- as.numeric(gsub("Row","",input$checked_rows))
  #   RV$data <- RV$data[-row_to_del, ]
  # })
  # 
  # observeEvent(input$lastClick,
  #              {
  #                if (input$lastClickId%like%"delete")
  #                {
  #                  row_to_del=as.numeric(gsub("delete_","",input$lastClickId))
  #                  RV$data=RV$data[-row_to_del]
  #                }
  #                else if (input$lastClickId%like%"modify")
  #                {
  #                  showModal(modal_modify)
  #                }
  #              }
  # )
}

shinyApp(ui = ui, server = server)

如果数据表列选择器也处于活动状态，如何选择行

1 个答案:

编辑

编辑2

编辑3