Why is this simple R Shiny output not plotting with ggplot? - r

In running the below code, I'm not sure why it's not plotting. In other, more involved versions of this code it does plot; I've done line-by-line comparisons and can't see why it doesn't plot in this case. I've played with req(), if(isTruthy()...)) statements, with no luck. I tested the interpol() custom function in the console, and it works fine as shown in the image at the bottom of this post.
library(ggplot2)
library(shiny)
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 # << interpolates
return(c)
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput('periods', 'Modeled periods (X variable):', min=1, max=10, value=10),
matrixInput("matrix1",
label = "Matrix 1:",
value = matrix(c(5), ncol = 1, dimnames = list("Base rate",NULL)),
cols = list(names = FALSE),
class = "numeric"),
matrixInput("matrix2",
label = "Matrix 2 (will link to Matrix 1):",
value = matrix(c(10,5), ncol = 2, dimnames = list(NULL,c("X","Y"))),
rows = list(extend = TRUE, delete = TRUE),
class = "numeric"),
),
mainPanel(
plotOutput("plot")
)
)
)
server <- function(input, output, session){
plotData <- reactive({
req(input$periods,input$matrix2) # << this doesn't help
tryCatch(
tibble(
X = seq_len(input$periods),
Y = interpol(input$periods,input$matrix2, drop = FALSE)
),
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)

library(dplyr) was missing function tibble was unknown
Your function interpol doesn't have a drop argument
Object 'Scenario' not found
library(ggplot2)
library(shiny)
library(shinyMatrix)
library(dplyr)
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(
sidebarLayout(
sidebarPanel(
sliderInput('periods', 'Modeled periods (X variable):', min=1, max=10, value=10),
matrixInput("matrix1",
label = "Matrix 1:",
value = matrix(c(5), ncol = 1, dimnames = list("Base rate",NULL)),
cols = list(names = FALSE),
class = "numeric"),
matrixInput("matrix2",
label = "Matrix 2 (will link to Matrix 1):",
value = matrix(c(10,5), ncol = 2, dimnames = list(NULL,c("X","Y"))),
rows = list(extend = TRUE, delete = TRUE),
class = "numeric"),
),
mainPanel(
plotOutput("plot")
)
)
)
server <- function(input, output, session){
plotData <- reactive({
# browser()
req(input$periods, input$matrix2) # << this doesn't help
tryCatch(
# drop = FALSE
tibble(
X = seq_len(input$periods),
Y = interpol(input$periods,input$matrix2)
),
error = function(e) NULL
)
})
output$plot <- renderPlot({
req(plotData())
# Error in is.factor: object 'Scenario' not found
# , colour = as.factor(Scenario)
plotData() %>% ggplot() +
geom_line(aes(x = X, y = Y)) +
theme(legend.title=element_blank())
})
}
shinyApp(ui, server)

Related

In R Shiny, isTruthy() function is not working the way I think it should

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)

How to run an observe function for an object rendered in modal dialog?

Further note: un-commenting the observe() section and inserting req(input$matrix2) underneath input$periods appears to work, except in circumstances where the user changes input$periods after having input into matrix2 in which case the input$periods limit is ignored.
In the below code, I'm trying to run the commented-out observe() function for matrix2 rendered in modalDialog(). Observe() is supposed to cap the values of the elements in the left column of matrix2 at input$periods. I tried placing this observe() inside the modal but it didn't work. This observe() worked well when matrix2 was rendered in the UI section without modalDialog(). But I want matrix2 inside a modalDialog.Is there a way to place the observe() inside that modalDialog()? Or is there another way to run this observe() feature?
library(dplyr)
library(ggplot2)
library(shiny)
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 # << interpolates
return(c)
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput('periods', 'Modeled periods (X variable):', min=1, max=10, value=10),
matrixInput("matrix1",
label = "Matrix 1",
value = matrix(c(5), ncol = 1, dimnames = list("Base rate",NULL)),
cols = list(names = FALSE),
class = "numeric"),
actionButton("matrix2show","Add scenarios (via Matrix 2)",width = "100%")
),
mainPanel(
plotOutput("plot")
)
)
)
server <- function(input, output, session){
# observe({
# input$periods
# tmpMat2 <- input$matrix2
# tmpMat2[,c(TRUE, FALSE)] <- apply(tmpMat2[,c(TRUE, FALSE),drop=FALSE], 2,
# function(x) pmin(x, input$periods))
# updateMatrixInput(session,
# inputId="matrix2",
# value=tmpMat2
# )
# })
observeEvent(input$matrix1, {
tmpMat2 <- c(input$matrix2[,1],input$matrix2[,2]) # convert to vector
tmpMat2[length(input$matrix2)/2+1] <- input$matrix1[,1] # drop matrix 1 value into row 1/col 2 of matrix 2
updateMatrixInput(session,
inputId="matrix2",
value=matrix(tmpMat2,ncol=2,dimnames=list(NULL,c("X","Y")))
)
})
observeEvent(input$matrix2show,{
showModal(
modalDialog(
matrixInput("matrix2",
label = "Matrix 2 (will link to Matrix 1)",
value = if(is.null(input$matrix2)){
matrix(c(10,5), ncol = 2, dimnames = list(NULL,c("X","Y")))}
else {input$matrix2},
rows = list(extend = TRUE, delete = TRUE),
class = "numeric"),
footer = modalButton("Close")
))
})
plotData <- reactive({
tryCatch(
tibble(
X = seq_len(input$periods),
Y = if(isTruthy(input$matrix2)){interpol(input$periods,input$matrix2)}
else {input$matrix1}
),
error = function(e) NULL
)
})
output$plot <- renderPlot({
req(plotData())
plotData() %>% ggplot() +
geom_line(aes(x = X, y = Y)) +
theme(legend.title=element_blank())
})
}
shinyApp(ui, server)
You need to make sure that input$matrix2 is not NULL. This can be done e.g. using req:
library(dplyr)
library(ggplot2)
library(shiny)
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 # << interpolates
return(c)
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput('periods', 'Modeled periods (X variable):', min=1, max=10, value=10),
matrixInput("matrix1",
label = "Matrix 1",
value = matrix(c(5), ncol = 1, dimnames = list("Base rate",NULL)),
cols = list(names = FALSE),
class = "numeric"),
actionButton("matrix2show","Add scenarios (via Matrix 2)",width = "100%")
),
mainPanel(
plotOutput("plot")
)
)
)
server <- function(input, output, session){
observeEvent(c(input$matrix2show, input$matrix2), {
tmpMat2 <- req(input$matrix2)
tmpMat2[,c(TRUE, FALSE)] <- apply(tmpMat2[,c(TRUE, FALSE), drop=FALSE], 2,
function(x) pmin(x, input$periods))
updateMatrixInput(session,
inputId="matrix2",
value=tmpMat2
)
})
observeEvent(input$matrix1, {
tmpMat2 <- c(input$matrix2[,1],input$matrix2[,2]) # convert to vector
tmpMat2[length(input$matrix2)/2+1] <- input$matrix1[,1] # drop matrix 1 value into row 1/col 2 of matrix 2
updateMatrixInput(session,
inputId="matrix2",
value=matrix(tmpMat2,ncol=2,dimnames=list(NULL,c("X","Y")))
)
})
observeEvent(input$matrix2show,{
showModal(
modalDialog(
matrixInput("matrix2",
label = "Matrix 2 (will link to Matrix 1)",
value = if(is.null(input$matrix2)){
matrix(c(10,5), ncol = 2, dimnames = list(NULL,c("X","Y")))}
else {input$matrix2},
rows = list(extend = TRUE, delete = TRUE),
class = "numeric"),
footer = modalButton("Close")
))
})
plotData <- reactive({
tryCatch(
tibble(
X = seq_len(input$periods),
Y = if(isTruthy(input$matrix2)){interpol(input$periods,input$matrix2)}
else {input$matrix1}
),
error = function(e) NULL
)
})
output$plot <- renderPlot({
req(plotData())
plotData() %>% ggplot() +
geom_line(aes(x = X, y = Y)) +
theme(legend.title=element_blank())
})
}
shinyApp(ui, server)

In R Shiny, how to replace observeEvent with observe?

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)

In R, why am I getting "Error in [: (subscript) logical subscript too long"?

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)

In R Shiny, how to read additional user inputs into a function and plot the results?

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)

Resources