The following almost-MWE code links user inputs into three objects using observeEvent. The image at the bottom also shows and explains these three objects:
First object is a slider input for number of modeled periods, called variable X.
Second object is a 1x1 matrix where the user inputs a single variable Y.
Third object is a vertically expandable matrix where the user inputs a series of values X|Y.
The calculation underlying the plot is a simple sum product, used as a placeholder simplification for this MWE.
User input linkages are shown in the image at the bottom.
How would I replace the two observeEvents used in MWE below with an observe in each case? If possible. (I believe this will offer a solution to another issue I'm having, based on my research of what the observe function does). I've only used observeEvents in my limited Shiny experience.
MWE code:
library(dplyr)
library(ggplot2)
library(shiny)
library(shinyMatrix)
sumProd <- function(a, b) {
c <- rep(NA, a)
c[] <- sum(b[,1], na.rm = T) %*% sum(b[,2],na.rm = T)
return(c)
}
ui <- fluidPage(
sliderInput('periods', 'Modeled periods (X):', min=1, max=10, value=10),
matrixInput("matrix1",
value = matrix(c(5), nrow = 1, ncol = 1, dimnames = list("Base rate (Y)",NULL)),
cols = list(names = FALSE),
class = "numeric"),
matrixInput("matrix2",
value = matrix(c(10,5), nrow = 1, ncol = 2, dimnames = list(NULL,c("X","Y"))),
rows = list(extend = TRUE, delete = TRUE),
class = "numeric"),
plotOutput("plot")
)
server <- function(input, output, session){
observeEvent(input$periods,{
updateMatrixInput(
session, inputId = "matrix2",
value = matrix(c(input$periods,input$matrix2[1,2]),1,2,dimnames=list(NULL,c("X","Y")))
)
})
observeEvent(input$matrix1, {
tmpMat2 <- c(input$matrix2[,1],input$matrix2[,2])
tmpMat2[length(input$matrix2)/2+1] <- input$matrix1[,1]
updateMatrixInput(session,inputId="matrix2",value=matrix(tmpMat2,ncol=2,dimnames=list(NULL,c("X","Y")))
)
})
plotData <- reactive({
tryCatch(
lapply(seq_len(ncol(input$matrix2)/2), # column counter to set matrix index as it expands
function(i){
tibble(
Scenario = colnames(input$matrix2)[i*2-1],
X = seq_len(input$periods),
Y = sumProd(input$periods,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)
Image showing user input linkages among the 3 objects:
I reviewed the post How to listen for more than one event expression within a Shiny observeEvent, which does a nice job of illustrating the interchangeability, in certain circumstances, of observe and observeEvent. Based on that post, I came up with the following substitutions of observeEvent with observe:
sumProd <- function(a, b) {
c <- rep(NA, a)
c[] <- sum(b[,1], na.rm = T) %*% sum(b[,2],na.rm = T)
return(c)
}
ui <- fluidPage(
sliderInput('periods', 'Modeled periods (X):', min=1, max=10, value=10),
matrixInput("matrix1",
value = matrix(c(5), nrow = 1, ncol = 1, dimnames = list("Base rate (Y)",NULL)),
cols = list(names = FALSE),
class = "numeric"),
matrixInput("matrix2",
value = matrix(c(10,5), nrow = 1, ncol = 2, dimnames = list(NULL,c("X","Y"))),
rows = list(extend = TRUE, delete = TRUE),
class = "numeric"),
plotOutput("plot")
)
server <- function(input, output, session){
observe({
input$periods
if(input$periods!=0){
isolate(
updateMatrixInput(
session, inputId = "matrix2",
value = matrix(c(input$periods,input$matrix2[1,2]),1,2,dimnames=list(NULL,c("X","Y")))
)
)
}
})
observe({
input$matrix1
if(input$matrix1!=0){
tmpMat2 <- c(input$matrix2[,1],input$matrix2[,2])
tmpMat2[length(input$matrix2)/2+1] <- input$matrix1[,1]
isolate(
updateMatrixInput(
session,inputId="matrix2",
value=matrix(tmpMat2,ncol=2,dimnames=list(NULL,c("X","Y")))
)
)
}
})
plotData <- reactive({
tryCatch(
lapply(seq_len(ncol(input$matrix2)/2), # column counter to set matrix index as it expands
function(i){
tibble(
Scenario = colnames(input$matrix2)[i*2-1],
X = seq_len(input$periods),
Y = sumProd(input$periods,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)
Related
I believe I have a fundamental misunderstanding of how the isTruthy() function works.
In the below MWE, inputs into the first matrix are summed and plotted straight-line over 10 periods. However this works ONLY IF the matrix 2 creation function is commented-out like in this MWE. When matrix 2 creation is un-commented (matrix 2 does the same thing as matrix 1: inputs are summed and plotted, but plotted as a separate line), matrix 1 inputs are no longer summed and plotted.
The issue appears to lie in if(isTruthy(input$matrix2)){... under the plotData <- reactive({...} function in the server section. I thought if(isTruthy(...) in this context meant if there are manual inputs into matrix 2, then plot matrix 2, otherwise skip ahead to the else{...} and just plot matrix 1. (Note that in the larger App this code is derived from, matrix 2 is rendered in modal dialog, thus the reason why plotting has been broken up this way).
How would I change this code so that matrix 2 is only plotted if there are manual inputs into matrix 2; otherwise plot matrix 1? In order to solve a larger problem I have, I'd like matrix 1 to plot correctly even when matrix 2 is present.
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",
value = matrix(c(60,5), ncol = 2, dimnames = list(NULL,c("X","Y"))),
rows = list(extend = TRUE, delete = TRUE), class = "numeric"),
# matrixInput("matrix2",
# label = "Matrix 2 (Value Y applied in Period X):",
# 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, {
tmpMat1 <- input$matrix1
if(any(rownames(input$matrix1) == "")){rownames(tmpMat1) <- paste("Row", seq_len(nrow(input$matrix1)))}
updateMatrixInput(session, inputId = "matrix1", value = tmpMat1)
})
plotData <- reactive({
tryCatch(
if(isTruthy(input$matrix2)){
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()
} else
{tibble(Scenario = "Scenario 1", X = seq_len(10),Y = sumMat(input$matrix1))},
error = function(e) NULL)
})
output$plot <- renderPlot({
req(plotData())
plotData() %>% ggplot() + geom_line(aes(x = X, y = Y, colour = as.factor(Scenario)))
})
}
shinyApp(ui, server)
See error explanation in CuriousJorge response to Limey comment (incorrect use of isTruthy(), flawed if/then/else logic in the plotData() function).
Note how matrix 1 inputs "downstream" to matrix 2 as scenario 1.
Below is the resolved code:
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"),
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
})
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)
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)
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)
The following "Resolved code" resolves my original question (original question shown below this "Resolved code"). Basically I parse the upstream matrix values inside the observeEvents and then downstream them to the applicable matrix in the same observeEvent. I ask however: is this non-renderUI method better than the renderUI method shown in "https://stackoverflow.com/questions/69718072/in-r-shiny-how-to-establish-a-reactivity-chain-for-a-series-of-linked-matrix-in"?
Resolved code:
ui <- fluidPage(
sliderInput('periods', 'Modeled periods (X):', min=1, max=10, value=10),
h5(strong("Matrix 1 is omitted for MWE")),
h5(strong("Matrix 2:")),
matrixInput("matrix2",
value = matrix(c(10, 5), 1, 2, dimnames = list(NULL,c("X","Y"))),
rows = list(extend = TRUE, names = TRUE, delete = TRUE),
class = "numeric"),
h5(strong("Matrix 3:")),
matrixInput("matrix3",
value = matrix(c(10,5), ncol = 2, dimnames = list(NULL, rep("Scenario 1", 2))),
rows = list(extend = TRUE, delta = 1, names = TRUE, delete = TRUE),
cols = list(extend = TRUE, delta = 2, names = TRUE, delete = TRUE, multiheader = TRUE),
class = "numeric"),
plotOutput("plot")
)
server <- function(input, output, session){
observeEvent(input$periods, {
updateMatrixInput(session, inputId = "matrix2",
value = matrix(c(input$periods, 5), 1, 2, dimnames = list(NULL,c("X","Y"))))
})
observeEvent(input$matrix2, {
if(any(rownames(input$matrix2) == "")){
tmpMatrix <- input$matrix2
rownames(tmpMatrix) <- paste("Row", seq_len(nrow(input$matrix2)))
isolate(updateMatrixInput(session, inputId = "matrix2", value = tmpMatrix))
isolate(updateMatrixInput(session, inputId = "matrix3",
value = tmpMatrix))
}
input$matrix2
isolate(
updateMatrixInput(
session,
inputId = "matrix3",
value = matrix(
c(input$matrix2[,1],input$matrix2[,2]),
ncol = 2,
dimnames = list(NULL, rep("Scenario 1", 2)))
)
)
})
observeEvent(input$matrix3, {
if(any(colnames(input$matrix3) == "")){
tmpMatrix <- input$matrix3
colnames(tmpMatrix) <- paste("Scenario",rep(1:ncol(tmpMatrix),each=2,length.out=ncol(tmpMatrix)))
isolate(updateMatrixInput(session, inputId = "matrix3", value = tmpMatrix))
}
input$matrix3
})
plotData <- reactive({
req(input$periods)
tryCatch(
lapply(seq_len(ncol(input$matrix3)/2), # column counter to set matrix index as it expands
function(i){
tibble(
Scenario = colnames(input$matrix3)[i*2-1],
X = seq_len(input$periods),
Y = interpol(input$periods,input$matrix3[,(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)
This is a follow-on to my earlier post today "https://stackoverflow.com/questions/69718072/in-r-shiny-how-to-establish-a-reactivity-chain-for-a-series-of-linked-matrix-in". In the code in that post, I used renderUI for the matrices and their links and it works well (as corrected by ismirsehregal). I'm trying to move away from renderUI (for sake of simplicity) and use updateMatrixInput inside observeEvent in order to maintain a reactivity chain without renderUI.
The below without-renderUI code ALMOST works like the renderUI version posted earlier, except I can't get the slider input input$periods to reactively downstream to the matrices, as shown in the image below. Also, I lost the automatic generation of sequential column headers for Matrix 3 in the below code, as shown in the image.
Basically, I don't know how to parse or subset inputs into updateMatrixInput; as the below code is drafted, it takes the entire set of matrix values that is being downstreamed from, thus giving rise to my issue. If I could tell it which matrix rows/columns to take in for updating, then it would work.
Maybe the answer in this case is sticking with renderUI if parsing/subsetting is not possible?
Code:
library(ggplot2)
library(shiny)
library(shinyMatrix)
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', 'Modeled periods (X):', min=1, max=10, value=10),
h5(strong("Matrix 1 is omitted for MWE")),
h5(strong("Matrix 2:")),
matrixInput("matrix2",
value = matrix(c(10, 5), 1, 2, dimnames = list(NULL,c("X","Y"))),
rows = list(extend = TRUE, names = TRUE, delete = TRUE),
class = "numeric"),
h5(strong("Matrix 3:")),
matrixInput("matrix3",
value = matrix(c(10, 5), ncol = 2, dimnames = list(NULL, rep("Scenario 1", 2))),
rows = list(extend = TRUE, delta = 1, names = TRUE, delete = TRUE),
cols = list(extend = TRUE, delta = 2, names = TRUE, delete = TRUE, multiheader = TRUE),
class = "numeric"),
plotOutput("plot")
)
server <- function(input, output, session){
observeEvent(input$matrix2, {
if(any(rownames(input$matrix2) == "")){
tmpMatrix <- input$matrix2
rownames(tmpMatrix) <- paste("Row", seq_len(nrow(input$matrix2)))
isolate(updateMatrixInput(session, inputId = "matrix2", value = tmpMatrix))
isolate(updateMatrixInput(session, inputId = "matrix3", value = tmpMatrix))
}
input$matrix2
isolate(updateMatrixInput(session, inputId = "matrix3", value = input$matrix2))
})
observeEvent(input$matrix3, {
if(any(colnames(input$matrix3) == "")){
tmpMatrix <- input$matrix3
colnames(tmpMatrix) <- paste("Scenario",rep(1:ncol(tmpMatrix),each=2,length.out=ncol(tmpMatrix)))
isolate(updateMatrixInput(session, inputId = "matrix3", value = tmpMatrix))
}
input$matrix3
})
plotData <- reactive({
req(input$periods)
tryCatch(
lapply(seq_len(ncol(input$matrix3)/2), # column counter to set matrix index as it expands
function(i){
tibble(
Scenario = colnames(input$matrix3)[i*2-1],
X = seq_len(input$periods),
Y = interpol(input$periods,input$matrix3[,(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)
The "Resolved code" above posted as an edit to the original question resolves this issue (original question shown below the "Resolved code"). Basically the upstream matrix values are parsed inside an observeEvent and are then downstreamed to the applicable matrix in the same observeEvent. Regarding the question raised: "is this non-renderUI method better than the renderUI method shown in...?" My answer is absolutely yes - removing the renderUI leaves you with much cleaner, easier to follow code. I just had to get more comfortable with embedding matrix parsing code inside an observeEvent. I also understand the code will run quicker without renderUI since objects are only edited and not completely re-rendered as occurs with renderUI.
The below MWE Code 1 works fine, in calculating the sumproduct of 2 columns of numbers, with the sumproduct input matrix expanding horizontally to accommodate additional sumproduct scenarios.
MWE Code 2 below is a modification of MWE Code 1 to make the input matrix vertically expandable too, so the user can add rows of elements to be summed in the sumproduct calculation. When I run MWE Code 2, the code crashes giving me "Error in [: (subscript) logical subscript too long".
Why am I getting this error?
The images below illustrate the issue.
MWE Code 1:
library(shiny)
library(shinyMatrix)
library(dplyr)
library(ggplot2)
sumProd <- function(a, b) { # a = periods, b = matrix inputs
c <- rep(NA, a)
c[] <- sum(b[,1]) %*% sum(b[,2])
return(c)
}
ui <- fluidPage(
sliderInput('periods', 'X-axis periods:', min=1, max=10, value=10),
matrixInput(
"myMatrixInput",
label = "Two columns to sumproduct 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 = FALSE, delta = 1, names = FALSE, delete = FALSE),
class = "numeric"),
plotOutput("plot")
)
server <- function(input, output, session) {
observeEvent(input$myMatrixInput, {
tmpMatrix <- input$myMatrixInput
# Remove any empty matrix columns
empty_columns <- sapply(tmpMatrix, function(x) all(is.na(x) | x == ""))
tmpMatrix <- tmpMatrix[, !empty_columns, drop=FALSE]
# Assign column header names
colnames(tmpMatrix) <- paste("Scenario", rep(1:ncol(tmpMatrix), each = 2, length.out = ncol(tmpMatrix)))
isolate( # isolate update to prevent infinite loop
updateMatrixInput(session, inputId = "myMatrixInput", value = tmpMatrix)
)
})
plotData <- reactive({
tryCatch(
lapply(seq_len(ncol(input$myMatrixInput)/2),
function(i){
tibble(
Scenario = colnames(input$myMatrixInput)[i*2-1],
X = seq_len(input$periods),
Y = sumProd(input$periods,input$myMatrixInput[1,(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)
))
})
}
shinyApp(ui, server)
MWE Code 2:
sumProd <- function(a, b) { # a = periods, b = matrix inputs
c <- rep(NA, a)
c[] <- sum(b[,1]) %*% sum(b[,2])
return(c)
}
ui <- fluidPage(
sliderInput('periods', 'X-axis periods:', min=1, max=10, value=10),
matrixInput(
"myMatrixInput",
label = "Two columns to sumproduct 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 = FALSE, delete = FALSE),
class = "numeric"),
plotOutput("plot")
)
server <- function(input, output, session) {
sanitizedMat <- reactiveVal() # < for vertical matrix expansion
observeEvent(input$myMatrixInput, {
if(any(colnames(input$myMatrixInput) == "")){
tmpMatrix <- input$myMatrixInput
# Remove any empty matrix columns
empty_columns <- sapply(tmpMatrix, function(x) all(is.na(x) | x == ""))
tmpMatrix <- tmpMatrix[, !empty_columns, drop=FALSE]
# Assign column header names
colnames(tmpMatrix) <- paste("Scenario", rep(1:ncol(tmpMatrix), each = 2, length.out = ncol(tmpMatrix)))
isolate( # isolate update to prevent infinite loop
updateMatrixInput(session, inputId = "myMatrixInput", value = tmpMatrix)
)
}
sanitizedMat(na.omit(input$myMatrixInput))
})
plotData <- reactive({
tryCatch(
lapply(seq_len(ncol(sanitizedMat())/2),
function(i){
tibble(
Scenario = colnames(sanitizedMat())[i*2-1],
X = seq_len(input$periods),
Y = sumProd(input$periods,sanitizedMat()[,(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)
))
})
}
shinyApp(ui, server)
Solution was to simply eliminate automated matrix empty column deletion under the single observeEvent() and modify UDF sumProd() to ignore NA's (added na.rm = T to sum() in sumProd()). NA's will arise in the matrix when sub-columns (groupings of 2 columns under each scenario header) are of unequal lengths, so ignoring the NA's resolves the issue. Also removed UDF sanitizedMat() and automated empty column deletion feature in MWE2 to simplify.
Revised code:
library(shiny)
library(shinyMatrix)
library(dplyr)
library(ggplot2)
sumProd <- function(a, b) { # a = periods, b = matrix inputs
c <- rep(NA, a)
c[] <- sum(b[,1], na.rm = T) %*% sum(b[,2],na.rm = T) # Added na.rm = T
return(c)
}
ui <- fluidPage(
sliderInput('periods', 'X-axis periods:', min=1, max=10, value=10),
matrixInput(
"myMatrixInput",
label = "Two columns to sumproduct 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 = FALSE, delete = FALSE),
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 = sumProd(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)
))
})
}
shinyApp(ui, server)
The below "MWE code 1" works as intended. It interpolates the values the user inputs into the matrix (id = input2) over the slider input periods (id = input1). Additional scenarios are generated with the click of the single action button which triggers a modal (for later purposes). For illustrative purposes, each scenario is linearly adjusted by a random variable.
I'm trying to adapt the above where additional user inputs into the matrix (always in column groupings of 2, for the 2 values to interpolate) are automatically added to the results function and plotted, without clicking the action button.
The below "MWE code 2" is my beginning of this implementation, and I end at my current knowledge. (Note the input matrix which expands in groups of 2 columns, and the elimination of the runif() inflator since presumably each added scenario will be different). How can I modify MWE code 2 to accomplish this? I am stuck.
MWE code 1:
library(shiny)
library(tidyverse)
library(ggplot2)
library(shinyMatrix)
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('input1','Periods to interpolate (input1):',min=2,max=10,value=10),
matrixInput("input2",
label = "Values to interpolate (input2):",
value = matrix(c(1,5),1,2,dimnames = list(NULL,c("Value 1","Value 2"))),
rows = list(names = FALSE),
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, {showModal(modalDialog(footer = modalButton("Close")))
numScenarios$numS <- (numScenarios$numS+1)})
output$plot <- renderPlot({
req(input$input1,input$input2)
v <- lapply(1:numScenarios$numS,
function(i) tibble(Scenario=i,X=1:input$input1,Y=runif(1)+results())
) %>% bind_rows()
v %>% ggplot() + geom_line(aes(x=X, y=Y, colour=as.factor(Scenario)))
})
}
shinyApp(ui, server)
MWE code 2:
library(shiny)
library(tidyverse)
library(ggplot2)
library(shinyMatrix)
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('input1','Periods to interpolate (input1):',min=2,max=10,value=10),
matrixInput("input2",
label = "Values to interpolate (input2) where first row lists scenario number:",
value = matrix(c(1,5),1,2,dimnames = list(NULL,c("Value 1","Value 2"))),
cols = list(extend = TRUE, delta = 2, delete = TRUE, names = TRUE,
editableNames = FALSE, multiheader=TRUE),
rows = list(names = FALSE),
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, {showModal(modalDialog(footer = modalButton("Close")))
numScenarios$numS <- (numScenarios$numS+1)})
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)))
})
observe({
req(input$input2)
mm <- input$input2
colnames(mm) <- trunc(1:ncol(mm)/2)+1
isolate(updateMatrixInput(session, "input2", mm))
})
}
shinyApp(ui, server)
See explanatory images below:
Edit: I'd suggest using a row-based matrixInput. This makes your life much easier, as you don't have to reshape the matrix before passing it to your custom function etc.
Please check the following:
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(
titlePanel("myMatrixInput"),
sidebarLayout(
sidebarPanel(
matrixInput(
"myMatrixInput",
label = "Values to interpolate (myMatrixInput) where first row lists scenario number:",
value = matrix(c(10, 1, 5), 1, 3, dimnames = list("Scenario 1", c("Periods", "Value 1", "Value 2"))),
cols = list(
extend = FALSE,
names = TRUE,
editableNames = FALSE
),
rows = list(names = TRUE,
delete = TRUE,
extend = TRUE,
delta = 1),
class = "numeric"
),
actionButton("add", "Add scenario")
),
mainPanel(
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 = seq_len(sanitizedMat()[i, 1]),
Y = interpol(sanitizedMat()[i, 1], sanitizedMat()[i, 2:3])
)
}) %>% 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)
Initial Answer
There is no need to calulate the numScenarios as they are defined by the dimensions of your matrix. The same applies to the modal you'll add later - just monitor the dimensions of the data to change the plot - no matter which input changes the reactive dataset.
As a general advice I'd recommend working with data.frames in long format instead of a matrix to prepare plots (using e.g. ggplot or plotly). See my answer here for an example.
Please check the following:
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(
'mySliderInput',
'Periods to interpolate (mySliderInput):',
min = 2,
max = 10,
value = 10
),
matrixInput(
"myMatrixInput",
label = "Values to interpolate (myMatrixInput):",
value = matrix(c(1, 5), 1, 2, dimnames = list(NULL, c("Value 1", "Value 2"))),
cols = list(
extend = TRUE,
delta = 2,
delete = TRUE
),
rows = list(names = FALSE),
class = "numeric"
),
actionButton("add", "Add scenario"),
plotOutput("plot")
)
server <- function(input, output, session) {
observeEvent(input$add, {
showModal(modalDialog(footer = modalButton("Close")))
})
plotData <- reactive({
req(dim(input$myMatrixInput)[2] >= 2)
# req(dim(input$myMatrixInput)[2]%%2 == 0)
req(input$mySliderInput)
if(as.logical(dim(input$myMatrixInput)[2]%%2)){
myVector <- head(as.vector(input$myMatrixInput), -1)
} else {
myVector <- as.vector(input$myMatrixInput)
}
myMatrix <- matrix(myVector, ncol = 2)
lapply(seq_len(length(myVector)/2),
function(i){
tibble(
Scenario = i,
X = seq_len(input$mySliderInput),
Y = interpol(req(input$mySliderInput), req(myMatrix[i,]))
)
}) %>% 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)
The above Edit works BEAUTIFULLY. Wow. Now the below simple edit of your edit simply pull the periods to interpolate out of the input matrix and back into a single slider input since in the full model this is meant for, modeled periods have to be the same for all input variables. However your 3 column matrix inputs also help me on another matter so THANK YOU. Also, I removed the "Add scenarios" action button since it is no longer needed with the automatically expanding input matrix. I sure learned a lot with this.
Edit of your edit:
ui <- fluidPage(
titlePanel("myMatrixInput"),
sidebarLayout(
sidebarPanel(
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"
),
),
mainPanel(
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)