How can you have one Reactive input in R shiny override and overwrite another Reactive input?

Viewed 267

My help request is sort of hard to describe so I employ images at the bottom to better explain.

As currently drafted, the user optionally inputs into a slider and 2 matrices. Works fine! However, if the user changes the slider value OR the single value in matrix 1, I would like the first row of matrix 2 to reactively show the revised value of the slider (in column 1 of matrix 2) and/or the revised value of matrix 1 (in column 2 of matrix 2). It's easier if you quickly review the images at the bottom.

No other rows in matrix 2 would ever be affected by changes in slider or matrix 1. Only this first row is impacted.

Any user changes to matrix 2 do not need to be reflected in matrix 1. For purposes of all subsequent calculations in the full App, matrix 2 governs.

How would this be done? By reactively changing the values in function m2 and "refreshing" the matrix2.input function?

The first matrix is governed by the functions m1 (for initial matrix values) and matrix1.input. The second matrix is governed by functions m2 and matrix2.input.

The second matrix extends. If you want to fiddle with it, click and input into the right-most column before clicking on the left-most column. This is due to a minor bug in shinyMatrix that I have a fix for but haven't yet implemented.

Here´s the almost-MWE code. I wouldn't worry about the matrix.validate, vector, and vector.final functions (I could have taken them out for MWE). The observeEvent functions at the bottom are for my testing and could have been removed. And the commented-out row, yield_vector_input <- reactive(input$yield_base_input), is one of my pitiful attempts to "crack this nut".

library(shiny); library(shinyMatrix)

# --- Sets up initial values for base performance input matrix
m1 <- function(x) {matrix(c(0.2), 1, 1, dimnames = list(c("Yield"),NULL))}

# --- Sets up initial values for performance vectors input matrix
m2 <- function(x) {matrix(c(60,0.2), 1, 2, dimnames = list(NULL, c("Y (period)", "Z (variable)")))}

# --- Matrix input function to use for base performance
matrix1.input <- function(x) {
  matrixInput(
    x,
    label = "Base performance:",
    value = {m1()},
    rows = list(extend = FALSE,  names = TRUE),
    cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
    class = "numeric")}

# --- Matrix input function to use for performance vector inputs
matrix2.input <- function(x) {
  matrixInput(
    x,
    label = "Generate yield performance vector:",
    value = {m2()},
    rows = list(extend = TRUE,  names = FALSE),
    cols = list(extend = FALSE, names = TRUE, editableNames = FALSE),
    class = "numeric")}

# --- Auto-correct user inputs into column Y of the input matrix
matrix.validate <- function(x,y){
  a <- x                                
  a[,1][a[,1]>y] <- y                   
  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]           
  return(a)}

# --- Vector function interpolates & spreads input across even time horizon
vector <- function(X,Y,Z){                                            
  a <- rep(NA, X)                                                     
  a[Y] <- Z                                                           
  a[seq_len(min(Y)-1)] <- a[min(Y)]                                   
  if(max(Y) < X){a[seq(max(Y)+1, X, 1)] <- 0}                         
  a <- approx(seq_along(a)[!is.na(a)],a[!is.na(a)], seq_along(a))$y   
  b <- seq(1:X)                                                       
  c <- data.frame(X = b, Z = a)                                       
  return(c)}

# --- Runs vector through matrix.validate to output clean vector data
vector.final <- function(x,y){vector(x,matrix.validate(y,x)[,1],matrix.validate(y,x)[,2])}

# --- UI and Server sections
ui <- fluidPage(style = "margin-top:10px;margin-left:10px;margin-right:10px",
    column(3, 
        fluidRow(
             sliderInput("periods", "Nbr of periods to model:",min = 1, max = 120, value = 60)),
      
        # --- Action button and matrix input for yield
        fluidRow(style="margin-left:5px;margin-right:5px;margin-top:5px",  
            matrix1.input("base_input"), 
            matrix2.input("yield_vector_input")),
      ), # close column
      column(9,style = "text-align:center",plotOutput("graph1"),
    ) # close column
  )  # fluid page

server <- function(input, output) {
  
  # --- Set reactive input variables
  periods             <-  reactive(input$periods)
  yield_base_input    <-  reactive(input$yield_base_input)
  yield_vector_input  <-  reactive(input$yield_vector_input)
# yield_vector_input  <-  reactive(input$yield_base_input)

  # --- Yield plot
  output$graph1 <- renderPlot({
    plot({vector.final(periods(),yield_vector_input())},
      type="b",main='Gross yield vector',xlab='X (time horizon)',ylab = 'Z (yield in period X)')})
  
  # --- Captures inputs and outputs as global variables
  observeEvent(periods(), {periods.R <<- unique(periods())})
  observeEvent(yield_vector_input(), {yield_input.R <<- unique(yield_vector_input())})
  observeEvent(matrix.validate(yield_vector_input(),periods()), {yield_validate.R <<- unique(matrix.validate(yield_vector_input(),periods()))})
  observeEvent(vector.final(periods(),yield_vector_input()),{yield_vector.R <<- unique(vector.final(periods(),yield_vector_input()))})
    
} # closes server

shinyApp(ui = ui, server = server)

Here are notated images to help explain:

  1. First image shows the default screen that appears when running the above code.
  2. Second image shows what I am trying to achieve in the 1st row, 1st column of matrix 2 when changing the slider input at the top.
  3. Third image shows what I am trying to achieve in the 1st row, 2nd column of matrix 2 when changing the single value in matrix 1.

This is what appears when you run the above code

In this image the slider input is changed

In this image the value in matrix1 is changed

1 Answers

OK lesson learned, no one attempted to answer the above probably because it's "a bit much". So I broke it down into a smaller example and asked at How to embed a Reactive Value in a matrix in the UI section of R Shiny?. Since that was shorter and better explained, I got a quick nice solution from Limey.

The trick is to add "session" to the Server function server <- function(input,output,session){ and to add the following Observe Events with updateMatrixInput functions in the Server section:

observeEvent(input$periods,{
    updateMatrixInput(session, "vector1_input", 
                      value=matrix(c(input$periods, 0.2), 1, 2, 
                                   dimnames = list(NULL, c("Y", "Z")))
    ) # close update matrix
  }) # close observe event

  observeEvent(input$periods|input$vector1_input,{
    updateMatrixInput(session, "vector2_input", 
                      value=matrix(c(input$periods,input$vector1_input[,2]), 1, 2, 
                                   dimnames = list(NULL, c("Y", "Z")))
    ) # close update matrix
  }) # close observe event

Both matrices first columns Y/first rows are updated by any changes in the slider input for periods, and the second matrix Z column (1st row) changes to reflect any changes in first matrix Z column (1st row). And any of the matrix cells can be overriden by user manual input. Exactly what I needed.

In any case, should anyone get backed into the same corner I was in, below is the resolved MWE code that incorporates this solution:

library(shiny) 
library(shinyMatrix)

matrix.input <- function(x) {
  matrixInput(
    x,
    value = matrix(c(1,0.2),1,2,dimnames=list(NULL, c("Y", "Z"))),
    rows = list(extend = TRUE,  names = FALSE),
    cols = list(extend = FALSE, names = TRUE, editableNames = FALSE),
    class = "numeric")}


ui <- fluidPage(style = "margin-top:10px;",
                column(3, 
                       fluidRow(sliderInput("periods", "Nbr of periods (X):",min = 1, max = 120, value = 60)),
                       fluidRow(matrix.input("vector1_input")),
                       fluidRow(matrix.input("vector2_input"))
                ),
                column(9,))

server <- function(input,output,session){
  
  observeEvent(input$periods,{
    updateMatrixInput(session, "vector1_input", 
                      value=matrix(c(input$periods, 0.2), 1, 2, 
                                   dimnames = list(NULL, c("Y", "Z")))
    ) # close update matrix
  }) # close observe event

  observeEvent(input$periods|input$vector1_input,{
    updateMatrixInput(session, "vector2_input", 
                      value=matrix(c(input$periods,input$vector1_input[,2]), 1, 2, 
                                   dimnames = list(NULL, c("Y", "Z")))
    ) # close update matrix
  }) # close observe event

  periods       <- reactive(input$periods)
  vector1_input <- reactive(input$vector1_input)
  vector2_input <- reactive(input$vector2_input)
  
  observeEvent(periods(), {periods.R <<- unique(periods())})
  observeEvent(vector1_input(), {vector1_input.R <<- unique(vector1_input())})
  observeEvent(vector2_input(), {vector2_input.R <<- unique(vector2_input())})
  
} # close server

shinyApp(ui = ui, server = server)
Related