In the below MWE code, the user has the option to refine model assumptions/inputs through a series of step-wise matrix inputs (3 in this case). The 1st matrix, presented by default when first invoking the App, is a flat rate Y over X periods. The 2nd matrix, invoked by clicking "Show", allows user to vary Y over periods X (building a "curve"). The 3rd matrix, invoked by clicking "Add scenarios" action button, allows user to add curved scenarios (note that this 3rd matrix doesn't currently expand horizontally for simplicity of MWE).
Matrices are linked in 1 direction: values in 1st matrix feed into 2nd matrix and 2nd matrix feeds into 3rd, with the last matrix taking precedence in all calculations. (Note that any inputs into an expandable matrix may have to go from right to left, due to a minor bug in shinyMatrix package that I have yet to download the patch for).
Matrix 1 id in MWE is flatInput, matrix 2 is curveBaseRate, matrix 3 is curveBaseRateAdd.
Problem I have is if the 2nd matrix is changed (with any added rows), it is not correctly reflected in the 3rd matrix (as shown in the 3rd image at bottom). If the 2nd matrix is not changed but only shown, then the 2nd matrix correctly feeds into the 3rd matrix (as shown in the 2nd image at the bottom). How can this be fixed? I believe there is something wrong with my citation of matrix 2 row/column in my matrix 3 rendered in modal dialog (lines input$curveBaseRate[,1] and input$curveBaseRate[,2], but I don't know what I'm doing wrong.
MWE code:
library(shiny);library(shinyMatrix);library(shinyjs)
f <- function(action,i){as.character(checkboxInput(paste0(action,i),label=NULL))}
actions <- c("show", "reset")
tbl <- t(outer(actions, c(1,2), FUN = Vectorize(f)))
colnames(tbl) <- c("Show", "Reset")
rownames(tbl) <- c("Base", "Spread")
xDflt <- .05 # << default value for x column of input matrix
yDflt <- .01 # << default value for y column of input matrix
flatRate <- function(inputId,x,y){
matrixInput(inputId,
value = matrix(c(x,y), 1, 1, dimnames = list(c("Base rate"),NULL)),
rows = list(extend = FALSE, names = TRUE),
cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
class = "numeric")
}
curveRate <- function(inputId,w,x,y){
matrixInput(inputId,
label = w,
value = matrix(c(x,y),1,2,dimnames=list(NULL,c("Period (X)","Curved (Y)"))),
rows = list(extend = TRUE, names = FALSE),
cols = list(extend = FALSE, names = TRUE, editableNames = FALSE),
class = "numeric")
}
ui <-
fluidPage(
tags$head(
tags$style(HTML(
"td .checkbox {margin-top: 0; margin-bottom: 0;}
td .form-group {margin-bottom: 0;}"
))
),
titlePanel("Model"),
sidebarLayout(
sidebarPanel(uiOutput("Panel")),
mainPanel(tabsetPanel(tabPanel("Rates", value=2),id = "tabselected"))
)
)
server <- function(input,output,session)({
output$Panel <- renderUI({
conditionalPanel(
condition = "input.tabselected == 2",
useShinyjs(),
helpText("Modeled periods (X):"),
sliderInput('periods','',min=2,max=120,value=60),
helpText("Initial rates (Y):"),
flatRate("flatInput",xDflt,yDflt),
helpText("Generate curves (Y|X):"),
tableOutput("checkboxes"),
hidden(uiOutput("curveBaseRate")),
actionButton("addScenarios","Add scenarios")
)
})
### Begin checkbox matrix ###
output[["checkboxes"]] <-
renderTable({tbl},
rownames = TRUE, align = "c",
sanitize.text.function = function(x) x
)
observeEvent(input[["show1"]], {
if(input[["show1"]]){
shinyjs::show("curveBaseRate")
} else {
shinyjs::hide("curveBaseRate")
}
})
### End checkbox matrix ###
output$curveBaseRate <- renderUI({
req(input$periods,input$flatInput)
input[["reset1"]]
curveRate("curveBaseRate",
"Base rates curve (Y|X):",
input$periods,
input$flatInput[1,1])
})
outputOptions(output, "curveBaseRate", suspendWhenHidden = FALSE)
observeEvent(input$addScenarios, {
showModal(
modalDialog(
curveRate("curveBaseRateAdd",
"Base rates curve (Y|X):",
input$curveBaseRate[,1],
input$curveBaseRate[,2]),
footer = modalButton("Close")
))
})
})
shinyApp(ui, server)
Explanatory images:
- First image shows 1st user input matrix.
- Second image shows the 2nd user input matrix (after clicking "Show") rendered and correctly feeding into 3rd user input matrix in modal dialog, with no user changes to 2nd input matrix.
- Third image shows incorrect rendering of 3rd input matrix in modal dialog, after user makes changes to 2nd input matrix.
CodePudding user response：
In your above code you are passing only the first 2 columns of the second matrix:
input$curveBaseRate[,1],
input$curveBaseRate[,2])
To be honest, I'd get rid of all custom functions which aren't at least called twice (otherwise there is no added value - only confusion).
Please check the following:
library(shiny);library(shinyMatrix);library(shinyjs)
f <- function(action,i){as.character(checkboxInput(paste0(action,i),label=NULL))}
actions <- c("show", "reset")
tbl <- t(outer(actions, c(1,2), FUN = Vectorize(f)))
colnames(tbl) <- c("Show", "Reset")
rownames(tbl) <- c("Base", "Spread")
xDflt <- .05 # << default value for x column of input matrix
yDflt <- .01 # << default value for y column of input matrix
flatRate <- function(inputId,x,y){
matrixInput(inputId,
value = matrix(c(x,y), 1, 1, dimnames = list(c("Base rate"),NULL)),
rows = list(extend = FALSE, names = TRUE),
cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
class = "numeric")
}
curveRate <- function(inputId,w,x,y){
matrixInput(inputId,
label = w,
value = matrix(c(x,y),1,2,dimnames=list(NULL,c("Period (X)","Curved (Y)"))),
rows = list(extend = TRUE, names = FALSE),
cols = list(extend = FALSE, names = TRUE, editableNames = FALSE),
class = "numeric")
}
ui <-
fluidPage(
tags$head(
tags$style(HTML(
"td .checkbox {margin-top: 0; margin-bottom: 0;}
td .form-group {margin-bottom: 0;}"
))
),
titlePanel("Model"),
sidebarLayout(
sidebarPanel(uiOutput("Panel")),
mainPanel(tabsetPanel(tabPanel("Rates", value=2),id = "tabselected"))
)
)
server <- function(input,output,session)({
output$Panel <- renderUI({
conditionalPanel(
condition = "input.tabselected == 2",
useShinyjs(),
helpText("Modeled periods (X):"),
sliderInput('periods','',min=2,max=120,value=60),
helpText("Initial rates (Y):"),
flatRate("flatInput",xDflt,yDflt),
helpText("Generate curves (Y|X):"),
tableOutput("checkboxes"),
hidden(uiOutput("curveBaseRate")),
actionButton("addScenarios","Add scenarios")
)
})
### Begin checkbox matrix ###
output[["checkboxes"]] <-
renderTable({tbl},
rownames = TRUE, align = "c",
sanitize.text.function = function(x) x
)
observeEvent(input[["show1"]], {
if(input[["show1"]]){
shinyjs::show("curveBaseRate")
} else {
shinyjs::hide("curveBaseRate")
}
})
### End checkbox matrix ###
output$curveBaseRate <- renderUI({
req(input$periods,input$flatInput)
input[["reset1"]]
curveRate("curveBaseRate",
"Base rates curve (Y|X):",
input$periods,
input$flatInput[1,1])
})
outputOptions(output, "curveBaseRate", suspendWhenHidden = FALSE)
observeEvent(input$addScenarios, {
showModal(
modalDialog(
matrixInput(inputId = "curveBaseRateAdd",
label = "Base rates curve (Y|X):",
value = input$curveBaseRate,
rows = list(extend = TRUE, names = FALSE),
cols = list(extend = FALSE, names = TRUE, editableNames = FALSE),
class = "numeric"),
footer = modalButton("Close")
))
})
})
shinyApp(ui, server)