Search code examples
rshinyshiny-reactivityshinyjs

How to automatically generate sequential column headers for an expandable matrix in R Shiny?


The below MWE code generates an expandable matrix (input grid) in R Shiny inside a modal dialog box, for user inputs. Action button "Modify" pulls up the default input grid which the user can modify (change default values, add/delete columns, etc.), "Show" and "Hide" show/hide the most recently updated input grid, and "Reset" returns input grid values to default values. All the above works well.

However, is it possible to automatically generate matrix column headers when the matrix is expandable, such as in this matrix function? So for example I have the first default column labeled "Series 1". I'd like any 2nd column that's added to be automatically labeled "Series 2", 3rd column labeled "Series 3", etc.; which the user would have the option to over-write on a column-by-column basis as it is currently set in shinyMatrix.

Below you'll see the line of code colnames(default_mat) <- paste0("Series ", 1:ncol(default_mat)) which works for generating the column header for the first default column. I've been trying to work this into the reactive sections of code in order to automatically generate headers for additional columns with no luck yet. User should have the ability to over-write this default auto header.

MWE code:

library(shiny)
library(shinyMatrix)
library(shinyjs)

default_mat <- matrix(c(1,24,0,1),4,1,dimnames=list(c("A","B","C","D"),NULL))

colnames(default_mat) <- paste0("Series ", 1:ncol(default_mat))

matrix3Input <- function(x, default_mat){
  matrixInput(x, 
              label = 'Series terms:',
              value = default_mat, 
              rows = list(extend = FALSE,names = TRUE), 
              cols = list(extend = TRUE,names = TRUE,editableNames = TRUE,delete = TRUE),
              class = "numeric") # close matrix input
} # close function

ui <- fluidPage(
  useShinyjs(),
  titlePanel("Inputs"),
  fluidRow(actionButton("modify","Modify"),
           actionButton("show","Show"),
           actionButton("hide","Hide"),
           actionButton("reset","Reset"),
           tableOutput("table2")
  ) # close fluid row
) # close fluid page

server <- function(input, output, session){
  
  rv <- reactiveValues(mat = matrix3Input("matrix", default_mat), 
                       input = default_mat,
                       name = colnames(default_mat)
        ) # close reactive values
  
  hide("table2")
  
  observeEvent(input$modify,{
    showModal(modalDialog(
      rv$mat,
      tableOutput("table1"))
    )
    hide("table2")
  })
  
  output$table1 <- renderTable({
    rv$mat <- matrix3Input("matrix", input$matrix)
    rv$input <- input$matrix
    input$matrix
  }, rownames = TRUE)
  
  observeEvent(input$show,{
    show("table2")
  })
  
  observeEvent(input$hide, hide("table2"))
  
  observeEvent(input$reset,{
    hide("table2")
    rv$input <- default_mat
    rv$mat <- matrix3Input("matrix", default_mat)
  }) # close observe event
  
  output$table2 <- renderTable({
    rv$input
  }, rownames = TRUE)
  
} # close server

shinyApp(ui, server)

Solution

  • Solved as follows:

    1. Added a reactive function for input "matrix" in the server section
    2. In the server section, observe changes in the input matrix with the observe function
    3. Inside the observe function, change the colnames of the input matrix given by input$matrix
    4. Send the updated matrix back to the UI with updateMatrixInput. Used the isolate function to avoid an endless cycle of change and refresh

    Revised MWE reflecting the solution, with changes from original MWE shown below marked with # << ADDED..., # << DELETED..., and similar notations:

    library(shiny)
    library(shinyMatrix)
    library(shinyjs)
    
    default_mat <- matrix(c(1,24,0,1),4,1,dimnames=list(c("A","B","C","D"),c(1))) # << ADDED c(1)
    # colnames(default_mat)... << DELETED this function that appeared in original MWE
    
    matrix3Input <- function(x, default_mat){
      matrixInput(x, 
                  label = 'Series terms:',
                  value = default_mat, 
                  rows = list(extend = FALSE,names = TRUE), 
                  cols = list(extend = TRUE,names = TRUE,editableNames = TRUE,delete = TRUE),
                  class = "numeric") # close matrix input
    }
    
    ui <- fluidPage(
      useShinyjs(),
      titlePanel("Inputs"),
      fluidRow(actionButton("modify","Modify"),
               actionButton("show","Show"),
               actionButton("hide","Hide"),
               actionButton("reset","Reset"),
               tableOutput("table2")
      )
    ) 
    
    server <- function(input, output, session){
      
      matrix  <- reactive(input$matrix) # << ADDED REACTIVE FOR "matrix"
      rv      <- reactiveValues(mat = matrix3Input("matrix", default_mat), input = default_mat) 
      
      hide("table2")
      
      observeEvent(input$modify,{
        showModal(modalDialog(
          rv$mat,
          tableOutput("table1"))
        )
        hide("table2")
      })
      
      # ADDED BELOW "OBSERVE", LINKs TO MATRIX INPUT >>
        observe({
          req(matrix())
          mm <- input$matrix
          colnames(mm) <- 1:ncol(mm)
          isolate(updateMatrixInput(session, "matrix", mm))
        })
      
      output$table1 <- renderTable({
        rv$mat <- matrix3Input("matrix", input$matrix)
        rv$input <- input$matrix
        input$matrix
      }, rownames = TRUE)
      
      observeEvent(input$show,{
        show("table2")
      })
      
      observeEvent(input$hide, hide("table2"))
      
      observeEvent(input$reset,{
        hide("table2")
        rv$input <- default_mat
        rv$mat <- matrix3Input("matrix", default_mat)
      })
      
      output$table2 <- renderTable({
        rv$input
      }, rownames = TRUE)
      
    } 
    
    shinyApp(ui, server)
    

    Thanks to Jan for his posted answer to similar and simplified CuriousJorge question on 29 Sep 2021 which set me on the course for this solution!