Question 216571 in Javascript Question posted in
A very good W3school tutorial can be found here.

Javascript – How to toggle a cell and remove it for further calculation within a shiny app

I am creating an app whom the goal is to compute rowmeans and coefficient variation (by rows). Each id got 3 measures. The user must be able to remove one or two values if the cv is too high (8).

I success to manipulate the tables like I expected, but cannot find the solution to removed the values of the cells while I click on it. Here is the current example of the app below.

library(shiny)
library(DT)

ui <- fluidPage(
  fluidRow(
    column(width = 8, DTOutput("table1")),
    column(width = 4, DTOutput("table2"))
  ),
  
  # Custom CSS to define the initial cell color
  tags$head(
    tags$style(HTML("
      .default-cell-color {
        background-color: lightgreen !important;
      }
      .selected-cell-color {
        background-color: lightcoral !important;
      }
    "))
  )
)

server <- function(input, output, session) {
  # Sample data for demonstration purposes (contains only numeric values)
  data <- data.frame(
    ID = c(1, 2, 3),
    Measure1 = c(25, 30, 22),
    Measure2 = c(30, 32, 28),
    Measure3 = c(35, 40, 30)
  )
  
  # Add a new column for row means
  data$row_mean <- apply(data[, -1], 1, mean) # Calculate row means for numeric columns (excluding the first column)
  
  # Add a new column for coefficient of variation (CV)
  data$cv <- apply(data[, -1], 1, function(row) (sd(row) / mean(row)) * 100)
  
  # Render the first table using DT::renderDataTable
  output$table1 <- DT::renderDataTable({
    datatable(
      data[, c(1:4)],
      selection = "none", # Disable row selection
      editable = FALSE,   # Disable cell editing
      class = "cell-color-table",
      options = list(
        dom = "t",        # Display table only without search bar, etc.
        pageLength = 10,  # Number of rows per page
        columnDefs = list(
          list(targets = "_all", className = "dt-center") # Center-align all columns
        ),
        initComplete = JS(
          "function(settings, json) {",
          "  var table = settings.oInstance.api();",
          "  table.cells().every(function() {",
          "    $(this.node()).addClass('default-cell-color');",
          "  });",
          "  table.on('click.dt', 'td', function() {",
          "    var cell = $(this);",
          "    var table = cell.closest('table').DataTable();",
          "    var row = table.cell(this).index().row;",
          "    var col = table.cell(this).index().column;",
          "    var isSelected = cell.hasClass('selected-cell-color');",
          "    if (isSelected) {",
          "      cell.removeClass('selected-cell-color');",
          "      cell.addClass('default-cell-color');",
          "    } else {",
          "      cell.removeClass('default-cell-color');",
          "      cell.addClass('selected-cell-color');",
          "    }",
          "    Shiny.setInputValue('selected_cells', {row: row, col: col, isSelected: !isSelected});",
          "  });",
          "}"
        )
      )
    )
  })
  
  # Render the second table for row means and CV
  output$table2 <- DT::renderDataTable({
    datatable(
      data[, c("row_mean", "cv")],
      selection = "none", # Disable row selection
      editable = FALSE,   # Disable cell editing
      class = "cell-color-table",
      options = list(
        dom = "t",        # Display table only without search bar, etc.
        pageLength = 10,  # Number of rows per page
        columnDefs = list(
          list(targets = "_all", className = "dt-center") # Center-align all columns
        )
      )
    ) %>% 
      formatStyle(
        'cv',
        backgroundColor = styleInterval(8, c('lightgreen', 'red'))
      )
  })
  
  # Observe changes in the selected_cells input and update cell colors accordingly
  observe({
    selected <- input$selected_cells
    if (!is.null(selected)) {
      rows <- selected$row
      cols <- selected$col
      
      # Get the JavaScript code to update cell colors based on the selected cells
      js_code <- ""
      for (i in seq_along(rows)) {
        row <- rows[i]
        col <- cols[i]
        cell_css <- sprintf("#table1 tbody tr:eq(%d) td:eq(%d)", row, col)
        js_code <- paste0(js_code, sprintf("$('%s').toggleClass('selected-cell-color').toggleClass('default-cell-color');", cell_css))
      }
      session$sendCustomMessage(type = 'jsCode', list(code = js_code))
    }
  })
}
shinyApp(ui, server)
Tags:

2

Answers


  1. Chosen as BEST ANSWER
    0

    I restarted from the very beginning, without considering the colors. now it seems that I got almost the solution. I must mix it with the previous code and fix some bugs while clicking on the case (I do not figure out why there is a "gap" while clicking).

    library(shiny)
library(DT)

# Sample data (replace this with your own dataset)
set.seed(123)
data <- data.frame(
  ID = 1:5,
  A = rnorm(5, mean = 10, sd = 2),
  B = rnorm(5, mean = 15, sd = 3),
  C = rnorm(5, mean = 5, sd = 1)
)

ui <- fluidPage(
  tags$head(
    tags$style(HTML("
      .non-editable-datatable td:not(.dataTables_empty) {
        pointer-events: none;
        background-color: #f9f9f9;
      }
      .non-editable-datatable td, .non-editable-datatable th {
        border-color: #dee2e6;
      }
      .non-editable-datatable th {
        background-color: #f2f2f2;
      }
      .non-editable-datatable td.dataTables_empty {
        background-color: transparent;
      }
    "))
  ),
  titlePanel("Row Means and Coefficient of Variation with Exclusion"),
  DTOutput("table")
)

server <- function(input, output) {
  # Reactive values to store the excluded cell coordinates
  excluded_cells <- reactiveValues(rows = NULL, cols = NULL)
  
  # Render the data table
  output$table <- renderDT({
    data_excluded <- data
    if (!is.null(excluded_cells$rows)) {
      for (i in seq_along(excluded_cells$rows)) {
        data_excluded[excluded_cells$rows[i], excluded_cells$cols[i]] <- NA
      }
    }
    
    # Calculate row means
    row_means <- rowMeans(data_excluded[, -1], na.rm = TRUE)
    
    # Add a new column for row means
    data_excluded$Row_Means <- row_means
    
    datatable(
      data_excluded,
      rownames = FALSE,
      editable = FALSE,  # Set to FALSE to make the table non-editable
      selection = "none",
      options = list(dom = "t", pageLength = 6, drawCallback = JS(
        "function(settings) {
          var table = settings.oInstance.api();
          table.cells('.non-editable-datatable td', { page: 'current' }).nodes().to$().addClass('non-editable-datatable');
        }"
      ))
    )
  })
  
  # Update the excluded_cells reactiveValues when a cell is clicked
  observeEvent(input$table_cell_clicked, {
    info <- input$table_cell_clicked
    if (!is.null(info$value) && !is.na(info$value)) {
      # Check if the cell is already excluded
      if (info$row %in% excluded_cells$rows & info$col %in% excluded_cells$cols) {
        # If excluded, remove it from the list
        excluded_cells$rows <- excluded_cells$rows[!(excluded_cells$rows == info$row)]
        excluded_cells$cols <- excluded_cells$cols[!(excluded_cells$cols == info$col)]
      } else {
        # If not excluded, add it to the list
        excluded_cells$rows <- c(excluded_cells$rows, info$row)
        excluded_cells$cols <- c(excluded_cells$cols, info$col)
      }
    }
  })
}

shinyApp(ui, server)

  2. 0

    Here is what I get with my code outside Shiny:

    enter image description here

    That works as expected. But in Shiny, that doesn’t work: once a cell is erased, it immediately reappears with the original data. I don’t know how to solve this issue yet, except by putting the DT table directly in the UI, but maybe you need to use reactivity.

    Edit

    I understand now: put server = FALSE in renderDT and it works.

    The code:

    library(shiny)
library(DT)
library(jsonlite)

dat <- data.frame(
  ID = c(1, 2, 3),
  Measure1 = c(25, 30, 22),
  Measure2 = c(30, 32, 28),
  Measure3 = c(35, 40, 30)
)
dat_json <- toJSON(dat, dataframe = "values")

js <- c(
  sprintf("var originalData = %s;", dat_json),
  "table.on('click.dt', 'td', function() {",
  "  var cell = table.cell(this);",
  "  var row = cell.index().row;",
  "  var col = cell.index().column;",
  "  var cellData = cell.data();",
  "  if(cellData === null) {",
  "    cell.data(originalData[row][col]).draw();",
  "  } else {",
  "    cell.data(null).draw();",
  "  }",
  "});"
)


ui <- basicPage(
  br(),
  DTOutput("dtable")
)

server <- function(input, output, session) {
  output[["dtable"]] <- renderDT({
    datatable(
      dat, rownames = FALSE,
      selection = "none",
      callback = JS(js)
    )
  })
}

shinyApp(ui, server)
    Login or Signup to reply.
Please signup or login to give your own answer.

Back To Top
Search