In R Shiny, how to use "isTruthy" in observe Event?-CodePudding

When running the below MWE code, the user can optionally input into 1st matrix rendered in the sidebar panel and into the 2nd matrix rendered in modal dialog. The 2nd matrix allows user to add scenarios, as well as to modify the 1st matrix input which by default is copied into the left columns of the 2nd matrix.

Works fine, EXCEPT when the user doesn´t touch matrix 1 and clicks on the action button to invoke matrix 2. In this case matrix 2 should pull up and reflect the default values of matrix 1 (value of 5 for 6 periods). Instead, I get the following error message in R studio console: "Warning: Error in matrixInput: is.matrix(value) is not TRUE". I tried to address this with the following highlighted line from the modal dialog section of MWE:

value = if(isTruthy(input$input2)){input$input2} 
                  else if(isTruthy(input$input1)){input$input1}
                  **else {matrix(c(6,5), 1, 2,**...

but this doesn´t work. I also played around with req(), various isTruthy and is.null iterations, with no luck. What am I doing wrong?

MWE code:

library(shiny)
library(shinyMatrix)

curveFill <- function(x,y){ # Input correction, interpolation, extrapolation
  a <- y
  a[,1][a[,1]>x] <- x
  b <- diff(a[,1,drop=FALSE])
  b[b<=0] <- NA              
  b <- c(1,b)                                                       
  a <- cbind(a,b)
  a <- na.omit(a)
  a <- a[,-c(3),drop=FALSE] 
  c <- rep(NA, x)     
  c[a[,1]] <- a[,2]       
  c[seq_len(min(a[,1])-1)] <- c[min(a[,1])]   
  if(max(a[,1]) < x){c[seq(max(a[,1]) 1, x, 1)] <- 0} 
  c <- approx(seq_along(c)[!is.na(c)],c[!is.na(c)],seq_along(c))$y  
  d <- seq(1:x)                                                   
  e <- data.frame(x=d,y=c)                                        
  return(e)}

ui <- fluidPage(
    sidebarLayout(
      sidebarPanel(uiOutput("panel"),actionButton("show2nd","Add curve scenario")),
      mainPanel(plotOutput("plot1"))
    )
  )

server <- function(input, output, session){
 
  rates <- function(){curveFill(input$periods,req(input$input1))}
  
  output$panel <- renderUI({
    tagList(
      sliderInput('periods','Periods (X):',min=2,max=12,value=6),
      uiOutput("input1"))
  })

  output$input1 <- renderUI({
    matrixInput("input1", 
                label = "Builder-curve scenario 1:",
                value = if(isTruthy(input$input2)){input$input2[,1:2]} else 
                          {matrix(c(input$periods,5), 1, 2, 
                                  dimnames = list(NULL,c("Period (X)","Y")))},
                rows =  list(extend = TRUE, names = FALSE),
                cols =  list(extend = FALSE, 
                             delta = 1,
                             delete = FALSE,
                             names = TRUE, 
                             editableNames = FALSE,
                             multiheader = FALSE),
                class = "numeric")
  })
  
  observeEvent(input$show2nd,{
    showModal(
      modalDialog(
        matrixInput("input2", 
          label = "Add builder-curves (sequentially numbered):",
          value = if(isTruthy(input$input2)){input$input2} 
                  else if(isTruthy(input$input1)){input$input1}
                  else {matrix(c(6,5), 1, 2, 
                       dimnames = list(NULL,c("Period (X)","Y")))},
          rows =  list(extend = TRUE, names = FALSE),
          cols =  list(extend = TRUE, 
                       delta = 2,
                       delete = TRUE,
                       names = TRUE, 
                       editableNames = FALSE,
                       multiheader=TRUE
                       ),
          class = "numeric"),
    footer = modalButton("Close")
    ))
  })

  observe({
    req(input$input2)
    mm <- input$input2
    colnames(mm) <- trunc(1:ncol(mm)/2) 1 
    isolate(updateMatrixInput(session, "input2", mm))
  })
  
  output$plot1 <-renderPlot({
    req(rates())
    plot(rates())
  })
  
}

shinyApp(ui, server)

CodePudding user response：

The problem is that R has the nasty property to silently drop dimensions when subsetting, when one of the dimensions equals to 1:

m <- matrix(1:4, 2, 2)
## works as expected b/c we are returning a 2 x 2 matrix
dim(m[, 1:2]) ## 2 2
## silently transforms to vector, arguably in this case maybe what we want
dim(m[1, 1:2]) ## NULL

## but here things get nasty
m2 <- matrix(1:2, 1, 2)
## here we would like to get a 1 x 2 matrix, instead we get a length 2 vector
dim(m2[, 1:2]) ## NULL

Solution is to use drop = FALSE to avoid dropping the dimensions. From ?`[`

drop: For matrices and arrays. If ‘TRUE’ the result is coerced to the lowest possible dimension (see the examples).

dim(m[1, 1:2, drop = FALSE]) ## 1 2
dim(m2[, 1:2, drop = FALSE]) ## 1 2

Thus, in your code you should use input$input2[, 1:2, drop = FALSE] (and likewise for input$input1) to make sure you always get back a matrix and not a vector.

CodePudding user response：

input$input2[,1:2] is not a matrix if input$input2 has only one row, it is not bidimensional, hence the error message, I guess. Use rbind(input$input2[,1:2]) or as.matrix(input$input2[,1:2]), etc.