How to move a linked object into modal dialog? - r

Question

The below code works as intended, bug-free. Matrix 1, including any user input into matrix 1, is linked to ("downstreams to") matrix 2 as "Scenario 1", and the user can add scenarios via matrix 2. Results are plotted. Additional scenarios input into matrix 2 are shown as additional lines in the plot. For sake of illustration, all matrix inputs are simply summed and plotted over 10 periods via the sumMat() function.
Any ideas for how to move matrix 2 into modal dialog? The user would optionally input into matrix 2 after clicking the single actionButton() in the code. Matrix 1 remains in the sidebarPanel(). While maintaining the exact same functionality that the code currently has, whereby the plot reactively updates as the user inputs into either matrix 1 or matrix 2 and where both matrices remain linked?
library(dplyr)
library(ggplot2)
library(shiny)
library(shinyMatrix)
sumMat <- function(x){return(rep(sum(x,na.rm = TRUE), 10))}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
matrixInput("matrix1",
label ="Matrix 1 (scenario 1):",
value = matrix(c(60,5), nrow = 1, ncol = 2, dimnames = list(NULL,c("X","Y"))),
rows = list(extend = TRUE, delete = TRUE),
class = "numeric"),
actionButton(inputId = "showMat2", "Add scenarios"),br(),br(),
matrixInput("matrix2",
label = "Matrix 2:",
value = matrix(c(60,5), ncol = 2, dimnames = list(NULL, rep("Scenario 1", 2))),
rows = list(extend = TRUE, delete = TRUE),
cols = list(extend = TRUE, delta = 2, delete = TRUE, multiheader = TRUE),
class = "numeric")
),
mainPanel(plotOutput("plot"))
)
)
server <- function(input, output, session){
observeEvent(input$matrix1, {
a <- apply(input$matrix2,2,'length<-',max(nrow(input$matrix2),nrow(input$matrix1)))
b <- apply(input$matrix1,2,'length<-',max(nrow(input$matrix2),nrow(input$matrix1)))
c <- if(length(a) == 2){c(b)} else {c(b,a[,-1:-2])}
d <- ncol(input$matrix2)
tmpMat2 <- matrix(c(c), ncol = d)
colnames(tmpMat2) <- paste("Scenario",rep(1:ncol(tmpMat2),each=2,length.out=ncol(tmpMat2)))
if(any(rownames(input$matrix1) == "")){
tmpMat1 <- input$matrix1
rownames(tmpMat1) <- paste("Row", seq_len(nrow(input$matrix1)))
updateMatrixInput(session, inputId = "matrix1", value = tmpMat1)
}
updateMatrixInput(session, inputId = "matrix2", value = tmpMat2)
})
observeEvent(input$matrix2, {
if(any(colnames(input$matrix2) == "")){
tmpMat2 <- input$matrix2
colnames(tmpMat2) <- paste("Scenario",rep(1:ncol(tmpMat2),each=2,length.out=ncol(tmpMat2)))
updateMatrixInput(session, inputId = "matrix2", value = tmpMat2)
}
if(any(rownames(input$matrix2) == "")){
tmpMat2 <- input$matrix2
rownames(tmpMat2) <- paste("Row", seq_len(nrow(input$matrix2)))
updateMatrixInput(session, inputId = "matrix2", value = tmpMat2)
}
input$matrix2
})
observeEvent(input$showMat2,{
showModal(
modalDialog(
h5("Matrix 2 needs to be shown here, with user ability to input into matrix 2"),
h5("User inputs into matrix 1 would automatically downstream to the 2 left-most columns of matrix 2 as Scenario 1"),
footer = tagList(modalButton("Close"))
))
})
plotData <- reactive({
tryCatch(
lapply(seq_len(ncol(input$matrix2)/2),
function(i){
tibble(
Scenario= colnames(input$matrix2)[i*2-1],X=seq_len(10),
Y=sumMat(input$matrix2[,(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)

Answer 1

The below code resolves the question. Matrix 2 is successfully moved into modal dialog. The last matrix modified "controls", as the 2 matrices are linked. In a departure from original code posted where matrix 1 simply "downstreams" to matrix 2, in the below code matrix 1 downstreams to matrix 2 AND matrix 2 (scenario 1) changes "upstream" to matrix 1, with the last matrix modified controlling.
The below also has added to it a table output in the main panel showing the values of reactive matrix currentMat(), which is plotted. Watching what happens in currentMat() was important for debugging and getting this to work correctly.
To see evolution of this solution, also see post In R shiny, how to modify reactivity chain so last object modified controls other chained objects?
library(dplyr)
library(ggplot2)
library(shiny)
library(shinyMatrix)
sumMat <- function(x) {return(rep(sum(x, na.rm = TRUE), 10))}
ui <- fluidPage(sidebarLayout(
sidebarPanel(
matrixInput(
"matrix1",
label = "Matrix 1:",
value = matrix(c(60,5),ncol=2,dimnames=list(NULL,rep("Scenario 1",2))),
rows = list(extend = TRUE, delete = TRUE),
cols = list(multiheader = TRUE),
class = "numeric"
),
actionButton(inputId = "showMat2", "Add scenarios"),br(),br(),
),
mainPanel(plotOutput("plot"),
h5("currentMat() values:"),
tableOutput("table1"))
))
server <- function(input, output, session) {
currentMat <- reactiveVal(isolate(input$matrix1))
observeEvent(input$matrix1, {
tmpMat1 <- input$matrix1
if(any(rownames(input$matrix1)=="")){rownames(tmpMat1)<-paste("Row",seq_len(nrow(input$matrix1)))}
updateMatrixInput(session, inputId = "matrix1", value = tmpMat1)
tmpMat2 <- currentMat()
if(nrow(tmpMat1) > nrow(tmpMat2)){tmpMat2 <- rbind(tmpMat2, rep(NA, ncol(tmpMat2)))}
if(nrow(tmpMat2) > nrow(tmpMat1)){tmpMat1 <- rbind(tmpMat1, rep(NA, ncol(tmpMat1)))}
currentMat(cbind(tmpMat1[drop=FALSE], tmpMat2[,-1:-2,drop=FALSE]))
})
observeEvent(input$showMat2, {
showModal(modalDialog(
matrixInput(
"matrix2",
label = "Matrix 2:",
value = currentMat(),
rows = list(extend = TRUE, delete = TRUE),
cols = list(extend = TRUE,delta = 2,delete = TRUE,multiheader = TRUE),
class = "numeric"
),
footer = tagList(modalButton("Close"))
))
})
observeEvent(input$matrix2, {
tmpMat2 <- input$matrix2
rownames(tmpMat2) <- paste("Row", seq_len(nrow(input$matrix2)))
colnames(tmpMat2) <-
paste("Scenario", rep(1:ncol(tmpMat2),each = 2,length.out = ncol(tmpMat2)))
currentMat(tmpMat2)
updateMatrixInput(session, inputId = "matrix2", value = tmpMat2)
updateMatrixInput(session, inputId = "matrix1", value = tmpMat2[, 1:2, drop = FALSE])
})
output$table1 <- renderTable(currentMat())
plotData <- reactive({
tryCatch(
lapply(seq_len(ncol(currentMat()) / 2),
function(i) {
tibble(
Scenario = colnames(currentMat())[i * 2 - 1],
X = seq_len(10),
Y = sumMat(currentMat()[, (i * 2 - 1):(i * 2), drop = FALSE])
)
}) %>% bind_rows(),
error = function(e)
NULL
)
})
output$plot <- renderPlot({
plotData() %>% ggplot() +
geom_line(aes(
x = X,
y = Y,
colour = as.factor(Scenario)
)) +
theme(legend.title = element_blank())
})
}
shinyApp(ui, server)