在 R shiny 中，如何在不使用 renderUI 的情况下首次调用应用程序时消除边栏中所有条件面板的闪烁？
In R shiny, how to eliminate flashing of all conditional panels in sidebar when first invoking the App without using renderUI?
这是我 6 月 30 日 post 的跟进，我在调用应用程序时消除了 sidebarPanel 中的 conditionalPanel 闪烁。解决方案是将那些侧边栏条件面板移动到 renderUI，消除闪烁。但是，后来我发现以这种方式使用 renderUI 会导致其他限制。有什么方法可以在不使用 renderUI 的情况下消除调用闪烁？
我包括以下 3 组代码：
- 说明闪烁问题的非常短的 MWE 代码，由 ismirsehregal 提供
- 长而复杂的代码非常清楚地说明了在调用时所有条件面板如何在侧面板中闪烁，当侧边栏条件面板在 UI 中呈现时（没有
renderUI 中的条件面板类似于下面 #3 中的侧边栏面板解决了这个问题，尽管它引入了其他未在此 post) 中解释的问题。
- 上面 #2 的改编，其中使用
renderUI 并且没有调用闪烁。
我不想完全剥离第 2 项和第 3 项中的代码，以便侧边栏面板足够大，从而使调用闪烁更加明显。此外，当我对这段代码进行一些剥离时，我确实失去了一些功能，如“重置”，无论如何这与手头的问题无关。
尽管#2 和#3 中的代码可能冗长复杂，但将条件面板移至 renderUI 中非常简单。
没有。 1 个短 MWE 代码：
library(shiny)
ui <- fluidPage(
radioButtons("yourChoice", "Display button?", choices = c("Yes", "No"), selected = "No",),
conditionalPanel("input.yourChoice == 'Yes'", actionButton("test", "test"))
# not working: ------------------------------------------------------------
# conditionalPanel("typeof input.yourChoice !== 'undefined' && input.yourChoice == 'Yes'", actionButton("test", "test"))
# conditionalPanel("typeof input !== 'undefined' && input.yourChoice == 'Yes'", actionButton("test", "test"))
)
server <- function(input, output, session) {}
shinyApp(ui, server)
没有。 2 没有 renderUI 且边栏调用闪烁的长代码：
library(shiny)
library(shinyMatrix)
library(shinyjs)
library(DT)
matrix1Input <- function(x){
matrixInput(x,
value = matrix(c(0.2), 4, 1, dimnames = list(c("A","B","C","D"),NULL)),
rows = list(extend = FALSE, names = TRUE),
cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
class = "numeric")}
matrix2Input <- function(x,y,z){
matrixInput(x,
value = matrix(c(y,z),1,2,dimnames=list(NULL,c("Y","Z"))),
rows = list(extend = TRUE, names = FALSE),
cols = list(extend = FALSE, names = TRUE, editableNames = FALSE),
class = "numeric")}
matrixLink <- function(x,y){
observeEvent(input$periods|input$base_input,{
updateMatrixInput(session,x,value=matrix(c(input$periods,y),1,2,dimnames=list(NULL, c("y","z"))))
})}
matrixValidate <- function(x,y){
a <- y
a[,1][a[,1]>x] <- x
b <- diff(a[,1,drop=FALSE])
b[b<=0] <- NA
b <- c(1,b)
a <- cbind(a,b)
a <- na.omit(a)
a <- a[,-c(3),drop=FALSE]
return(a)}
vectorBase <- function(x,y){
a <- rep(y,x)
b <- seq(1:x)
c <- data.frame(x = b, y = a)
return(c)}
vectorMulti <- function(x,y,z){
a <- rep(NA, x)
a[y] <- z
a[seq_len(min(y)-1)] <- a[min(y)]
if(max(y) < x){a[seq(max(y)+1, x, 1)] <- 0}
a <- approx(seq_along(a)[!is.na(a)],a[!is.na(a)],seq_along(a))$y
b <- seq(1:x)
c <- data.frame(x=b,z=a)
return(c)}
vectorMultiFinal <- function(x,y){vectorMulti(x,matrixValidate(x,y)[,1],matrixValidate(x,y)[,2])}
vectorPlot <- function(w,x,y,z){plot(w,main=x,xlab=y,ylab=z,type="b",col="blue",pch=19,cex=1.25)}
ui <-
pageWithSidebar(
headerPanel("Model"),
sidebarPanel(
useShinyjs(),
fluidRow(helpText(h4("Base Input Panel"))),
conditionalPanel(condition="input.tabselected==1",h4("Select:")),
conditionalPanel(
condition="input.tabselected==2",
sliderInput('periods','',min=1,max=120,value=60),
matrix1Input("base_input"),
actionButton('showVectorBtn','Show'),
actionButton('hideVectorBtn','Hide'),
actionButton('resetVectorBtn','Reset'),
hidden(uiOutput("Vectors"))
), # close conditional panel
), # close sidebar panel
mainPanel(
useShinyjs(),
tabsetPanel(
tabPanel("About model", value=1, helpText("Model")),
tabPanel("By balances", value=2,
fluidRow(
radioButtons(
inputId = 'mainPanelBtnTab2',
label = h5(helpText("Asset outputs:")),
choices = c('Vector plots','Vector values','Downloads'),
selected = 'Vector plots',
inline = TRUE
) # close radio buttons
), # close fluid row
conditionalPanel(condition="input.mainPanelBtnTab2=='Vector plots'",plotOutput("graph1")),
conditionalPanel(condition="input.mainPanelBtnTab2=='Vector values'",DTOutput("table1")),
), # close tab panel
id = "tabselected"
) # close tabset panel
) # close main panel
) # close page with sidebar
server <- function(input,output,session)({
periods <- reactive(input$periods)
base_input <- reactive(input$base_input)
yield_vector_input <- reactive(input$yield_vector_input)
chargeoff_vector_input <- reactive(input$chargeoff_vector_input)
npr_vector_input <- reactive(input$npr_vector_input)
mpr_vector_input <- reactive(input$mpr_vector_input)
chargeoff <- reactiveValues()
npr <- reactiveValues()
mpr <- reactiveValues()
vectorVariable <- function(x,y){
if(input$showVectorBtn == 0) vectorBase(input$periods,x)
else vectorMultiFinal(input$periods,matrixValidate(input$periods,y))}
yield <- function(){vectorVariable(input$base_input[1,1],yield_vector_input())}
chargeoffs <- function(){vectorVariable(input$base_input[2,1],chargeoff_vector_input())}
npr <- function(){vectorVariable(input$base_input[3,1],npr_vector_input())}
mpr <- function(){vectorVariable(input$base_input[4,1],mpr_vector_input())}
renderUI({
matrixLink("yield_vector_input",input$base_input[1,1])
matrixLink("chargeoff_vector_input",input$base_input[2,1])
matrixLink("npr_vector_input",input$base_input[3,1])
matrixLink("mpr_vector_input",input$base_input[4,1])
}) # close renderUI
output$Vectors <- renderUI({
input$resetVectorBtn
tagList(
matrix2Input("yield_vector_input",input$periods,input$base_input[1,1]),
matrix2Input("chargeoff_vector_input",input$periods,input$base_input[2,1]),
matrix2Input("npr_vector_input",input$periods,input$base_input[3,1]),
matrix2Input("mpr_vector_input",input$periods,input$base_input[4,1])
) # close tag list
}) # close render UI
observeEvent(input$showVectorBtn,{shinyjs::show("Vectors")})
observeEvent(input$hideVectorBtn,{shinyjs::hide("Vectors")})
vectorsAll <- reactive({
cbind(Period = 1:periods(),
Yld_Rate = yield()[,2],
Chg_Rate = chargeoffs()[,2],
Pur_Rate = npr()[,2],
Pmt_Rate = mpr()[,2]
) # close cbind
}) # close reactive
output$graph1 <-renderPlot(vectorPlot(yield(),"Annual gross portfolio yield","Period","Rate"))
output$table1 <- renderDT({vectorsAll()},
options=list(columnDefs=list(list(className='dt-center',targets=0:4)))
) # close renderDT
output$balancePlot <- renderPlot({vectorPlot(bal(),"Asset bal","Period","Balances OS")})
output$download <- downloadHandler(
filename = function() {{paste("Yield","png",sep=".")}},
content = function(file){
png(file)
vectorPlot(yield(),"Annual yield","Period","Rate")
dev.off()
} # close content function
) # close download handler
observeEvent(input$mainPanelBtnTab2,{
req(input$mainPanelBtnTab2 == "Downloads")
showModal(
modalDialog(
selectInput("downloadItem","Selection:",c("Yield plot")),
downloadButton("download", "Download")
) # close modal dialog
) # close show modal
updateRadioButtons(inputId = "mainPanelBtnTab2", selected = "Vector plots")
}) # close observeEvent
}) # close server
shinyApp(ui, server)
没有。 3 长代码resloving #2 renderUI，并且没有侧边栏调用闪烁（省略自定义函数，因为它们与上面的代码相同）：
ui <-
pageWithSidebar(
headerPanel("Model"),
sidebarPanel(
useShinyjs(),
fluidRow(helpText(h4("Base Input Panel"))),
uiOutput("Panels")
), # close sidebar panel
mainPanel(
useShinyjs(),
tabsetPanel(
tabPanel("About model", value=1, helpText("Model")),
tabPanel("By balances", value=2,
fluidRow(
radioButtons(
inputId = 'mainPanelBtnTab2',
label = h5(helpText("Asset outputs:")),
choices = c('Vector plots','Vector values','Downloads'),
selected = 'Vector plots',
inline = TRUE
) # close radio buttons
), # close fluid row
conditionalPanel(condition="input.mainPanelBtnTab2=='Vector plots'",plotOutput("graph1")),
conditionalPanel(condition="input.mainPanelBtnTab2=='Vector values'",DTOutput("table1")),
), # close tab panel
id = "tabselected"
) # close tabset panel
) # close main panel
) # close page with sidebar
server <- function(input,output,session)({
periods <- reactive(input$periods)
base_input <- reactive(input$base_input)
yield_vector_input <- reactive(input$yield_vector_input)
chargeoff_vector_input <- reactive(input$chargeoff_vector_input)
npr_vector_input <- reactive(input$npr_vector_input)
mpr_vector_input <- reactive(input$mpr_vector_input)
chargeoff <- reactiveValues()
npr <- reactiveValues()
mpr <- reactiveValues()
vectorVariable <- function(x,y){
if(input$showVectorBtn == 0) vectorBase(input$periods,x)
else vectorMultiFinal(input$periods,matrixValidate(input$periods,y))}
yield <- function(){vectorVariable(input$base_input[1,1],yield_vector_input())}
chargeoffs <- function(){vectorVariable(input$base_input[2,1],chargeoff_vector_input())}
npr <- function(){vectorVariable(input$base_input[3,1],npr_vector_input())}
mpr <- function(){vectorVariable(input$base_input[4,1],mpr_vector_input())}
output$Panels <- renderUI({
tagList(
conditionalPanel(condition="input.tabselected==1",h4("Select:")),
conditionalPanel(
condition="input.tabselected==2",
sliderInput('periods','',min=1,max=120,value=60),
matrix1Input("base_input"),
actionButton('showVectorBtn','Show'),
actionButton('hideVectorBtn','Hide'),
actionButton('resetVectorBtn','Reset'),
hidden(uiOutput("Vectors"))
), # close conditional panel
) # close tag list
}) # close renderUI
renderUI({
matrixLink("yield_vector_input",input$base_input[1,1])
matrixLink("chargeoff_vector_input",input$base_input[2,1])
matrixLink("npr_vector_input",input$base_input[3,1])
matrixLink("mpr_vector_input",input$base_input[4,1])
}) # close renderUI
output$Vectors <- renderUI({
input$resetVectorBtn
tagList(
matrix2Input("yield_vector_input",input$periods,input$base_input[1,1]),
matrix2Input("chargeoff_vector_input",input$periods,input$base_input[2,1]),
matrix2Input("npr_vector_input",input$periods,input$base_input[3,1]),
matrix2Input("mpr_vector_input",input$periods,input$base_input[4,1])
) # close tag list
}) # close render UI
observeEvent(input$showVectorBtn,{shinyjs::show("Vectors")})
observeEvent(input$hideVectorBtn,{shinyjs::hide("Vectors")})
vectorsAll <- reactive({
cbind(Period = 1:periods(),
Yld_Rate = yield()[,2],
Chg_Rate = chargeoffs()[,2],
Pur_Rate = npr()[,2],
Pmt_Rate = mpr()[,2]
) # close cbind
}) # close reactive
output$graph1 <-renderPlot(vectorPlot(yield(),"Annual gross portfolio yield","Period","Rate"))
output$table1 <- renderDT({vectorsAll()},
options=list(columnDefs=list(list(className='dt-center',targets=0:4)))
) # close renderDT
output$balancePlot <- renderPlot({vectorPlot(bal(),"Asset bal","Period","Balances OS")})
output$download <- downloadHandler(
filename = function() {{paste("Yield","png",sep=".")}},
content = function(file){
png(file)
vectorPlot(yield(),"Annual yield","Period","Rate")
dev.off()
} # close content function
) # close download handler
observeEvent(input$mainPanelBtnTab2,{
req(input$mainPanelBtnTab2 == "Downloads")
showModal(
modalDialog(
selectInput("downloadItem","Selection:",c("Yield plot")),
downloadButton("download", "Download")
) # close modal dialog
) # close show modal
updateRadioButtons(inputId = "mainPanelBtnTab2", selected = "Vector plots")
}) # close observeEvent
}) # close server
shinyApp(ui, server)
宁可在服务器中使用 observeEvent 而不是在 ui 中使用 conditionalPanel，如下所示（参见#Added 代码）。我还需要向 h4() 添加一个 id，并从所有第二个选项卡侧边栏按钮 hidden 开始。最后我将 ignoreInit = TRUE 添加到 observeEvent 因为它最初是不必要的：
library(shiny)
library(shinyMatrix)
library(shinyjs)
library(DT)
matrix1Input <- function(x){
matrixInput(x,
value = matrix(c(0.2), 4, 1, dimnames = list(c("A","B","C","D"),NULL)),
rows = list(extend = FALSE, names = TRUE),
cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
class = "numeric")}
matrix2Input <- function(x,y,z){
matrixInput(x,
value = matrix(c(y,z),1,2,dimnames=list(NULL,c("Y","Z"))),
rows = list(extend = TRUE, names = FALSE),
cols = list(extend = FALSE, names = TRUE, editableNames = FALSE),
class = "numeric")}
matrixLink <- function(x,y){
observeEvent(input$periods|input$base_input,{
updateMatrixInput(session,x,value=matrix(c(input$periods,y),1,2,dimnames=list(NULL, c("y","z"))))
})}
matrixValidate <- function(x,y){
a <- y
a[,1][a[,1]>x] <- x
b <- diff(a[,1,drop=FALSE])
b[b<=0] <- NA
b <- c(1,b)
a <- cbind(a,b)
a <- na.omit(a)
a <- a[,-c(3),drop=FALSE]
return(a)}
vectorBase <- function(x,y){
a <- rep(y,x)
b <- seq(1:x)
c <- data.frame(x = b, y = a)
return(c)}
vectorMulti <- function(x,y,z){
a <- rep(NA, x)
a[y] <- z
a[seq_len(min(y)-1)] <- a[min(y)]
if(max(y) < x){a[seq(max(y)+1, x, 1)] <- 0}
a <- approx(seq_along(a)[!is.na(a)],a[!is.na(a)],seq_along(a))$y
b <- seq(1:x)
c <- data.frame(x=b,z=a)
return(c)}
vectorMultiFinal <- function(x,y){vectorMulti(x,matrixValidate(x,y)[,1],matrixValidate(x,y)[,2])}
vectorPlot <- function(w,x,y,z){plot(w,main=x,xlab=y,ylab=z,type="b",col="blue",pch=19,cex=1.25)}
ui <-
pageWithSidebar(
headerPanel("Model"),
sidebarPanel(
useShinyjs(),
fluidRow(helpText(h4("Base Input Panel"))),
h4(id = 'select', "Select:", ),
hidden(sliderInput('periods','',min=1,max=120,value=60)),
hidden(matrix1Input("base_input")),
hidden(actionButton('showVectorBtn','Show')),
hidden(actionButton('hideVectorBtn','Hide')),
hidden(actionButton('resetVectorBtn','Reset')),
hidden(uiOutput("Vectors"))
), # close sidebar panel
mainPanel(
useShinyjs(),
tabsetPanel(
tabPanel("About model", value=1, helpText("Model")),
tabPanel("By balances", value=2,
fluidRow(
radioButtons(
inputId = 'mainPanelBtnTab2',
label = h5(helpText("Asset outputs:")),
choices = c('Vector plots','Vector values','Downloads'),
selected = 'Vector plots',
inline = TRUE
) # close radio buttons
), # close fluid row
conditionalPanel(condition="input.mainPanelBtnTab2=='Vector plots'",plotOutput("graph1")),
conditionalPanel(condition="input.mainPanelBtnTab2=='Vector values'",DTOutput("table1")),
), # close tab panel
id = "tabselected"
) # close tabset panel
) # close main panel
) # close page with sidebar
server <- function(input,output,session)({
periods <- reactive(input$periods)
base_input <- reactive(input$base_input)
yield_vector_input <- reactive(input$yield_vector_input)
chargeoff_vector_input <- reactive(input$chargeoff_vector_input)
npr_vector_input <- reactive(input$npr_vector_input)
mpr_vector_input <- reactive(input$mpr_vector_input)
chargeoff <- reactiveValues()
npr <- reactiveValues()
mpr <- reactiveValues()
vectorVariable <- function(x,y){
if(input$showVectorBtn == 0) vectorBase(input$periods,x)
else vectorMultiFinal(input$periods,matrixValidate(input$periods,y))}
yield <- function(){vectorVariable(input$base_input[1,1],yield_vector_input())}
chargeoffs <- function(){vectorVariable(input$base_input[2,1],chargeoff_vector_input())}
npr <- function(){vectorVariable(input$base_input[3,1],npr_vector_input())}
mpr <- function(){vectorVariable(input$base_input[4,1],mpr_vector_input())}
renderUI({
matrixLink("yield_vector_input",input$base_input[1,1])
matrixLink("chargeoff_vector_input",input$base_input[2,1])
matrixLink("npr_vector_input",input$base_input[3,1])
matrixLink("mpr_vector_input",input$base_input[4,1])
}) # close renderUI
output$Vectors <- renderUI({
input$resetVectorBtn
tagList(
matrix2Input("yield_vector_input",input$periods,input$base_input[1,1]),
matrix2Input("chargeoff_vector_input",input$periods,input$base_input[2,1]),
matrix2Input("npr_vector_input",input$periods,input$base_input[3,1]),
matrix2Input("mpr_vector_input",input$periods,input$base_input[4,1])
) # close tag list
}) # close render UI
# Added Code
observeEvent(input$tabselected, {
if (input$tabselected == 1) {
show('select')
hide('periods')
hide("base_input")
hide('showVectorBtn')
hide('hideVectorBtn')
hide('resetVectorBtn')
} else {
hide('select')
show('periods')
show("base_input")
show('showVectorBtn')
show('hideVectorBtn')
show('resetVectorBtn')
}
}, ignoreInit = TRUE)
observeEvent(input$showVectorBtn,{shinyjs::show("Vectors")})
observeEvent(input$hideVectorBtn,{shinyjs::hide("Vectors")})
vectorsAll <- reactive({
cbind(Period = 1:periods(),
Yld_Rate = yield()[,2],
Chg_Rate = chargeoffs()[,2],
Pur_Rate = npr()[,2],
Pmt_Rate = mpr()[,2]
) # close cbind
}) # close reactive
output$graph1 <-renderPlot(vectorPlot(yield(),"Annual gross portfolio yield","Period","Rate"))
output$table1 <- renderDT({vectorsAll()},
options=list(columnDefs=list(list(className='dt-center',targets=0:4)))
) # close renderDT
output$balancePlot <- renderPlot({vectorPlot(bal(),"Asset bal","Period","Balances OS")})
output$download <- downloadHandler(
filename = function() {{paste("Yield","png",sep=".")}},
content = function(file){
png(file)
vectorPlot(yield(),"Annual yield","Period","Rate")
dev.off()
} # close content function
) # close download handler
observeEvent(input$mainPanelBtnTab2,{
req(input$mainPanelBtnTab2 == "Downloads")
showModal(
modalDialog(
selectInput("downloadItem","Selection:",c("Yield plot")),
downloadButton("download", "Download")
) # close modal dialog
) # close show modal
updateRadioButtons(inputId = "mainPanelBtnTab2", selected = "Vector plots")
}) # close observeEvent
}) # close server
shinyApp(ui, server)
现在我得到了一些 feedback on GitHub。
可以通过设置style = "display: none;"来避免闪烁。
在 UI 中解决此问题而不是使用基于服务器的解决方法（@EliBerkow 的回答）会导致更快地加载 UI。
library(shiny)
ui <- fluidPage(
radioButtons("yourChoice", "Display button?", choices = c("Yes", "No"), selected = "No",),
conditionalPanel("input.yourChoice == 'Yes'", style = "display: none;", actionButton("test", "test"))
)
server <- function(input, output, session) {}
shinyApp(ui, server)
应用于@CuriousJorge-user9788072 的代码：
library(shiny)
library(shinyMatrix)
library(shinyjs)
library(DT)
matrix1Input <- function(x){
matrixInput(x,
value = matrix(c(0.2), 4, 1, dimnames = list(c("A","B","C","D"),NULL)),
rows = list(extend = FALSE, names = TRUE),
cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
class = "numeric")}
matrix2Input <- function(x,y,z){
matrixInput(x,
value = matrix(c(y,z),1,2,dimnames=list(NULL,c("Y","Z"))),
rows = list(extend = TRUE, names = FALSE),
cols = list(extend = FALSE, names = TRUE, editableNames = FALSE),
class = "numeric")}
matrixLink <- function(x,y){
observeEvent(input$periods|input$base_input,{
updateMatrixInput(session,x,value=matrix(c(input$periods,y),1,2,dimnames=list(NULL, c("y","z"))))
})}
matrixValidate <- function(x,y){
a <- y
a[,1][a[,1]>x] <- x
b <- diff(a[,1,drop=FALSE])
b[b<=0] <- NA
b <- c(1,b)
a <- cbind(a,b)
a <- na.omit(a)
a <- a[,-c(3),drop=FALSE]
return(a)}
vectorBase <- function(x,y){
a <- rep(y,x)
b <- seq(1:x)
c <- data.frame(x = b, y = a)
return(c)}
vectorMulti <- function(x,y,z){
a <- rep(NA, x)
a[y] <- z
a[seq_len(min(y)-1)] <- a[min(y)]
if(max(y) < x){a[seq(max(y)+1, x, 1)] <- 0}
a <- approx(seq_along(a)[!is.na(a)],a[!is.na(a)],seq_along(a))$y
b <- seq(1:x)
c <- data.frame(x=b,z=a)
return(c)}
vectorMultiFinal <- function(x,y){vectorMulti(x,matrixValidate(x,y)[,1],matrixValidate(x,y)[,2])}
vectorPlot <- function(w,x,y,z){plot(w,main=x,xlab=y,ylab=z,type="b",col="blue",pch=19,cex=1.25)}
ui <-
pageWithSidebar(
headerPanel("Model"),
sidebarPanel(
useShinyjs(),
fluidRow(helpText(h4("Base Input Panel"))),
conditionalPanel(condition="input.tabselected==1",h4("Select:")),
conditionalPanel(
condition="input.tabselected==2",
sliderInput('periods','',min=1,max=120,value=60),
matrix1Input("base_input"),
actionButton('showVectorBtn','Show'),
actionButton('hideVectorBtn','Hide'),
actionButton('resetVectorBtn','Reset'),
hidden(uiOutput("Vectors")),
style = "display: none;"
), # close conditional panel
), # close sidebar panel
mainPanel(
useShinyjs(),
tabsetPanel(
tabPanel("About model", value=1, helpText("Model")),
tabPanel("By balances", value=2,
fluidRow(
radioButtons(
inputId = 'mainPanelBtnTab2',
label = h5(helpText("Asset outputs:")),
choices = c('Vector plots','Vector values','Downloads'),
selected = 'Vector plots',
inline = TRUE
) # close radio buttons
), # close fluid row
conditionalPanel(condition="input.mainPanelBtnTab2=='Vector plots'",plotOutput("graph1")),
conditionalPanel(condition="input.mainPanelBtnTab2=='Vector values'",DTOutput("table1")),
), # close tab panel
id = "tabselected"
) # close tabset panel
) # close main panel
) # close page with sidebar
server <- function(input,output,session)({
periods <- reactive(input$periods)
base_input <- reactive(input$base_input)
yield_vector_input <- reactive(input$yield_vector_input)
chargeoff_vector_input <- reactive(input$chargeoff_vector_input)
npr_vector_input <- reactive(input$npr_vector_input)
mpr_vector_input <- reactive(input$mpr_vector_input)
chargeoff <- reactiveValues()
npr <- reactiveValues()
mpr <- reactiveValues()
vectorVariable <- function(x,y){
if(input$showVectorBtn == 0) vectorBase(input$periods,x)
else vectorMultiFinal(input$periods,matrixValidate(input$periods,y))}
yield <- function(){vectorVariable(input$base_input[1,1],yield_vector_input())}
chargeoffs <- function(){vectorVariable(input$base_input[2,1],chargeoff_vector_input())}
npr <- function(){vectorVariable(input$base_input[3,1],npr_vector_input())}
mpr <- function(){vectorVariable(input$base_input[4,1],mpr_vector_input())}
renderUI({
matrixLink("yield_vector_input",input$base_input[1,1])
matrixLink("chargeoff_vector_input",input$base_input[2,1])
matrixLink("npr_vector_input",input$base_input[3,1])
matrixLink("mpr_vector_input",input$base_input[4,1])
}) # close renderUI
output$Vectors <- renderUI({
input$resetVectorBtn
tagList(
matrix2Input("yield_vector_input",input$periods,input$base_input[1,1]),
matrix2Input("chargeoff_vector_input",input$periods,input$base_input[2,1]),
matrix2Input("npr_vector_input",input$periods,input$base_input[3,1]),
matrix2Input("mpr_vector_input",input$periods,input$base_input[4,1])
) # close tag list
}) # close render UI
observeEvent(input$showVectorBtn,{shinyjs::show("Vectors")})
observeEvent(input$hideVectorBtn,{shinyjs::hide("Vectors")})
vectorsAll <- reactive({
cbind(Period = 1:periods(),
Yld_Rate = yield()[,2],
Chg_Rate = chargeoffs()[,2],
Pur_Rate = npr()[,2],
Pmt_Rate = mpr()[,2]
) # close cbind
}) # close reactive
output$graph1 <-renderPlot(vectorPlot(yield(),"Annual gross portfolio yield","Period","Rate"))
output$table1 <- renderDT({vectorsAll()},
options=list(columnDefs=list(list(className='dt-center',targets=0:4)))
) # close renderDT
output$balancePlot <- renderPlot({vectorPlot(bal(),"Asset bal","Period","Balances OS")})
output$download <- downloadHandler(
filename = function() {{paste("Yield","png",sep=".")}},
content = function(file){
png(file)
vectorPlot(yield(),"Annual yield","Period","Rate")
dev.off()
} # close content function
) # close download handler
observeEvent(input$mainPanelBtnTab2,{
req(input$mainPanelBtnTab2 == "Downloads")
showModal(
modalDialog(
selectInput("downloadItem","Selection:",c("Yield plot")),
downloadButton("download", "Download")
) # close modal dialog
) # close show modal
updateRadioButtons(inputId = "mainPanelBtnTab2", selected = "Vector plots")
}) # close observeEvent
}) # close server
shinyApp(ui, server)
这是我 6 月 30 日 post 的跟进，我在调用应用程序时消除了 sidebarPanel 中的 conditionalPanel 闪烁。解决方案是将那些侧边栏条件面板移动到 renderUI，消除闪烁。但是，后来我发现以这种方式使用 renderUI 会导致其他限制。有什么方法可以在不使用 renderUI 的情况下消除调用闪烁？
我包括以下 3 组代码：
- 说明闪烁问题的非常短的 MWE 代码，由 ismirsehregal 提供
- 长而复杂的代码非常清楚地说明了在调用时所有条件面板如何在侧面板中闪烁，当侧边栏条件面板在 UI 中呈现时（没有
renderUI中的条件面板类似于下面 #3 中的侧边栏面板解决了这个问题，尽管它引入了其他未在此 post) 中解释的问题。 - 上面 #2 的改编，其中使用
renderUI并且没有调用闪烁。
我不想完全剥离第 2 项和第 3 项中的代码，以便侧边栏面板足够大，从而使调用闪烁更加明显。此外，当我对这段代码进行一些剥离时，我确实失去了一些功能，如“重置”，无论如何这与手头的问题无关。
尽管#2 和#3 中的代码可能冗长复杂，但将条件面板移至 renderUI 中非常简单。
没有。 1 个短 MWE 代码：
library(shiny)
ui <- fluidPage(
radioButtons("yourChoice", "Display button?", choices = c("Yes", "No"), selected = "No",),
conditionalPanel("input.yourChoice == 'Yes'", actionButton("test", "test"))
# not working: ------------------------------------------------------------
# conditionalPanel("typeof input.yourChoice !== 'undefined' && input.yourChoice == 'Yes'", actionButton("test", "test"))
# conditionalPanel("typeof input !== 'undefined' && input.yourChoice == 'Yes'", actionButton("test", "test"))
)
server <- function(input, output, session) {}
shinyApp(ui, server)
没有。 2 没有 renderUI 且边栏调用闪烁的长代码：
library(shiny)
library(shinyMatrix)
library(shinyjs)
library(DT)
matrix1Input <- function(x){
matrixInput(x,
value = matrix(c(0.2), 4, 1, dimnames = list(c("A","B","C","D"),NULL)),
rows = list(extend = FALSE, names = TRUE),
cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
class = "numeric")}
matrix2Input <- function(x,y,z){
matrixInput(x,
value = matrix(c(y,z),1,2,dimnames=list(NULL,c("Y","Z"))),
rows = list(extend = TRUE, names = FALSE),
cols = list(extend = FALSE, names = TRUE, editableNames = FALSE),
class = "numeric")}
matrixLink <- function(x,y){
observeEvent(input$periods|input$base_input,{
updateMatrixInput(session,x,value=matrix(c(input$periods,y),1,2,dimnames=list(NULL, c("y","z"))))
})}
matrixValidate <- function(x,y){
a <- y
a[,1][a[,1]>x] <- x
b <- diff(a[,1,drop=FALSE])
b[b<=0] <- NA
b <- c(1,b)
a <- cbind(a,b)
a <- na.omit(a)
a <- a[,-c(3),drop=FALSE]
return(a)}
vectorBase <- function(x,y){
a <- rep(y,x)
b <- seq(1:x)
c <- data.frame(x = b, y = a)
return(c)}
vectorMulti <- function(x,y,z){
a <- rep(NA, x)
a[y] <- z
a[seq_len(min(y)-1)] <- a[min(y)]
if(max(y) < x){a[seq(max(y)+1, x, 1)] <- 0}
a <- approx(seq_along(a)[!is.na(a)],a[!is.na(a)],seq_along(a))$y
b <- seq(1:x)
c <- data.frame(x=b,z=a)
return(c)}
vectorMultiFinal <- function(x,y){vectorMulti(x,matrixValidate(x,y)[,1],matrixValidate(x,y)[,2])}
vectorPlot <- function(w,x,y,z){plot(w,main=x,xlab=y,ylab=z,type="b",col="blue",pch=19,cex=1.25)}
ui <-
pageWithSidebar(
headerPanel("Model"),
sidebarPanel(
useShinyjs(),
fluidRow(helpText(h4("Base Input Panel"))),
conditionalPanel(condition="input.tabselected==1",h4("Select:")),
conditionalPanel(
condition="input.tabselected==2",
sliderInput('periods','',min=1,max=120,value=60),
matrix1Input("base_input"),
actionButton('showVectorBtn','Show'),
actionButton('hideVectorBtn','Hide'),
actionButton('resetVectorBtn','Reset'),
hidden(uiOutput("Vectors"))
), # close conditional panel
), # close sidebar panel
mainPanel(
useShinyjs(),
tabsetPanel(
tabPanel("About model", value=1, helpText("Model")),
tabPanel("By balances", value=2,
fluidRow(
radioButtons(
inputId = 'mainPanelBtnTab2',
label = h5(helpText("Asset outputs:")),
choices = c('Vector plots','Vector values','Downloads'),
selected = 'Vector plots',
inline = TRUE
) # close radio buttons
), # close fluid row
conditionalPanel(condition="input.mainPanelBtnTab2=='Vector plots'",plotOutput("graph1")),
conditionalPanel(condition="input.mainPanelBtnTab2=='Vector values'",DTOutput("table1")),
), # close tab panel
id = "tabselected"
) # close tabset panel
) # close main panel
) # close page with sidebar
server <- function(input,output,session)({
periods <- reactive(input$periods)
base_input <- reactive(input$base_input)
yield_vector_input <- reactive(input$yield_vector_input)
chargeoff_vector_input <- reactive(input$chargeoff_vector_input)
npr_vector_input <- reactive(input$npr_vector_input)
mpr_vector_input <- reactive(input$mpr_vector_input)
chargeoff <- reactiveValues()
npr <- reactiveValues()
mpr <- reactiveValues()
vectorVariable <- function(x,y){
if(input$showVectorBtn == 0) vectorBase(input$periods,x)
else vectorMultiFinal(input$periods,matrixValidate(input$periods,y))}
yield <- function(){vectorVariable(input$base_input[1,1],yield_vector_input())}
chargeoffs <- function(){vectorVariable(input$base_input[2,1],chargeoff_vector_input())}
npr <- function(){vectorVariable(input$base_input[3,1],npr_vector_input())}
mpr <- function(){vectorVariable(input$base_input[4,1],mpr_vector_input())}
renderUI({
matrixLink("yield_vector_input",input$base_input[1,1])
matrixLink("chargeoff_vector_input",input$base_input[2,1])
matrixLink("npr_vector_input",input$base_input[3,1])
matrixLink("mpr_vector_input",input$base_input[4,1])
}) # close renderUI
output$Vectors <- renderUI({
input$resetVectorBtn
tagList(
matrix2Input("yield_vector_input",input$periods,input$base_input[1,1]),
matrix2Input("chargeoff_vector_input",input$periods,input$base_input[2,1]),
matrix2Input("npr_vector_input",input$periods,input$base_input[3,1]),
matrix2Input("mpr_vector_input",input$periods,input$base_input[4,1])
) # close tag list
}) # close render UI
observeEvent(input$showVectorBtn,{shinyjs::show("Vectors")})
observeEvent(input$hideVectorBtn,{shinyjs::hide("Vectors")})
vectorsAll <- reactive({
cbind(Period = 1:periods(),
Yld_Rate = yield()[,2],
Chg_Rate = chargeoffs()[,2],
Pur_Rate = npr()[,2],
Pmt_Rate = mpr()[,2]
) # close cbind
}) # close reactive
output$graph1 <-renderPlot(vectorPlot(yield(),"Annual gross portfolio yield","Period","Rate"))
output$table1 <- renderDT({vectorsAll()},
options=list(columnDefs=list(list(className='dt-center',targets=0:4)))
) # close renderDT
output$balancePlot <- renderPlot({vectorPlot(bal(),"Asset bal","Period","Balances OS")})
output$download <- downloadHandler(
filename = function() {{paste("Yield","png",sep=".")}},
content = function(file){
png(file)
vectorPlot(yield(),"Annual yield","Period","Rate")
dev.off()
} # close content function
) # close download handler
observeEvent(input$mainPanelBtnTab2,{
req(input$mainPanelBtnTab2 == "Downloads")
showModal(
modalDialog(
selectInput("downloadItem","Selection:",c("Yield plot")),
downloadButton("download", "Download")
) # close modal dialog
) # close show modal
updateRadioButtons(inputId = "mainPanelBtnTab2", selected = "Vector plots")
}) # close observeEvent
}) # close server
shinyApp(ui, server)
没有。 3 长代码resloving #2 renderUI，并且没有侧边栏调用闪烁（省略自定义函数，因为它们与上面的代码相同）：
ui <-
pageWithSidebar(
headerPanel("Model"),
sidebarPanel(
useShinyjs(),
fluidRow(helpText(h4("Base Input Panel"))),
uiOutput("Panels")
), # close sidebar panel
mainPanel(
useShinyjs(),
tabsetPanel(
tabPanel("About model", value=1, helpText("Model")),
tabPanel("By balances", value=2,
fluidRow(
radioButtons(
inputId = 'mainPanelBtnTab2',
label = h5(helpText("Asset outputs:")),
choices = c('Vector plots','Vector values','Downloads'),
selected = 'Vector plots',
inline = TRUE
) # close radio buttons
), # close fluid row
conditionalPanel(condition="input.mainPanelBtnTab2=='Vector plots'",plotOutput("graph1")),
conditionalPanel(condition="input.mainPanelBtnTab2=='Vector values'",DTOutput("table1")),
), # close tab panel
id = "tabselected"
) # close tabset panel
) # close main panel
) # close page with sidebar
server <- function(input,output,session)({
periods <- reactive(input$periods)
base_input <- reactive(input$base_input)
yield_vector_input <- reactive(input$yield_vector_input)
chargeoff_vector_input <- reactive(input$chargeoff_vector_input)
npr_vector_input <- reactive(input$npr_vector_input)
mpr_vector_input <- reactive(input$mpr_vector_input)
chargeoff <- reactiveValues()
npr <- reactiveValues()
mpr <- reactiveValues()
vectorVariable <- function(x,y){
if(input$showVectorBtn == 0) vectorBase(input$periods,x)
else vectorMultiFinal(input$periods,matrixValidate(input$periods,y))}
yield <- function(){vectorVariable(input$base_input[1,1],yield_vector_input())}
chargeoffs <- function(){vectorVariable(input$base_input[2,1],chargeoff_vector_input())}
npr <- function(){vectorVariable(input$base_input[3,1],npr_vector_input())}
mpr <- function(){vectorVariable(input$base_input[4,1],mpr_vector_input())}
output$Panels <- renderUI({
tagList(
conditionalPanel(condition="input.tabselected==1",h4("Select:")),
conditionalPanel(
condition="input.tabselected==2",
sliderInput('periods','',min=1,max=120,value=60),
matrix1Input("base_input"),
actionButton('showVectorBtn','Show'),
actionButton('hideVectorBtn','Hide'),
actionButton('resetVectorBtn','Reset'),
hidden(uiOutput("Vectors"))
), # close conditional panel
) # close tag list
}) # close renderUI
renderUI({
matrixLink("yield_vector_input",input$base_input[1,1])
matrixLink("chargeoff_vector_input",input$base_input[2,1])
matrixLink("npr_vector_input",input$base_input[3,1])
matrixLink("mpr_vector_input",input$base_input[4,1])
}) # close renderUI
output$Vectors <- renderUI({
input$resetVectorBtn
tagList(
matrix2Input("yield_vector_input",input$periods,input$base_input[1,1]),
matrix2Input("chargeoff_vector_input",input$periods,input$base_input[2,1]),
matrix2Input("npr_vector_input",input$periods,input$base_input[3,1]),
matrix2Input("mpr_vector_input",input$periods,input$base_input[4,1])
) # close tag list
}) # close render UI
observeEvent(input$showVectorBtn,{shinyjs::show("Vectors")})
observeEvent(input$hideVectorBtn,{shinyjs::hide("Vectors")})
vectorsAll <- reactive({
cbind(Period = 1:periods(),
Yld_Rate = yield()[,2],
Chg_Rate = chargeoffs()[,2],
Pur_Rate = npr()[,2],
Pmt_Rate = mpr()[,2]
) # close cbind
}) # close reactive
output$graph1 <-renderPlot(vectorPlot(yield(),"Annual gross portfolio yield","Period","Rate"))
output$table1 <- renderDT({vectorsAll()},
options=list(columnDefs=list(list(className='dt-center',targets=0:4)))
) # close renderDT
output$balancePlot <- renderPlot({vectorPlot(bal(),"Asset bal","Period","Balances OS")})
output$download <- downloadHandler(
filename = function() {{paste("Yield","png",sep=".")}},
content = function(file){
png(file)
vectorPlot(yield(),"Annual yield","Period","Rate")
dev.off()
} # close content function
) # close download handler
observeEvent(input$mainPanelBtnTab2,{
req(input$mainPanelBtnTab2 == "Downloads")
showModal(
modalDialog(
selectInput("downloadItem","Selection:",c("Yield plot")),
downloadButton("download", "Download")
) # close modal dialog
) # close show modal
updateRadioButtons(inputId = "mainPanelBtnTab2", selected = "Vector plots")
}) # close observeEvent
}) # close server
shinyApp(ui, server)
宁可在服务器中使用 observeEvent 而不是在 ui 中使用 conditionalPanel，如下所示（参见#Added 代码）。我还需要向 h4() 添加一个 id，并从所有第二个选项卡侧边栏按钮 hidden 开始。最后我将 ignoreInit = TRUE 添加到 observeEvent 因为它最初是不必要的：
library(shiny)
library(shinyMatrix)
library(shinyjs)
library(DT)
matrix1Input <- function(x){
matrixInput(x,
value = matrix(c(0.2), 4, 1, dimnames = list(c("A","B","C","D"),NULL)),
rows = list(extend = FALSE, names = TRUE),
cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
class = "numeric")}
matrix2Input <- function(x,y,z){
matrixInput(x,
value = matrix(c(y,z),1,2,dimnames=list(NULL,c("Y","Z"))),
rows = list(extend = TRUE, names = FALSE),
cols = list(extend = FALSE, names = TRUE, editableNames = FALSE),
class = "numeric")}
matrixLink <- function(x,y){
observeEvent(input$periods|input$base_input,{
updateMatrixInput(session,x,value=matrix(c(input$periods,y),1,2,dimnames=list(NULL, c("y","z"))))
})}
matrixValidate <- function(x,y){
a <- y
a[,1][a[,1]>x] <- x
b <- diff(a[,1,drop=FALSE])
b[b<=0] <- NA
b <- c(1,b)
a <- cbind(a,b)
a <- na.omit(a)
a <- a[,-c(3),drop=FALSE]
return(a)}
vectorBase <- function(x,y){
a <- rep(y,x)
b <- seq(1:x)
c <- data.frame(x = b, y = a)
return(c)}
vectorMulti <- function(x,y,z){
a <- rep(NA, x)
a[y] <- z
a[seq_len(min(y)-1)] <- a[min(y)]
if(max(y) < x){a[seq(max(y)+1, x, 1)] <- 0}
a <- approx(seq_along(a)[!is.na(a)],a[!is.na(a)],seq_along(a))$y
b <- seq(1:x)
c <- data.frame(x=b,z=a)
return(c)}
vectorMultiFinal <- function(x,y){vectorMulti(x,matrixValidate(x,y)[,1],matrixValidate(x,y)[,2])}
vectorPlot <- function(w,x,y,z){plot(w,main=x,xlab=y,ylab=z,type="b",col="blue",pch=19,cex=1.25)}
ui <-
pageWithSidebar(
headerPanel("Model"),
sidebarPanel(
useShinyjs(),
fluidRow(helpText(h4("Base Input Panel"))),
h4(id = 'select', "Select:", ),
hidden(sliderInput('periods','',min=1,max=120,value=60)),
hidden(matrix1Input("base_input")),
hidden(actionButton('showVectorBtn','Show')),
hidden(actionButton('hideVectorBtn','Hide')),
hidden(actionButton('resetVectorBtn','Reset')),
hidden(uiOutput("Vectors"))
), # close sidebar panel
mainPanel(
useShinyjs(),
tabsetPanel(
tabPanel("About model", value=1, helpText("Model")),
tabPanel("By balances", value=2,
fluidRow(
radioButtons(
inputId = 'mainPanelBtnTab2',
label = h5(helpText("Asset outputs:")),
choices = c('Vector plots','Vector values','Downloads'),
selected = 'Vector plots',
inline = TRUE
) # close radio buttons
), # close fluid row
conditionalPanel(condition="input.mainPanelBtnTab2=='Vector plots'",plotOutput("graph1")),
conditionalPanel(condition="input.mainPanelBtnTab2=='Vector values'",DTOutput("table1")),
), # close tab panel
id = "tabselected"
) # close tabset panel
) # close main panel
) # close page with sidebar
server <- function(input,output,session)({
periods <- reactive(input$periods)
base_input <- reactive(input$base_input)
yield_vector_input <- reactive(input$yield_vector_input)
chargeoff_vector_input <- reactive(input$chargeoff_vector_input)
npr_vector_input <- reactive(input$npr_vector_input)
mpr_vector_input <- reactive(input$mpr_vector_input)
chargeoff <- reactiveValues()
npr <- reactiveValues()
mpr <- reactiveValues()
vectorVariable <- function(x,y){
if(input$showVectorBtn == 0) vectorBase(input$periods,x)
else vectorMultiFinal(input$periods,matrixValidate(input$periods,y))}
yield <- function(){vectorVariable(input$base_input[1,1],yield_vector_input())}
chargeoffs <- function(){vectorVariable(input$base_input[2,1],chargeoff_vector_input())}
npr <- function(){vectorVariable(input$base_input[3,1],npr_vector_input())}
mpr <- function(){vectorVariable(input$base_input[4,1],mpr_vector_input())}
renderUI({
matrixLink("yield_vector_input",input$base_input[1,1])
matrixLink("chargeoff_vector_input",input$base_input[2,1])
matrixLink("npr_vector_input",input$base_input[3,1])
matrixLink("mpr_vector_input",input$base_input[4,1])
}) # close renderUI
output$Vectors <- renderUI({
input$resetVectorBtn
tagList(
matrix2Input("yield_vector_input",input$periods,input$base_input[1,1]),
matrix2Input("chargeoff_vector_input",input$periods,input$base_input[2,1]),
matrix2Input("npr_vector_input",input$periods,input$base_input[3,1]),
matrix2Input("mpr_vector_input",input$periods,input$base_input[4,1])
) # close tag list
}) # close render UI
# Added Code
observeEvent(input$tabselected, {
if (input$tabselected == 1) {
show('select')
hide('periods')
hide("base_input")
hide('showVectorBtn')
hide('hideVectorBtn')
hide('resetVectorBtn')
} else {
hide('select')
show('periods')
show("base_input")
show('showVectorBtn')
show('hideVectorBtn')
show('resetVectorBtn')
}
}, ignoreInit = TRUE)
observeEvent(input$showVectorBtn,{shinyjs::show("Vectors")})
observeEvent(input$hideVectorBtn,{shinyjs::hide("Vectors")})
vectorsAll <- reactive({
cbind(Period = 1:periods(),
Yld_Rate = yield()[,2],
Chg_Rate = chargeoffs()[,2],
Pur_Rate = npr()[,2],
Pmt_Rate = mpr()[,2]
) # close cbind
}) # close reactive
output$graph1 <-renderPlot(vectorPlot(yield(),"Annual gross portfolio yield","Period","Rate"))
output$table1 <- renderDT({vectorsAll()},
options=list(columnDefs=list(list(className='dt-center',targets=0:4)))
) # close renderDT
output$balancePlot <- renderPlot({vectorPlot(bal(),"Asset bal","Period","Balances OS")})
output$download <- downloadHandler(
filename = function() {{paste("Yield","png",sep=".")}},
content = function(file){
png(file)
vectorPlot(yield(),"Annual yield","Period","Rate")
dev.off()
} # close content function
) # close download handler
observeEvent(input$mainPanelBtnTab2,{
req(input$mainPanelBtnTab2 == "Downloads")
showModal(
modalDialog(
selectInput("downloadItem","Selection:",c("Yield plot")),
downloadButton("download", "Download")
) # close modal dialog
) # close show modal
updateRadioButtons(inputId = "mainPanelBtnTab2", selected = "Vector plots")
}) # close observeEvent
}) # close server
shinyApp(ui, server)
现在我得到了一些 feedback on GitHub。
可以通过设置style = "display: none;"来避免闪烁。
在 UI 中解决此问题而不是使用基于服务器的解决方法（@EliBerkow 的回答）会导致更快地加载 UI。
library(shiny)
ui <- fluidPage(
radioButtons("yourChoice", "Display button?", choices = c("Yes", "No"), selected = "No",),
conditionalPanel("input.yourChoice == 'Yes'", style = "display: none;", actionButton("test", "test"))
)
server <- function(input, output, session) {}
shinyApp(ui, server)
应用于@CuriousJorge-user9788072 的代码：
library(shiny)
library(shinyMatrix)
library(shinyjs)
library(DT)
matrix1Input <- function(x){
matrixInput(x,
value = matrix(c(0.2), 4, 1, dimnames = list(c("A","B","C","D"),NULL)),
rows = list(extend = FALSE, names = TRUE),
cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
class = "numeric")}
matrix2Input <- function(x,y,z){
matrixInput(x,
value = matrix(c(y,z),1,2,dimnames=list(NULL,c("Y","Z"))),
rows = list(extend = TRUE, names = FALSE),
cols = list(extend = FALSE, names = TRUE, editableNames = FALSE),
class = "numeric")}
matrixLink <- function(x,y){
observeEvent(input$periods|input$base_input,{
updateMatrixInput(session,x,value=matrix(c(input$periods,y),1,2,dimnames=list(NULL, c("y","z"))))
})}
matrixValidate <- function(x,y){
a <- y
a[,1][a[,1]>x] <- x
b <- diff(a[,1,drop=FALSE])
b[b<=0] <- NA
b <- c(1,b)
a <- cbind(a,b)
a <- na.omit(a)
a <- a[,-c(3),drop=FALSE]
return(a)}
vectorBase <- function(x,y){
a <- rep(y,x)
b <- seq(1:x)
c <- data.frame(x = b, y = a)
return(c)}
vectorMulti <- function(x,y,z){
a <- rep(NA, x)
a[y] <- z
a[seq_len(min(y)-1)] <- a[min(y)]
if(max(y) < x){a[seq(max(y)+1, x, 1)] <- 0}
a <- approx(seq_along(a)[!is.na(a)],a[!is.na(a)],seq_along(a))$y
b <- seq(1:x)
c <- data.frame(x=b,z=a)
return(c)}
vectorMultiFinal <- function(x,y){vectorMulti(x,matrixValidate(x,y)[,1],matrixValidate(x,y)[,2])}
vectorPlot <- function(w,x,y,z){plot(w,main=x,xlab=y,ylab=z,type="b",col="blue",pch=19,cex=1.25)}
ui <-
pageWithSidebar(
headerPanel("Model"),
sidebarPanel(
useShinyjs(),
fluidRow(helpText(h4("Base Input Panel"))),
conditionalPanel(condition="input.tabselected==1",h4("Select:")),
conditionalPanel(
condition="input.tabselected==2",
sliderInput('periods','',min=1,max=120,value=60),
matrix1Input("base_input"),
actionButton('showVectorBtn','Show'),
actionButton('hideVectorBtn','Hide'),
actionButton('resetVectorBtn','Reset'),
hidden(uiOutput("Vectors")),
style = "display: none;"
), # close conditional panel
), # close sidebar panel
mainPanel(
useShinyjs(),
tabsetPanel(
tabPanel("About model", value=1, helpText("Model")),
tabPanel("By balances", value=2,
fluidRow(
radioButtons(
inputId = 'mainPanelBtnTab2',
label = h5(helpText("Asset outputs:")),
choices = c('Vector plots','Vector values','Downloads'),
selected = 'Vector plots',
inline = TRUE
) # close radio buttons
), # close fluid row
conditionalPanel(condition="input.mainPanelBtnTab2=='Vector plots'",plotOutput("graph1")),
conditionalPanel(condition="input.mainPanelBtnTab2=='Vector values'",DTOutput("table1")),
), # close tab panel
id = "tabselected"
) # close tabset panel
) # close main panel
) # close page with sidebar
server <- function(input,output,session)({
periods <- reactive(input$periods)
base_input <- reactive(input$base_input)
yield_vector_input <- reactive(input$yield_vector_input)
chargeoff_vector_input <- reactive(input$chargeoff_vector_input)
npr_vector_input <- reactive(input$npr_vector_input)
mpr_vector_input <- reactive(input$mpr_vector_input)
chargeoff <- reactiveValues()
npr <- reactiveValues()
mpr <- reactiveValues()
vectorVariable <- function(x,y){
if(input$showVectorBtn == 0) vectorBase(input$periods,x)
else vectorMultiFinal(input$periods,matrixValidate(input$periods,y))}
yield <- function(){vectorVariable(input$base_input[1,1],yield_vector_input())}
chargeoffs <- function(){vectorVariable(input$base_input[2,1],chargeoff_vector_input())}
npr <- function(){vectorVariable(input$base_input[3,1],npr_vector_input())}
mpr <- function(){vectorVariable(input$base_input[4,1],mpr_vector_input())}
renderUI({
matrixLink("yield_vector_input",input$base_input[1,1])
matrixLink("chargeoff_vector_input",input$base_input[2,1])
matrixLink("npr_vector_input",input$base_input[3,1])
matrixLink("mpr_vector_input",input$base_input[4,1])
}) # close renderUI
output$Vectors <- renderUI({
input$resetVectorBtn
tagList(
matrix2Input("yield_vector_input",input$periods,input$base_input[1,1]),
matrix2Input("chargeoff_vector_input",input$periods,input$base_input[2,1]),
matrix2Input("npr_vector_input",input$periods,input$base_input[3,1]),
matrix2Input("mpr_vector_input",input$periods,input$base_input[4,1])
) # close tag list
}) # close render UI
observeEvent(input$showVectorBtn,{shinyjs::show("Vectors")})
observeEvent(input$hideVectorBtn,{shinyjs::hide("Vectors")})
vectorsAll <- reactive({
cbind(Period = 1:periods(),
Yld_Rate = yield()[,2],
Chg_Rate = chargeoffs()[,2],
Pur_Rate = npr()[,2],
Pmt_Rate = mpr()[,2]
) # close cbind
}) # close reactive
output$graph1 <-renderPlot(vectorPlot(yield(),"Annual gross portfolio yield","Period","Rate"))
output$table1 <- renderDT({vectorsAll()},
options=list(columnDefs=list(list(className='dt-center',targets=0:4)))
) # close renderDT
output$balancePlot <- renderPlot({vectorPlot(bal(),"Asset bal","Period","Balances OS")})
output$download <- downloadHandler(
filename = function() {{paste("Yield","png",sep=".")}},
content = function(file){
png(file)
vectorPlot(yield(),"Annual yield","Period","Rate")
dev.off()
} # close content function
) # close download handler
observeEvent(input$mainPanelBtnTab2,{
req(input$mainPanelBtnTab2 == "Downloads")
showModal(
modalDialog(
selectInput("downloadItem","Selection:",c("Yield plot")),
downloadButton("download", "Download")
) # close modal dialog
) # close show modal
updateRadioButtons(inputId = "mainPanelBtnTab2", selected = "Vector plots")
}) # close observeEvent
}) # close server
shinyApp(ui, server)