通过单击actionButton()或闪亮的小部件选择一个数据表行 [英] Choose a datatable row either by clicking, actionButton() or shiny widget

问题描述

我下面有一个闪亮的应用程序，用户可以在其中选择一行以3种方式显示其索引.

I have the shiny app below in which the user is able to choose a row to display its index with 3 ways.

1. 单击该行并显示其索引
2. 单击一行，然后按 Next 并显示下一行的索引.
3. 选择一行的行名，按 Assign 并显示其索引.

1. Click on the row and display its index
2. Click on a row then press Next and display the index of the next row.
3. Select the rowname of a row,press Assign and display its index.

我知道我可以使用 callback 来使数据表实现此目的，但是我不知道如何组合许多 callbacks .

I know that I can use callback in order to enable datatable to achieve this but I do not know how to combine many callbacks.

library(shiny)
library(DT)

dat <- mtcars

callback <- JS(
  "Shiny.addCustomMessageHandler(",
  "  'selectRow',",
  "  function(index) {",
  "    table.row(index - 1).select();",
  "  }",
  ");",
  "$('#btn-next').prop('disabled', true);",
  "var selected_row = null;",
  "table.on('select', function( e, dt, type, indexes ) {",
  "  $('#btn-next').prop('disabled', false);",
  "  selected_row = indexes[0];",
  "});",
  "table.on('deselect', function( e, dt, type, indexes ) {",
  "  $('#btn-next').prop('disabled', true);",
  "});",
  "var nrows = table.rows().count();",
  "$('#btn-next').on('click', function() {",
  "  var next_row = selected_row + 1 < nrows ? selected_row + 1 : 0;",
  "  table.row(next_row).select();",
  "});"
)

ui <- fluidPage(
  br(),
  DTOutput("dtable"),
  br(),
  
    textOutput("selectedRow"),
    actionButton("btn-next", "select next row"),
    pickerInput(
      "rowname",
      label = "Choose a row",
      choices = setNames(1:nrow(dat), rownames(dat))
    ),
    actionButton("assign", "Assign")
    
    
  
)

server <- function(input, output, session) {
  
  output[["dtable"]] <- renderDT({
    datatable(
      dat, 
      extensions = "Select",
      selection = "none",
      callback = callback,
      options = list(
        columnDefs = list(
          list(className = "dt-center", targets = "_all")
        ),
        select = list(style = "single")
      )
    )
  }, server = FALSE)
  
  output[["selectedRow"]] <- renderText({
    i <- input[["dtable_rows_selected"]]
    paste0(
      "Selected row: ", 
      ifelse(is.null(i), "none", i)
    )
  })
  observeEvent(input[["rowname"]], {observeEvent(input[["assign"]], {
    session$sendCustomMessage("selectRow", isolate(input[["rowname"]]))
  })})
  
}


shinyApp(ui, server)    

推荐答案

完整应用:

library(shinydashboard)
library(shinydashboardPlus)
library(DT)
library(shinyjs)
library(shinyWidgets)

attribute_name <- c("Jack", "Bob", "Jack", "Bob")
category_id <- c(7, 7, 7, 7)
candidate_phrase_lemma <- c("apple", "olive", "banana", "tomato")
d <- data.frame(
  attribute_name,
  category_id,
  candidate_phrase_lemma,
  stringsAsFactors = FALSE
)
names <- tapply(d$candidate_phrase_lemma, d$attribute_name, I)

candidate_1 <- c("Jack", "Bob", "Jack", "Bob")
candidate_2 <- c("phone", "camera", "micro", "pc")
similarity <- c(4, 5, 6, 7)
category_id <- c(7, 7, 7, 7)
e <- data.frame(candidate_1, candidate_2, similarity, category_id)

selector <- function(id, values, items = values) {
  options <- HTML(paste0(mapply(
    function(value, item) {
      as.character(tags$option(value = value, selected = "selected", item))
    }, values, items
  ), collapse = ""))
  as.character(
    tags$select(
      id = id, multiple = "multiple", options
    )
  )
}

dat <- data.frame(
  attributes = unique(as.character(d$attribute_name)),
  attributes_phrases = vapply(
    1:length(names),
    function(i) {
      selector(paste0("slct", i), names[[i]])
    },
    character(1)
  ),
  Count = lengths(names),
  stringsAsFactors = FALSE
)

nrows <- nrow(dat)

initComplete <- c(
  "function(settings) {",
  "  var table = this.api().table();",
  "  var nrows = table.rows().count();",
  "  function selectize(i) {",
  "    var $slct = $('#slct' + i);",
  "    $slct.select2({",
  "      width: '100%',",
  "      closeOnSelect: false",
  "    });",
  "    $slct.on('change', function(e) {",
  "      table.cell(i-1, 2).data($slct.val().length);",
  "    });",
  "  }",
  "  for(var i = 1; i <= nrows; i++) {",
  "    selectize(i);",
  "  }",
  "}"
)

callback <- JS(
  "Shiny.addCustomMessageHandler(",
  "  'selectRow',",
  "  function(index) {",
  "    table.row(index - 1).select();",
  "  }",
  ");",
  "$('#btn-next').prop('disabled', true);",
  "var selected_row = null;",
  "table.on('select', function( e, dt, type, indexes ) {",
  "  $('#btn-next').prop('disabled', false);",
  "  selected_row = indexes[0];",
  "});",
  "table.on('deselect', function( e, dt, type, indexes ) {",
  "  $('#btn-next').prop('disabled', true);",
  "});",
  "var nrows = table.rows().count();",
  "$('#btn-next').on('click', function() {",
  "  var next_row = selected_row + 1 < nrows ? selected_row + 1 : 0;",
  "  table.row(next_row).select();",
  "});"
)

js <- paste0(c(
  "Shiny.addCustomMessageHandler(",
  "  'addCandidate',",
  "  function(row_candidate) {",
  "    var i = row_candidate.row;",
  "    var candidate = row_candidate.candidate;",
  "    var $slct = $('#slct' + i);",
  "    if($slct.find(\"option[value='\" + candidate + \"']\").length === 0) {",
  "      var newOption = new Option(candidate, candidate, true, true);",
  "      $slct.append(newOption).trigger('change');",
  "    }",
  "  }",
  ");"
), collapse = "\n")

shinyApp(
  ui = dashboardPagePlus(
    tags$head(
      tags$link(rel = "stylesheet", href = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/css/select2.min.css"),
      tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/js/select2.min.js"),
      tags$style(HTML(
        ".select2-selection__choice {background-color: darkblue !important;}"
      )),
      tags$script(HTML(js))
    ),
    useShinyjs(),
    header = dashboardHeaderPlus(),
    sidebar = dashboardSidebar(),
    body = dashboardBody(
      DTOutput("table"),
      br(),
      fluidRow(
        column(
          4,
          uiOutput("ui-rowselect")
        ),
        column(
          2,
          actionButton("selectrow", "Select this row")
        )
      ),
      br(),
      actionButton("btn-next", "Select next row"),
      br(), br(),
      conditionalPanel(
        condition = "input.table_rows_selected.length > 0",
        wellPanel(
          uiOutput("celltext"),
          splitLayout(
            actionButton("bc", "Previous candidate"),
            actionButton("dec", "Next candidate"),
            actionButton("addWord", "Add this candidate", class = "btn-info"),
            cellWidths = "auto"
          )
        )
      )
    )
  ),
  server = function(input, output, session) {
    Text <- reactiveVal()
    Data <- reactiveVal()
    Candidate <- reactiveVal()
    rnum <- reactiveVal()

    output[["table"]] <- renderDT({
      datatable(
        data = dat,
        extensions = "Select",
        selection = "none",
        escape = FALSE,
        rownames = FALSE,
        callback = callback,
        options = list(
          pageLength = 5,
          columnDefs = list(
            list(className = "dt-center", targets = "_all")
          ),
          select = list(style = "single"),
          initComplete = JS(initComplete),
          preDrawCallback = JS(
            "function() { Shiny.unbindAll(this.api().table().node()); }"
          ),
          drawCallback = JS(
            "function() { Shiny.bindAll(this.api().table().node()); }"
          )
        )
      )
    }, server = FALSE)
    
    output[["ui-rowselect"]] <- renderUI({
      selectedRow <- input[["table_rows_selected"]]
      choices <- if(is.null(selectedRow)) 1:nrows else (1:nrows)[-selectedRow]
      pickerInput(
        "rowselect",
        label = "Choose a row",
        choices = choices
      ) 
    })
    
    observeEvent(input[["selectrow"]], {
      session$sendCustomMessage("selectRow", input[["rowselect"]])
    })
    
    observeEvent(input[["table_rows_selected"]], {
      row <- input[["table_rows_selected"]]
      dat <- e[e[["candidate_1"]] %in% d[row, 1], ]
      Data(dat[order(dat[["similarity"]], decreasing = TRUE), ])
      rnum(1)
    })
    
    output[["celltext"]] <- renderUI({
      HTML(Text())
    })
    
    observeEvent(input[["dec"]], {
      rnum(rnum() + 1)
    })
    
    observeEvent(input[["bc"]], {
      rnum(rnum() - 1)
    })
    
    observeEvent(list(rnum(), Data()), {
      if(rnum() == 1){
        disable("bc")
      }else{
        enable("bc")
      }
      if(rnum() == nrows){
        disable("dec")
      }else{
        enable("dec")
      }
      Candidate(Data()[rnum(), 2])
      Text(
        paste(
          "Similarity of <em>", Data()[rnum(), 1], "</em>",
          "to candidate <em>", Candidate(), "</em>",
          "is <strong>", Data()[rnum(), 3], "</strong>"
        )
      )
    }, ignoreInit = TRUE)
    
    observeEvent(input[["addWord"]], {
      session$sendCustomMessage(
        "addCandidate",
        list(row = input[["table_rows_selected"]], candidate = Candidate())
      )
    })
    
  }
)

这篇关于通过单击actionButton()或闪亮的小部件选择一个数据表行的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！