Блог

Следующий код почти MWE работает нормально, за исключением того, что таблица, показанная на первом изображении ниже, по умолчанию отображается на главной панели при нажатии на вкладку «Модуль обязательств». Вместо этого я хотел бы, чтобы таблица, показанная на втором изображении ниже, в результате чего, когда пользователь нажимает кнопку «Обязательства» в верхней части главной панели на той же вкладке «Модуль обязательств», по умолчанию отображалась на главной панели при первом вызове приложения (и переходе в «Модуль обязательств»).

Мои вопросы таковы:

1. Что в приведенном ниже коде в настоящее время задает представление по умолчанию (таблицы ставок table4 ) в этом модуле обязательств?
2. Как изменить приведенный ниже код, чтобы таблица структуры обязательств ( table3 ) отображалась по умолчанию при открытии вкладки «Модуль обязательств»?

Примечание по быстрому использованию: при нажатии на кнопки действий «Изменить…» на боковой панели модуля «Обязательства» появляются модальные диалоговые окна для ввода данных пользователем в table3 и table4 . Эти входные данные реактивно (мгновенно) отражаются на table3 table4 выходах и.

Код почти-MWE:

 library(shiny);library(shinyMatrix);library(shinyjs);library(shinyWidgets)

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'
  ) # close matrix input
} # close function

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")}

pct <- function(x){paste(format(round(x*100,digits=1),nsmall=1),"%",sep="")} # convert to percentage

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",col="blue",pch=19,cex=1.25)}

ui <- 
  pageWithSidebar(
    headerPanel("Model..."),
    sidebarPanel(
      fluidRow(helpText(h5(strong("Base Input Panel")),align="center",
                        style="margin-top:-15px;margin-bottom:5px")),
      uiOutput("Panels") 
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("By balances", value=2),
        tabPanel("By accounts", value=3), 
        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'),
                 ), # close fluid row
                 div(style = "margin-top: 5px"),
                 uiOutput('showResults')), 
        id = "tabselected"
      ) # close tabset panel
    ) # close main panel
  ) # close page with sidebar

server <- function(input,output,session)({
  
  rates_input <- reactive(input$rates_input)
  showResults <- reactiveValues()
  baseRate    <- function(){vectorBaseRate(60,input$rates_input[1,1])} # Must remain in server section
  rv          <- reactiveValues( 
                  mat3=matrix3Input('matrix3',matrix3Default),
                  input=matrix3Default,
                  colHeader = colnames(input)
                ) # close reactive values
  
  output$Panels <- renderUI({
    tagList( 
      conditionalPanel(
        condition="input.tabselected==4",
        actionButton('modLiabStruct','Modify Liabilities Structure',
                     style='width:100%;background-color:LightGrey'
        ),
        div(style = "margin-bottom: 10px"),
        actionButton('modRates','Modify Rates and Coupons',
                     style='width:100%;background-color:LightGrey'
        ),
        div(style = "margin-bottom: 10px"),
        setShadow(id='modLiabStruct'),
        setShadow(id='modRates')
      ), # close conditional panel
      conditionalPanel(condition="input.tabselected==3"),
      conditionalPanel(condition="input.tabselected==4")
    ) # close tagList
  }) # close renderUI
  
  vectorRates <- reactive({
    if (is.null(input$modRates)){df <- NULL}
    else {
      if(input$modRates < 1){df <- cbind(Period = 1:60,BaseRate = pct(0.2))}
      else {
        req(input$rates_input)
        df <- cbind(Period = 1:60,BaseRate = pct(baseRate()[,2]))
      } # close 2nd else
    } # close 1st else
    df
  }) # close reactive
  
  output$table4 <- renderTable({vectorRates()})
  
  vectorLiabStruct <- reactive({
    if(!isTruthy(input$modLiabStruct)){ # << Generates default table when first invoking the App
      df <- matrix3Default
      df
      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({vectorLiabStruct()})
  
  output$table3 <- renderTable({
    if(!isTruthy(input$modLiabStruct)){ # << Generates default table when first invoking the App
      df <- matrix3Default
      df
      n <- dim(df)[2]
      colnames(df) <- paste("Series", 1:n)
      rownames(df) <- matrix3Headers()
    }
    else{ 
      req(input$matrix3) 
      rv$mat3 <- matrix3Input('matrix3',input$matrix3) # << Any live modifications to the matrix in the modal box are reflected in table3 thanks to the reactivity, and stored in the rv$mat3 reactiveValues() (with the rv$mat3 <- matrix3Input('matrix3',input$matrix3) line)
      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
  
  observeEvent(input$modLiabStruct,{ 
    showModal(modalDialog( 
      rv$mat3
    )) # close shown modal and modal dialog
  }) # close observe event
  
  observeEvent(input$showLiabStructBtn,
               {showResults$showme <- tagList(tableOutput("table3"))},ignoreNULL = FALSE)  
  
  observeEvent(input$showRatesValueBtn,
               {showResults$showme <- tagList(tableOutput("table4"))},ignoreNULL = FALSE)
  
  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("rates_input",if(is.null(input$rates_input)) matrix4Default else input$rates_input),
                 div(style = "margin-top: 0px"),
                 useShinyjs(),
               ))}
  ) # close observeEvent
  
}) # close server

shinyApp(ui, server)
 

Должно сработать следующее.

   observeEvent(input$showLiabStructBtn,
               {showResults$showme <- tagList(tableOutput("table3"))},ignoreNULL = FALSE)  
  
  observeEvent(input$showRatesValueBtn,
               {showResults$showme <- tagList(tableOutput("table4"))},ignoreNULL = TRUE)