rshinyshiny-reactivity
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:
Solution
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)
- r piping image_annotate doesn't work as expected
- reading text portion from list of images and saving in R, using magick
- Difference betweeen Fix and Edit in R
- Conditional coloring in the Flextable in R
- Rename multiple variables at once using dplyr
- Fast NMF in R on sparse matrices
- cannot find -lMagick++-6.Q16
- Suppressing output from ImageMagick when calling function from the R Animation package
- How to identify relevant strings in this emmeans() output
- Why is message() a better choice than print() in R for writing a package?
- How can I prevent my computer from crashing when running R-script on large dataset
- Crop out circle from image and lay over second image
- R: Swap two variables without using a third
- Literal curly brackets in gtsummary
- Hide "Panel" row from rbinded modelsummary tables
- Ignoring NA cases when getting column index of lowest value in row
- Is there a way to change the color of the tab_spanner when creating a gt table?
- Assign groups in dataframe using vectors containing start and end indexes
- Is there a product operator (or work around) in SQLite?
- Loading Magick package after tidyverse
- Make silhouette icons in tmap
- plm object to LaTeX table
- Why is my bslib theme not coloring the navbar as expected?
- Adding a footnote to a single row label in a gtsummary table
- How to order a data frame by one descending and one ascending column?
- dplyr is turning dates to doubles when mutating dataframe
- How to display headers from a quarto with a for loop and plotly graphs?
- mixed date converted from default mm/dd/yy in excel to dd/mm/yy
- Git lfs version https://git-lfs.github.com/spec/v1 oid error
- Generate list of lead values