#r #shiny #shiny-reactivity
Вопрос:
В приведенном ниже коде 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)
Ответ №1:
У тебя была хорошая попытка. Просто переместите свое «гото» внутрь фигурных скобок:
{showModal(modalDialog(
matrix4Input("matrix4",if(is.null(input$matrix4)) matrix4Default else input$matrix4),
useShinyjs(),
footer = tagList(
actionButton("resetRatesStruct","Reset"),
modalButton("Close")
)))
showResults$showme <- tagList(tableOutput("table4")) ### this line
} ## above this curly brace
Комментарии:
1. Дополнительным преимуществом этого «перехода» является то, что изменяемая базовая таблица отображается в фоновом режиме под модальным диалогом, поэтому вы можете видеть свои изменения, отраженные в таблице главной панели в режиме реального времени. A
2. Да, мне действительно понравился этот эффект. Реактивные значения, используемые таким образом, дают нам гораздо больше контроля над выводом только элементов$; например , вы можете иметь, скажем, содержимое правой боковой панели на основе «переключателя» реактивного значения и изменять его в зависимости от того, где пользователь перемещается в приложении. отличный эффект пользовательского интерфейса!
Ответ №2:
Возможно, вы ищете это.
library(shiny)
library(shinyMatrix)
library(shinyjs)
matrix3Headers <- function(){c('A','B','C','D')}
matrix3Default <- matrix(c(1,24,0,100),4,1,dimnames=list(matrix3Headers(), NULL))
colnames(matrix3Default) <- paste0("Series ",1:ncol(matrix3Default))
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")
actionButton("close1","Close")
), # close tag list
))} # close show modal and modal dialog
# ATTEMPT > {showResults$showme <- tagList(tableOutput("table3"))}
) # close observe event
observeEvent(input$close1,{
removeModal()
showResults$showme <- tagList(tableOutput("table3"))
})
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")
actionButton("close2","Close")
)))} # close taglist, modalDialog, showModal, and showModal function
# ATTEMPT > {showResults$showme <- tagList(tableOutput("table4"))}
) # close observeEvent
observeEvent(input$close2,{
removeModal()
showResults$showme <- tagList(tableOutput("table4"))
})
}) # close server
shinyApp(ui, server)
Комментарии:
1. Да, именно то, что я искал. Снова я спасен YBS! То, что вы здесь сделали, ясно, спасибо вам за то, что вы четко изложили изменения. Таким образом, я смогу понять, что происходит, и узнать что-то важное.