rdatatabledashboarddt

How to Create an Editable DataTable in Shiny with Tooltips and Always-Visible Input Fields?


I would like to display a data table in an R Shiny dashboard using DT, where the user can enter measurement values in the "Value" column. All other columns should not be editable. The process of entering a value in the "Value" column should work without needing to double-click on the cell. Is it possible to have the input field permanently displayed by default in all cells of the "Value" column?

library(shiny)
library(shinydashboard)
library(DT)

data <- data.frame(
  Param = c("FVC", "FEV1", "FEV1/FVC ratio"),
  Tooltip = c("forced vital capacity", "forced expiratory volume exhaled in the first second", "tiffeneau index"),
  Unit = c("l", "l", "%"),
  Value = c(NA, NA, NA)
)

data

# UI
ui <- dashboardPage(
  dashboardHeader(title = "Test"),
  dashboardSidebar(disable = TRUE),
  dashboardBody(
    DTOutput("table")
  )
)

# Server
server <- function(input, output, session) {
  output$table <- renderDT({
    datatable(
      data,
      options = list(
        dom = 't',
        paging = FALSE,
        ordering = FALSE
      ),
      selection = 'none',
      rownames = FALSE,
      editable = list(target = 'cell', disable = list(columns = c(0, 1, 2)))
    )
  }, server = FALSE)
}

# Shiny-App starten
shinyApp(ui = ui, server = server)

Solution

  • Below is a modified version of your example where the functionality is working that if you populate the inputs via the "Select dummy data" option, these values get recognized by shiny. The reason why this is not working in your example is that you created the inputs using oninput="Shiny.setInputValue(...)", but this never gets triggered when the user does not type something into the input. So shiny does not know the values in such a case.

    Below I added a session$sendCustomMessage which sends the list of values to JS after populating the inputs and there triggers a Shiny.setInputValue on each of them. Then shiny knows them and also if the user changes some of the values, your previously defined Shiny.setInputValue lets shiny know the updated values.

    library(shiny)
    library(shinydashboard)
    library(DT)
    
    # Data frame skeleton without data
    data <- data.frame(
      Param = c("FVC", "FEV1", "FEV1/FVC ratio"),
      Tooltip = c("forced vital capacity", "forced expiratory volume exhaled in the first second", "tiffeneau index"),
      Unit = c("l", "l", "%"),
      stringsAsFactors = FALSE
    )
    
    # UI
    ui <- dashboardPage(
      dashboardHeader(title = "Test"),
      dashboardSidebar(disable = TRUE),
      dashboardBody(
        tags$head(tags$script('Shiny.addCustomMessageHandler("setCreatedInputs",
          function(message) {
            for (const [key, value] of Object.entries(message)) {
              Shiny.setInputValue(key, value);
            }
          })')),
        tabBox(
          id = "tabs",
          width = 12,
          tabPanel(
            "Input",
            selectInput("inputType", "Select Dummy Data:", choices = c("Empty", "Obstruction", "Restriction")),
            DTOutput("table")
          ),
          tabPanel("Output", verbatimTextOutput("outputText"))
        ),
        actionButton("createButton", "Create")
      )
    )
    
    # Server
    server <- function(input, output, session) {
      
      # Function to fill the data table with dummy data."
      updateTable <- function(inputType) {
        values <- switch(inputType,
                         "Empty" = list("", "", ""),
                         "Obstruction" = list("2.5", "1.8", "72.0"),
                         "Restriction" = list("3.2", "2.9", "90.6"))
        
        data$Value <- paste0('<input type="text" style="width: 100%" id="val_', 1:3, 
                             '" value="', values, 
                             '" oninput="Shiny.setInputValue(\'val_', 1:3, '\', this.value)">')
        
        names(values) <- paste0("val_", 1:length(values))
    
        session$sendCustomMessage("setCreatedInputs", message = values)
        
        output$table <- renderDT({
          datatable(
            data,
            options = list(
              dom = 't',
              paging = FALSE,
              ordering = FALSE
            ),
            selection = 'none',
            rownames = FALSE,
            escape = FALSE,  # Set escape to FALSE to allow HTML input fields
            editable = list(target = 'cell', disable = list(columns = c(0, 1, 2)))
          )
        }, server = FALSE)
      }
      
      # Create Initial Data Table with Empty Text Fields
      observe({
        updateTable("Empty")
      })
      
      # Update the Data Table when the dropdown value is changed
      observeEvent(input$inputType, {
        updateTable(input$inputType)
      })
      
      # Update the output panel when the create button is clicked
      observeEvent(input$createButton, {
        # Extract and format values
        values <- sapply(1:nrow(data), function(i) {
          as.numeric(input[[paste0("val_", i)]])
        })
        
        # Check the type and structure of the values
        if (is.list(values) || any(is.na(values))) {
          # Display an error message if values is a list or contains NA values
          showModal(modalDialog(
            title = "Error",
            "The data input is incorrect. Please check the inputs and try again.",
            easyClose = TRUE,
            footer = NULL
          ))
        } else {
          # Format values to two decimal places
          formattedValues <- formatC(values, format = "f", digits = 2)
          
          # Combine parameters and formatted values
          outputText <- paste(data$Param, ":", formattedValues, data$Unit, collapse = ", ")
          
          output$outputText <- renderText({
            outputText
          })
          
          # Switch to the Output tab
          updateTabItems(session, "tabs", "Output")
        }
      })
    }
    
    # Shiny-App starten
    shinyApp(ui = ui, server = server)