In R Shiny, how to run an observe function for an object rendered in modal dialog?-CodePudding

Further note: un-commenting the observe() section and inserting req(input$matrix2) underneath input$periods appears to work, except in circumstances where the user changes input$periods after having input into matrix2 in which case the input$periods limit is ignored.

In the below code, I'm trying to run the commented-out observe() function for matrix2 rendered in modalDialog(). Observe() is supposed to cap the values of the elements in the left column of matrix2 at input$periods. I tried placing this observe() inside the modal but it didn't work. This observe() worked well when matrix2 was rendered in the UI section without modalDialog(). But I want matrix2 inside a modalDialog.Is there a way to place the observe() inside that modalDialog()? Or is there another way to run this observe() feature?

library(dplyr)
library(ggplot2)
library(shiny)
library(shinyMatrix)

interpol <- function(a, b) { # a = periods, b = matrix inputs
  c <- rep(NA, a)
  c[1] <- b[1]
  c[a] <- b[2]
  c <- approx(seq_along(c)[!is.na(c)], c[!is.na(c)], seq_along(c))$y # << interpolates
  return(c)
}

ui <- fluidPage(
  
  sidebarLayout(
    sidebarPanel(
      sliderInput('periods', 'Modeled periods (X variable):', min=1, max=10, value=10),
      matrixInput("matrix1", 
                  label = "Matrix 1",
                  value = matrix(c(5), ncol = 1, dimnames = list("Base rate",NULL)),
                  cols =  list(names = FALSE),
                  class = "numeric"),
      
      actionButton("matrix2show","Add scenarios (via Matrix 2)",width = "100%")
    ),
    mainPanel(
      plotOutput("plot")
    )  
  )    
)

server <- function(input, output, session){
  
  # observe({ 
  #   input$periods
  #   tmpMat2 <- input$matrix2
  #   tmpMat2[,c(TRUE, FALSE)] <- apply(tmpMat2[,c(TRUE, FALSE),drop=FALSE], 2,
  #                                     function(x) pmin(x, input$periods))
  #   updateMatrixInput(session,
  #                     inputId="matrix2",
  #                     value=tmpMat2
  #   )
  # })
  
  observeEvent(input$matrix1, {
    tmpMat2 <- c(input$matrix2[,1],input$matrix2[,2]) # convert to vector
    tmpMat2[length(input$matrix2)/2 1] <- input$matrix1[,1] # drop matrix 1 value into row 1/col 2 of matrix 2
    updateMatrixInput(session,
                      inputId="matrix2",
                      value=matrix(tmpMat2,ncol=2,dimnames=list(NULL,c("X","Y")))
    )
  })
  
  observeEvent(input$matrix2show,{
    showModal(
      modalDialog(
          matrixInput("matrix2",
                      label = "Matrix 2 (will link to Matrix 1)",
                      value = if(is.null(input$matrix2)){
                                 matrix(c(10,5), ncol = 2, dimnames = list(NULL,c("X","Y")))}
                              else {input$matrix2},
                      rows = list(extend = TRUE, delete = TRUE),
                      class = "numeric"),
          footer = modalButton("Close")
      ))
  })
  
  plotData <- reactive({
    tryCatch(
      tibble(
        X = seq_len(input$periods),
        Y = if(isTruthy(input$matrix2)){interpol(input$periods,input$matrix2)}
            else {input$matrix1}
      ),
      error = function(e) NULL
    )
  })
  
  output$plot <- renderPlot({
    req(plotData())
    plotData() %>% ggplot()   
      geom_line(aes(x = X, y = Y))  
      theme(legend.title=element_blank())
  })
}

shinyApp(ui, server)

CodePudding user response：

You need to make sure that input$matrix2 is not NULL. This can be done e.g. using req:

library(dplyr)
library(ggplot2)
library(shiny)
library(shinyMatrix)

interpol <- function(a, b) { # a = periods, b = matrix inputs
  c <- rep(NA, a)
  c[1] <- b[1]
  c[a] <- b[2]
  c <- approx(seq_along(c)[!is.na(c)], c[!is.na(c)], seq_along(c))$y # << interpolates
  return(c)
}

ui <- fluidPage(
  
  sidebarLayout(
    sidebarPanel(
      sliderInput('periods', 'Modeled periods (X variable):', min=1, max=10, value=10),
      matrixInput("matrix1", 
                  label = "Matrix 1",
                  value = matrix(c(5), ncol = 1, dimnames = list("Base rate",NULL)),
                  cols =  list(names = FALSE),
                  class = "numeric"),
      
      actionButton("matrix2show","Add scenarios (via Matrix 2)",width = "100%")
    ),
    mainPanel(
      plotOutput("plot")
    )  
  )    
)

server <- function(input, output, session){
  
  observeEvent(c(input$matrix2show, input$matrix2), {
    tmpMat2 <- req(input$matrix2)
    tmpMat2[,c(TRUE, FALSE)] <- apply(tmpMat2[,c(TRUE, FALSE), drop=FALSE], 2,
                                      function(x) pmin(x, input$periods))
    updateMatrixInput(session,
                      inputId="matrix2",
                      value=tmpMat2
    )
  })
  
  observeEvent(input$matrix1, {
    tmpMat2 <- c(input$matrix2[,1],input$matrix2[,2]) # convert to vector
    tmpMat2[length(input$matrix2)/2 1] <- input$matrix1[,1] # drop matrix 1 value into row 1/col 2 of matrix 2
    updateMatrixInput(session,
                      inputId="matrix2",
                      value=matrix(tmpMat2,ncol=2,dimnames=list(NULL,c("X","Y")))
    )
  })
  
  observeEvent(input$matrix2show,{
    showModal(
      modalDialog(
        matrixInput("matrix2",
                    label = "Matrix 2 (will link to Matrix 1)",
                    value = if(is.null(input$matrix2)){
                      matrix(c(10,5), ncol = 2, dimnames = list(NULL,c("X","Y")))}
                    else {input$matrix2},
                    rows = list(extend = TRUE, delete = TRUE),
                    class = "numeric"),
        footer = modalButton("Close")
      ))
  })
  
  plotData <- reactive({
    tryCatch(
      tibble(
        X = seq_len(input$periods),
        Y = if(isTruthy(input$matrix2)){interpol(input$periods,input$matrix2)}
        else {input$matrix1}
      ),
      error = function(e) NULL
    )
  })
  
  output$plot <- renderPlot({
    req(plotData())
    plotData() %>% ggplot()   
      geom_line(aes(x = X, y = Y))  
      theme(legend.title=element_blank())
  })
}

shinyApp(ui, server)