【发布时间】：2021-09-03 15:28:02
【问题描述】：
在下面的 MWE 代码中，运行时，如果用户 (1) 当前正在查看主面板中的费率值表（在单击主面板顶部的“费率值”操作按钮之后），那么 (2 ) 点击侧边栏面板中的“修改负债结构”操作按钮并在随后的模态对话框中更改负债结构输入网格，然后 (3) 关闭模态对话框，然后 (4) 用户留在主面板中的费率值表。
类似地，如果用户 (1) 当前正在主面板中查看负债结构表，则 (2) 单击侧边栏面板中的“修改利率和优惠券”操作按钮并更改 A 行在随后的模态对话中矩阵输入网格（唯一的操作行），然后（3）关闭模态对话，然后（4）用户留在主面板的负债结构表中。
我希望在单击“修改负债结构”后对输入网格进行任何更改，以使负债表 (“table3”) 呈现在主面板中，而不管主面板中之前的内容。同样，我希望在单击“修改费率和优惠券”后对输入网格进行任何更改，以使费率表（“table4”）在主面板中呈现，无论主面板中以前是什么。
本质上，在模式对话框中对输入网格进行更改后，我需要为主面板表渲染触发某种“转到”功能。我不知道该怎么做。在下面的 MWE 中，我尝试执行此类“转到”的失败尝试标记为“# ATTEMPT >”
MWE 代码：
library(shiny);library(shinyMatrix);library(shinyjs)
colnames(matrix3Default) <- paste0("Series ",1:ncol(matrix3Default))
matrix3Default <- matrix(c(1,24,0,100),4,1,dimnames=list(matrix3Headers(), NULL))
matrix3Headers <- function(){c('A','B','C','D')}
matrix3Input <- function(x, matrix3Default){
matrixInput(x,label = 'Input series terms into below grid:',
value = matrix3Default,
rows = list(extend=FALSE,names=TRUE),
cols = list(extend=TRUE,names=TRUE,editableNames=FALSE,delete=TRUE),
class = 'numeric')}
matrix4Default <- matrix(c(0.2), 4, 1,dimnames=list(c("A","B","C","D"),NULL))
matrix4Input <- function(x,matrix4Input){
matrixInput(x,value = matrix4Input,
rows = list(extend=FALSE,names=TRUE),
cols = list(extend=FALSE,names=FALSE,editableNames=FALSE),
class = "numeric")}
vectorBaseRate <- function(x,y){
a <- rep(y,x)
b <- seq(1:x)
c <- data.frame(x = b, y = a)
return(c)}
vectorBaseRatePlot <- function(w,x,y,z){plot(w[,1],sapply(w[,2], function(x)gsub("%","",x)),
main=x,xlab=y,ylab=z,type="b")}
ui <-
pageWithSidebar(
headerPanel("Model..."),
sidebarPanel(fluidRow(helpText(h5(strong("Base Input Panel")),align="center")),uiOutput("Panels")),
mainPanel(
tabsetPanel(
tabPanel("Liabilities module", value=4,
fluidRow(h5(strong(helpText("Select model output to view:")))),
fluidRow(
actionButton('showLiabStructBtn','Liabilities'),
actionButton('showRatesValueBtn','Rates values'),
actionButton('showRatesPlotBtn','Rates plots')),
uiOutput('showResults')),
id = "tabselected")))
server <- function(input,output,session)({
showResults <- reactiveValues()
rv <- reactiveValues( # Used for matrix 3 (liability structure) inputs
mat3 = matrix3Input('matrix3',matrix3Default),
input = matrix3Default,
colHeader = colnames(input))
matrix4 <- reactive(input$matrix4)
baseRate <- function(){vectorBaseRate(60,input$matrix4[1,1])}
output$Panels <- renderUI({
tagList(
conditionalPanel(condition="input.tabselected==4",
actionButton('modLiabStruct','Modify Liabilities Structure'),
actionButton('modRates','Modify Rates and Coupons'))
) # close tagList
}) # close renderUI
vectorLiabStruct <- reactive({
if(!isTruthy(input$modLiabStruct)){ # << Generates default table when first invoking the App
df <- matrix3Default
n <- dim(df)[2]
colnames(df) <- paste("Series", 1:n)
rownames(df) <- matrix3Headers()
}
else{ #
req(input$matrix3)
rv$mat3 <- matrix3Input('matrix3',input$matrix3)
df <- input$matrix3
n <- dim(df)[2]
colnames(df) <- paste("Series", 1:n)
rownames(df) <- matrix3Headers()
rv$input <- df
} # close else
df
})
output$table3 <- renderTable({
if(!isTruthy(input$modLiabStruct)){
df <- matrix3Default
n <- dim(df)[2]
colnames(df) <- paste("Series", 1:n)
rownames(df) <- matrix3Headers()
}
else{
req(input$matrix3)
rv$mat3 <- matrix3Input('matrix3',input$matrix3)
df <- input$matrix3
n <- dim(df)[2]
colnames(df) <- paste("Series", 1:n)
rownames(df) <- matrix3Headers()
rv$input <- df
} # close else
df
},rownames=TRUE, colnames=TRUE) # close output$table3
vectorRates <- reactive({
if (is.null(input$modRates)){df <- NULL}
else {if(input$modRates < 1){df <- cbind(Period = 1:60,BaseRate = 0.2)}
else {
req(input$matrix4)
df <- cbind(Period = 1:60,BaseRate = baseRate()[,2])
} # close 2nd else
} # close 1st else
df
}) # close reactive
output$table4 <- renderTable({vectorRates()})
observeEvent(input$modLiabStruct,{
showModal(modalDialog(
rv$mat3,
footer = tagList(
actionButton("resetLiabStruct","Reset"),
modalButton("Close")
), # close tag list
))} # close show modal and modal dialog
# ATTEMPT > {showResults$showme <- tagList(tableOutput("table3"))}
) # close observe event
observeEvent(input$showLiabStructBtn,
{showResults$showme <- tagList(tableOutput("table3"))},ignoreNULL = FALSE)
observeEvent(input$resetLiabStruct, {updateMatrixInput(session,'matrix3', matrix3Default)})
observeEvent(input$resetRatesStruct, {updateMatrixInput(session,'matrix4', matrix4Default)})
observeEvent(input$showRatesValueBtn,
{showResults$showme <- tagList(tableOutput("table4"))},ignoreNULL = TRUE)
output$graph1 <-renderPlot(vectorBaseRatePlot(vectorRates(),"A Variable","Period","Rate"))
observeEvent(input$showRatesPlotBtn,{showResults$showme <- plotOutput("graph1")})
output$showResults <- renderUI({showResults$showme})
observeEvent(input$modRates,
{showModal(modalDialog(
matrix4Input("matrix4",if(is.null(input$matrix4)) matrix4Default else input$matrix4),
useShinyjs(),
footer = tagList(
actionButton("resetRatesStruct","Reset"),
modalButton("Close")
)))} # close taglist, modalDialog, showModal, and showModal function
# ATTEMPT > {showResults$showme <- tagList(tableOutput("table4"))}
) # close observeEvent
}) # close server
shinyApp(ui, server)
【问题讨论】：
标签： r shiny shiny-reactivity