如何根据用户单击将值输入到 Shiny DataTable 中？

Question

My example is based on code from Stéphane Laurent with my code below: Change row CSS properties on clicking an icon

My goal in addition to changing the CSS properties is to add today's date to the corresponding row where the click was made.

So far I've created an extra column called the_date , created a reactiveValues dataframe, and then updated it based on an observeEvent. When the "x" is clicked the the_date gets filled, but it takes another click to change the CSS properties. If I then click on another "x" without a the_date value, then the CSS properties change for the whole table.

How do I change the CSS properties on a click and also edit the table at the same time?

library(shiny)
library(DT)
library(lubridate)
rowNames <- TRUE # whether to show row names in the table
colIndex <- as.integer(rowNames)
callback <- c(
  sprintf("table.on('click', 'td:nth-child(%d)', function(){", colIndex+1),
  "  var td = this;",
  "  var cell = table.cell(td);",
  "  if(cell.data() === 'ok'){",
  "    cell.data('remove');",
  "  } else {",
  "    cell.data('ok');",
  "  }",
  "  var $row = $(td).closest('tr');",
  "  $row.toggleClass('excluded');",
  "  var excludedRows = [];",
  "  table.$('tr').each(function(i, row){",
  "    if($(this).hasClass('excluded')){",
  "      excludedRows.push(parseInt($(row).attr('id').split('_')[1]))",
  "    }",
  "  });",
  "  Shiny.setInputValue('excludedRows', excludedRows);",
  "})"
)
restore <- c(
  "function(e, table, node, config) {",
  "  table.$('tr').removeClass('excluded').each(function(){",
  sprintf("    var td = $(this).find('td').eq(%d)[0];", colIndex),
  "    var cell = table.cell(td);",
  "    cell.data('remove');",
  "  });",
  "  Shiny.setInputValue('excludedRows', null);",
  "}"
)
render <- c(
  'function(data, type, row, meta){',
  '  if(type === "display"){',
  '    var color = data === "remove" ? "red" : "forestgreen";',
  '    return "<span style=\\\"color:" + color +',
  '           "; font-size:18px\\\"><i class=\\\"glyphicon glyphicon-" +',
  '           data + "\\\"></i></span>";',
  '  } else {',
  '    return data;',
  '  }',
  '}'
)
ui <- fluidPage(
  tags$head(
    tags$style(HTML(
      ".excluded { color: rgb(211,211,211); font-style: italic; }"
    ))
  ),

  br(),
  DTOutput("mytable")
)
server <- function(input, output,session) {

  mcars <- mtcars[1:6,]
  mcars[,"the_date"] <- ""
  df <- cbind(Selected = "remove", mcars, id = paste0("row_",1:6))

  RV <- reactiveValues(data = df)


  output$mytable <- renderDataTable({
    datatable(isolate(RV$data), rownames = rowNames,
              extensions = c("Select", "Buttons"),
              selection = "none",
              callback = JS(callback),
              options = list(
                scrollY = "400px",
                paging = FALSE,
                rowId = JS(sprintf("function(df){return df[%d];}",
                                   ncol(df)-1+colIndex)),
                columnDefs = list(
                  list(visible = FALSE, targets = ncol(df)-1+colIndex),
                  list(className = "dt-center", targets = "_all"),
                  list(className = "notselectable", targets = colIndex),
                  list(targets = colIndex, render = JS(render))
                ),
                dom = "Bt",
                buttons = list("copy", "csv",
                               list(
                                 extend = "collection",
                                 text = 'Select all rows',
                                 action = JS(restore)
                               )
                ),
                select = list(style = "single",
                              selector = "td:not(.notselectable)")
              )
    )
  }, server = FALSE)


  observeEvent(input$excludedRows, {
    RV$data[as.integer(input$excludedRows), ]$the_date <- as.character.Date(today())
  })

}
shinyApp(ui, server)

Answer 1

Is it what you want?

library(shiny)
library(DT)

rowNames <- TRUE # whether to show row names in the table
colIndex <- as.integer(rowNames)

mcars <- mtcars[1:6,]
mcars[,"the_date"] <- ""
df <- cbind(Selected = "remove", mcars, id = paste0("row_",1:6))
colDate <- which(names(df) == "the_date")

callback <- c(
  sprintf("table.on('click', 'td:nth-child(%d)', function(){", colIndex+1),
  "  var td = this;",
  "  var cell = table.cell(td);",
  "  var $row = $(td).closest('tr');",
  sprintf("  var cell_date = table.cell($row[0], %d);", colDate + colIndex - 1),
  "  var today = new Date();",
  "  var date = today.getFullYear()+'-'+(today.getMonth()+1)+'-'+today.getDate();",
  "  if(cell.data() === 'ok'){",
  "    cell.data('remove');",
  "    cell_date.data('');",
  "  } else {",
  "    cell.data('ok');",
  "    cell_date.data(date);",
  "  }",
  "  $row.toggleClass('excluded');",
  "  var excludedRows = [];",
  "  table.$('tr').each(function(i, row){",
  "    if($(this).hasClass('excluded')){",
  "      excludedRows.push(parseInt($(row).attr('id').split('_')[1]))",
  "    }",
  "  });",
  "  Shiny.setInputValue('excludedRows', excludedRows);",
  "})"
)
restore <- c(
  "function(e, table, node, config) {",
  "  table.$('tr').removeClass('excluded').each(function(){",
  sprintf("    var td = $(this).find('td').eq(%d)[0];", colIndex),
  "    var cell = table.cell(td);",
  "    cell.data('remove');",
  "  });",
  "  Shiny.setInputValue('excludedRows', null);",
  "}"
)
render <- c(
  'function(data, type, row, meta){',
  '  if(type === "display"){',
  '    var color = data === "remove" ? "red" : "forestgreen";',
  '    return "<span style=\\\"color:" + color +',
  '           "; font-size:18px\\\"><i class=\\\"glyphicon glyphicon-" +',
  '           data + "\\\"></i></span>";',
  '  } else {',
  '    return data;',
  '  }',
  '}'
)
ui <- fluidPage(
  tags$head(
    tags$style(HTML(
      ".excluded { color: rgb(211,211,211); font-style: italic; }"
    ))
  ),

  br(),
  DTOutput("mytable")
)
server <- function(input, output,session) {

  output$mytable <- renderDataTable({
    datatable(df, rownames = rowNames,
              extensions = c("Select", "Buttons"),
              selection = "none",
              callback = JS(callback),
              options = list(
                scrollY = "400px",
                paging = FALSE,
                rowId = JS(sprintf("function(df){return df[%d];}",
                                   ncol(df)-1+colIndex)),
                columnDefs = list(
                  list(visible = FALSE, targets = ncol(df)-1+colIndex),
                  list(className = "dt-center", targets = "_all"),
                  list(className = "notselectable", targets = colIndex),
                  list(targets = colIndex, render = JS(render))
                ),
                dom = "Bt",
                buttons = list("copy", "csv",
                               list(
                                 extend = "collection",
                                 text = 'Select all rows',
                                 action = JS(restore)
                               )
                ),
                select = list(style = "single",
                              selector = "td:not(.notselectable)")
              )
    )
  }, server = FALSE)

}
shinyApp(ui, server)