Search code examples
rmatrixshinylapplytibble

In R Shiny, how to flip a function around so it reads a matrix from left-right instead of up-down?

The three images below help explain. MWE Code 1 reactively interpolates user input values as shown in the 1st image, but the user input matrix needs to instead expand horizontally to the right in pairings of two values to interpolate rather than the vertical (downward) expansion currently used in MWE Code 1. A horizontally expanding matrix with input pairings of two values is shown in the 2nd image and its code in MWE Code 2 below. MWE Code 2 isn't completely functional like MWE Code 1 but it illustrates the desired horizontally-expanding matrix in value pairings of two.

Note how in MWE Code 2 the two input variables to interpolate are “paired” or grouped under a single column heading labelled “Scenario 1”, “Scenario 2”, etc.. This pairing is necessary. A formula for skipping along a matrix that horizontally expands in groupings of two columns is shown in MWE Code 2, with trunc(1:ncol(mm)/2)+1.

How to modify MWE Code 1 so it expands horizontally like MWE Code 2, rather than vertically as it currently does?

It’s easy enough to change the parameters for the matrixInput function to reorient its expansion and pairings, as done in MWE Code 2; the tricky part is modifying the functions that feed off the matrix especially in the section starting plotData <- reactive({… with its use of lapply..., etc. in MWE Code 1.

MWE Code 1:

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 # this interpolates
  return(c)
}

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


server <- function(input, output, session) {
  
  sanitizedMat <- reactiveVal()
  
  observeEvent(input$myMatrixInput, {
    if(any(rownames(input$myMatrixInput) == "")){
      tmpMatrix <- input$myMatrixInput
      rownames(tmpMatrix) <- paste("Scenario", seq_len(nrow(input$myMatrixInput)))
      updateMatrixInput(session, inputId = "myMatrixInput", value = tmpMatrix)
    }
    sanitizedMat(na.omit(input$myMatrixInput))
  })
  
  plotData <- reactive({
    req(dim(sanitizedMat())[1] >= 1)
    lapply(seq_len(nrow(sanitizedMat())),
           function(i){
             tibble(
               Scenario = rownames(sanitizedMat())[i],
               X = 1:input$periods,
               Y = interpol(input$periods, sanitizedMat()[i, 1:2])
             )
           }) %>% bind_rows()
  })
  
  output$plot <- renderPlot({
    req(nrow(plotData()) > 0)
    plotData() %>% ggplot() + geom_line(aes(
      x = X,
      y = Y,
      colour = as.factor(Scenario)
    ))
  })
}

shinyApp(ui, server)

MWE Code 2 (uses same packages and interpol() function as above):

ui <- fluidPage(
    
    sliderInput('input1','Interpolate over periods (X):',min=2,max=12,value=6),
    matrixInput("input2",
                label = "Input into empty 2nd row cells to add interpolation scenario:",
                value = matrix(c(1, 5), 1, 2, dimnames = list("Begin|end value", c("Scenario 1", ""))),
                rows =  list(names = TRUE),
                cols =  list(names = TRUE,
                             extend = TRUE,
                             delta = 2,
                             delete = TRUE,
                             multiheader=TRUE),
                class = "numeric"),
    actionButton("add","Add scenario"),
    plotOutput("plot")
)

server <- function(input, output, session){
  
  results <- function(){interpol(req(input$input1),req(input$input2))}
  
  numScenarios <- reactiveValues(numS=1)
  
  observeEvent(input$add,{numScenarios$numS <- (numScenarios$numS+1)})
  
  observe({
    req(input$input2)
    mm <- input$input2
    colnames(mm) <- paste("Scenario ", trunc(1:ncol(mm)/2)+1)
    isolate(updateMatrixInput(session, "input2", mm))
  })
  
  output$plot <-renderPlot({
    req(input$input1,input$input2)
    v <- lapply(
      1:numScenarios$numS,
      function(i) tibble(Scenario=i,X=1:input$input1,Y=results())
    ) %>%
      bind_rows()
    v %>% ggplot() + 
      geom_line(aes(x=X, y=Y, colour=as.factor(Scenario)))  +
      geom_point(aes(x=X, y=Y))
  })
  
}

shinyApp(ui, server)

enter image description here

enter image description here

enter image description here

Solution

  • Refer to post on 17 Oct, 2021, which completely addresses the question and improves the below code, removing some bugs when deleting inputs: "How to automatically delete a matrix column in R if there otherwise would be subscript out of bounds error?"

    Apologies for the cumbersome question. The below code provides a solution. Hopefully this will be of some benefit for novices in the community who can see that matrix indices can be made dynamic with the use of formulas. This opens a lot of possibilities. Solution involves:

    1. Re-orienting the matrixInput() specifications as shown below (this is the easy part). Also note the use of multiheader = TRUE and delta = 2 for matrixInput() column specification, so that variables to interpolate are horizontally grouped in pairs of 2 under each scenario heading.
    2. Adjusting the matrix indices where the functions refer to the input matrix, so that matrix index references "dynamically" skip along in steps of 2 columns horizontally. For example in the plotData function below, see matrix indices of [i*2-1] and [1,(i*2-1):(i*2)] for skipping horizontally across the matrix in leaps of 2. This part was a bit tricky for me to figure out but it now works.

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

ui <- fluidPage(
  sliderInput('periods','Periods to interpolate:',min=2,max=10,value=10),
  matrixInput(
    "myMatrixInput",
    label = "Values to interpolate paired under each scenario heading:",
    value =  matrix(c(1, 5), 1, 2, dimnames = list(NULL, c("Scenario 1", "NULL"))),
    cols = list(extend = TRUE,  delta = 2, names = TRUE,  delete = TRUE,  multiheader = TRUE),
    rows = list(extend = FALSE, delta = 1, names = FALSE, delete = FALSE),
    class = "numeric"),
  plotOutput("plot")
)

server <- function(input, output, session) {
  
  sanitizedMat <- reactiveVal()
  
  observeEvent(input$myMatrixInput, {
    if(any(colnames(input$myMatrixInput) == "")){
      tmpMatrix <- input$myMatrixInput
      colnames(tmpMatrix) <- paste("Scenario", trunc(1:ncol(input$myMatrixInput)/2+1))
      updateMatrixInput(session, inputId = "myMatrixInput", value = tmpMatrix)
    }
    sanitizedMat(na.omit(input$myMatrixInput))
  })
  
  plotData <- reactive({
    lapply(seq_len(ncol(sanitizedMat())/2),
           function(i){
             tibble(
               Scenario = colnames(sanitizedMat())[i*2-1],
               X = 1:input$periods,
               Y = interpol(input$periods, sanitizedMat()[1,(i*2-1):(i*2)])
             )
           }) %>% bind_rows()
  })
  
  output$plot <- renderPlot({
    plotData() %>% ggplot() + geom_line(aes(
      x = X,
      y = Y,
      colour = as.factor(Scenario)
    ))
  })

}

shinyApp(ui, server)