Search code examples
rshinydimensionstibble

In R, why am I getting incorrect number of dimensions when running this function?

The MWE code below as presented runs as it should. However when I comment out the custom interpol() function that is currently un-commented, and un-comment the longer interpol() function that is commented out, I get an "incorrect number of dimensions" error. When the output of the 2 functions in terms of structure (I think) is so similar. How do I eliminate this error when running the second interpol()?

The second, longer interpol() function shouldn't be interpolating in this cut-back MWE like the first (it does other things when fully deployed including but not limited to interpolation): in the default scenario it should plot a 5 in period 1 and 0's thereafter. If the user inputs 3 and 5, it should plot a 5 for the first 3 periods and 0's after.

When I run the 2 functions in R studio console, I get what's shown in the images below. The first image is for the shorter interpol() (which does interpolate), and the second is for the longer interpol() function (which isn't ready to interpolate in this MWE). So both work as they should in R Studio Console, but the second one crashes the App!

MWE code:

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

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)
}

# interpol <- function(a, b) { # [a] = modeled periods, [b] = matrix inputs
#   c <- b
#   c[,1][c[,1] > a] <- a
#   d <- diff(c[,1, drop = FALSE])
#   d[d <= 0] <- NA
#   d <- c(1,d)
#   c <- cbind(c,d)
#   c <- na.omit(c)
#   c <- c[,-c(3),drop=FALSE]
#   e <- rep(NA, a)
#   e[c[,1]] <- c[,2]
#   e[seq_len(min(c[,1])-1)] <- e[min(c[,1])]
#   if(max(c[,1]) < a){e[seq(max(c[,1]) + 1, a, 1)] <- 0}
#   e <- approx(seq_along(e)[!is.na(e)], e[!is.na(e)], seq_along(e))$y # interpolates
#  return(e)
# }

ui <- fluidPage(
  sliderInput('periods', 'Periods to interpolate:', min=2, max=10, value=10),
  matrixInput(
    "myMatrixInput",
    label = "Values to interpolate:",
    value =  matrix(c(2, 5), 1, 2),
    cols = list(names = FALSE),
    rows = list(names = FALSE),
    class = "numeric"),
  plotOutput("plot")
)

server <- function(input, output, session) {
  
  observeEvent(input$myMatrixInput, {
    tmpMatrix <- input$myMatrixInput
    # isolate( # isolate update to prevent infinite loop
      updateMatrixInput(session, inputId = "myMatrixInput", value = tmpMatrix)
    # )
  })
  
    plotData <- reactive({
    tibble(
      X = seq_len(input$periods),
      Y = interpol(input$periods, input$myMatrixInput[1,1:2])
    )
  })
  
  output$plot <- renderPlot({
    req(plotData())
    plotData() %>% ggplot() + geom_line(aes(
      x = X,
      y = Y
      ))  
    })
}

shinyApp(ui, server)

Shorter interpol() function:

enter image description here

Longer interpol() function:

enter image description here

Solution

  • See below functioning code that resolves. Key fix is adding drop = FALSE to matrix index per rawr comment. Other changes to enhance functionality include adding lapply() "loop" to create dynamic matrix indexing to reflect a matrix that expands/contracts per user inputs, and isolating the updateMatrixInput() function.

    interpol <- function(a, b) {
  
  # [a] = modeled periods, [b] = matrix inputs
  c <- b
  
  # Assign < of modeled periods [a] and max periods per matrix [b] left-col to matrix [c]
  c[,1][c[,1] > a] <- a
  
  # Ensure matrix [b] left-column period inputs are in increasing order
  d <- diff(c[,1, drop = FALSE])
  d[d <= 0] <- NA
  d <- c(1,d)
  c <- cbind(c,d)
  c <- na.omit(c)
  c <- c[,-c(3),drop=FALSE]
  
  ### Interpolate [b] matrix right-col variables###
  e <- rep(NA, a)
  
  # Places each [b] matrix right-col variable in position indicated by its left-col period
  e[c[,1]] <- c[,2]
  
  # If 1st period in [b] matrix left-col > 1, applies its right-col variable to all periods <= [b] matrix 1st period
  e[seq_len(min(c[,1])-1)] <- e[min(c[,1])]
  
  # Applies 0 to all periods after max period in [b] matrix left-col up to period [a]
  if(max(c[,1]) < a){e[seq(max(c[,1]) + 1, a, 1)] <- 0}
  
  # Interpolates
  e <- approx(seq_along(e)[!is.na(e)], e[!is.na(e)], seq_along(e))$y
  ### End interpolation ###
  return(e)
}

ui <- fluidPage(
  sliderInput('periods', 'Modeled periods:', min=1, max=10, value=10),
  matrixInput(
    "myMatrixInput",
    label = "Period (X) to apply variable (Y) are paired under each scenario heading:",
    value =  matrix(c(1, 5), 1, 2, dimnames = list(NULL, rep("Scenario 1", 2))),
    cols = list(extend = TRUE, delta = 2, names = TRUE, delete = TRUE, multiheader = TRUE),
    rows = list(extend = TRUE, delta = 1, names = TRUE, delete = TRUE),
    class = "numeric"),
  plotOutput("plot")
)

server <- function(input, output, session) {
  
  observeEvent(input$myMatrixInput, {
    if(any(colnames(input$myMatrixInput) == "")){
      tmpMatrix <- input$myMatrixInput
      colnames(tmpMatrix) <- paste("Scenario",rep(1:ncol(tmpMatrix),each=2,length.out=ncol(tmpMatrix)))
      isolate(updateMatrixInput(session, inputId = "myMatrixInput", value = tmpMatrix))
      }
    input$myMatrixInput
  })
  
  plotData <- reactive({
    tryCatch(
      lapply(seq_len(ncol(input$myMatrixInput)/2), # column counter to set matrix index as it expands
         function(i){
             tibble(
               Scenario = colnames(input$myMatrixInput)[i*2-1],
               X = seq_len(input$periods),
               Y = interpol(input$periods,input$myMatrixInput[,(i*2-1):(i*2), drop = FALSE])
             )
          }) %>% bind_rows(),
      error = function(e) NULL
    )
  })
  
  output$plot <- renderPlot({
    req(plotData())
    plotData() %>% ggplot() + 
      geom_line(aes(
        x = X,
        y = Y,
        colour = as.factor(Scenario)
      )) +
      theme(legend.title=element_blank())
  })
  
}

shinyApp(ui, server)