在 R Shiny 中，如何允许通过下一次单击允许修改的操作按钮来保留反应性用户输入的更改？
In R Shiny, how to allow a change in reactive user inputs to retain through the next click of an action button that permits modification?
在下面的第一个 MWE 代码中，它完美地工作 - 用户点击“修改”操作按钮，在弹出的模式对话框中用户对矩阵用户输入网格进行更改，用户关闭模式对话框，再次单击“修改”，这些用户输入将保留（或“保留”）在矩阵输入网格（和输出 table）中，而不会进行任何类型的重置回默认设置。完美，按预期工作。
在下面的第二个 MWE 代码中，在“负债模块”选项卡内，用户输入不会从一次单击“修改...”操作按钮（呈现在侧边栏面板中）到下一次保留。每次单击“修改...”都会将用户输入网格重置为默认值。
我一直在尝试将反应链从第一个 MWE 复制到第二个 MWE，但没有成功。我对反应性的理解不够深入。有人可以帮我解决这个问题，并解释需要做什么以及可能的原因吗？
用户输入正确保留的第一个 MWE 代码：
library(shiny)
library(shinyMatrix)
library(shinyjs)
# Function assigns row headers to input matrix grid
matrix3Headers <- function(){
c('A','B','C','D')}
# Assigns default values to first column of input matrix grid
matrix3Default <- matrix(c(1,24,0,100),4,1,dimnames=list(matrix3Headers(),NULL))
# Automatically assigns names to column headers
colnames(matrix3Default) <- paste0("Series ",1:ncol(matrix3Default))
# Matrix input function
matrix3Input <- function(x, matrix3Default){
matrixInput(x,
label = 'Input series terms into below grid, formatted version shown at bottom:',
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
ui <- fluidPage(
useShinyjs(),
titlePanel('Liabilities Inputs'),
fluidRow(actionButton('show','Show'),
actionButton('modify','Modify'),
actionButton('hide','Hide'),
actionButton('reset','Reset'),
tableOutput('table2')
) # close fluid row
) # close fluid page
server <- function(input, output, session){
rv <- reactiveValues(
mat3=matrix3Input('matrix3',matrix3Default),
input=matrix3Default,
colHeader = colnames(input)
) # close reactive values
hide('table2')
observeEvent(input$modify,{
showModal(modalDialog(
rv$mat3,
tableOutput('table1')
)) # close shown modal and modal dialog
hide('table2')
}) # close observe event
output$table1 <- renderTable({
rv$mat3 <- matrix3Input('matrix3',input$matrix3)
# Indented section below assigns sequential column headers to output tables:
df <- input$matrix3
n <- dim(df)[2]
# Below indented code adds numeric formats to table output
dfA <- format(df[1,],nsmall=0)
dfB <- format(df[2,],nsmall=0)
dfC <- paste(format(df[3,],nsmall=2),'%')
dfD <- paste(format(df[4,],nsmall=2),'%')
df <- rbind(df[0,],dfA,dfB,dfC,dfD)
rownames(df) <- matrix3Headers()
rv$input <- df
colnames(df) <- paste("Series", 1:n)
df
},rownames=TRUE, colnames=TRUE)
observeEvent(input$show,show('table2'))
observeEvent(input$hide, hide('table2'))
observeEvent(input$reset,{
hide('table2')
rv$input <- matrix3Default
rv$mat3 <- matrix3Input('matrix3', matrix3Default)
}) # close observe event
output$table2 <- renderTable({
df <- rv$input
n <- dim(df)[2]
colnames(df) <- paste("Series", 1:n)
df
},rownames=TRUE)
} # close server
shinyApp(ui, server)
第二个需要用户输入的 MWE 代码“留下来”：
library(shiny)
library(shinyMatrix)
library(shinyjs)
library(shinyWidgets)
button2 <- function(x,y){actionButton(x,y,style="width:90px;margin-bottom:5px;font-size:80%")}
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")}
pct <- function(x){paste(format(round(x*100,digits=1),nsmall=1),"%",sep="")} # convert to percentage
vectorBase <- function(x,y){
a <- rep(y,x)
b <- seq(1:x)
c <- data.frame(x = b, y = a)
return(c)}
vectorPlot <- function(w,x,y,z){
plot(w[,1],sapply(w[,2], function(x)gsub("%","",x)), # << per YBS solution Aug 27, 2021
main=x,
xlab=y,
ylab=z,
type="b",
col="blue",
pch=19,cex=1.25
) # close plot
} # close function
ui <-
pageWithSidebar(
headerPanel("Model..."),
sidebarPanel(
fluidRow(helpText(h5(strong("Base Input Panel")),align="center",
style="margin-top:-15px;margin-bottom:5px")),
# Panels rendered with uiOuput & renderUI in server to stop flashing at invocation
uiOutput("Panels")
), # close sidebar panel
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(
button2('showRatesValueBtn','Rates values'),
button2('showRatesPlotBtn','Rates plots'),
), # close fluid row
div(style = "margin-top: 5px"),
# Shows outputs on each page of main panel
uiOutput('showResults')),
id = "tabselected"
) # close tabset panel
) # close main panel
) # close page with sidebar
server <- function(input,output,session)({
base_input <- reactive(input$base_input)
showResults <- reactiveValues()
yield <- function(){vectorBase(60,input$base_input[1,1])} # Must remain in server section
# --- Conditional panels rendered here rather than in UI to eliminate invocation flashing ------------>
output$Panels <- renderUI({
tagList(
conditionalPanel(
condition="input.tabselected==4",
actionButton('modRates','Modify Rates and Coupons',
style='width:100%;background-color:LightGrey'
),
setShadow(id='modRates'),
div(style = "margin-bottom: 10px"),
), # close conditional panel
conditionalPanel(condition="input.tabselected==3"),
conditionalPanel(condition="input.tabselected==4")
) # close tagList
}) # close renderUI
# --- Below defines the vectorsAll object before user clicks on actionButton "Input Liabilities" ---->
vectorsAll <- reactive({
if (is.null(input$modRates)){df <- NULL}
else {
if(input$modRates < 1){df <- cbind(Period = 1:60,BaseRate = pct(0.2))} # define what you want to display by default
else {
req(input$base_input)
df <- cbind(Period = 1:60,BaseRate = pct(yield()[,2]))
} # close 2nd else
} # close 1st else
df
}) # close reactive
output$table1 <- renderTable({vectorsAll()})
# --- Below produces vector values after clicking "Vector Values" button; see above for pre-click ---->
observeEvent(input$showRatesValueBtn,
{showResults$showme <-
tagList(tableOutput("table1"))
},ignoreNULL = FALSE)
# --- Below produces vector plots -------------------------------------------------------------------->
output$graph1 <-renderPlot(vectorPlot(vectorsAll(),"A Variable","Period","Rate"))
observeEvent(input$showRatesPlotBtn,{showResults$showme <- plotOutput("graph1")})
# --- Below sends both vector plots and vector values to UI section above ---------------------------->
output$showResults <- renderUI({showResults$showme})
# --- Below for modal dialog inputs ------------------------------------------------------------------>
observeEvent(input$modRates,
{showModal(modalDialog(
matrix1Input("base_input"),
div(style = "margin-top: 0px"),
useShinyjs(),
) # close modalDialog
) # close showModal
} # close showModal function
) # close observeEvent
}) # close server
shinyApp(ui, server)
那是因为您的 modalDialog 每次单击按钮时都会重置 table。 matrix1Input 始终使用默认值。你需要把它作为你的第一个例子。渲染 table 时，您不再使用默认值重新渲染它，而是使用旧值。
library(shiny)
library(shinyMatrix)
library(shinyjs)
library(shinyWidgets)
button2 <- function(x,y){actionButton(x,y,style="width:90px;margin-bottom:5px;font-size:80%")}
mDefaults <- matrix(c(0.2), 4, 1,dimnames=list(c("A","B","C","D"),NULL))
matrix1Input <- function(x, defaults){
matrixInput(x,
value = defaults,
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
vectorBase <- function(x,y){
a <- rep(y,x)
b <- seq(1:x)
c <- data.frame(x = b, y = a)
return(c)}
vectorPlot <- function(w,x,y,z){
plot(w[,1],sapply(w[,2], function(x)gsub("%","",x)), # << per YBS solution Aug 27, 2021
main=x,
xlab=y,
ylab=z,
type="b",
col="blue",
pch=19,cex=1.25
) # close plot
} # close function
ui <-
pageWithSidebar(
headerPanel("Model..."),
sidebarPanel(
fluidRow(helpText(h5(strong("Base Input Panel")),align="center",
style="margin-top:-15px;margin-bottom:5px")),
# Panels rendered with uiOuput & renderUI in server to stop flashing at invocation
uiOutput("Panels")
), # close sidebar panel
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(
button2('showRatesValueBtn','Rates values'),
button2('showRatesPlotBtn','Rates plots'),
), # close fluid row
div(style = "margin-top: 5px"),
# Shows outputs on each page of main panel
uiOutput('showResults')),
id = "tabselected"
) # close tabset panel
) # close main panel
) # close page with sidebar
server <- function(input,output,session)({
base_input <- reactive(input$base_input)
showResults <- reactiveValues()
yield <- function(){vectorBase(60,input$base_input[1,1])} # Must remain in server section
# --- Conditional panels rendered here rather than in UI to eliminate invocation flashing ------------>
output$Panels <- renderUI({
tagList(
conditionalPanel(
condition="input.tabselected==4",
actionButton('modRates','Modify Rates and Coupons',
style='width:100%;background-color:LightGrey'
),
setShadow(id='modRates'),
div(style = "margin-bottom: 10px"),
), # close conditional panel
conditionalPanel(condition="input.tabselected==3"),
conditionalPanel(condition="input.tabselected==4")
) # close tagList
}) # close renderUI
# --- Below defines the vectorsAll object before user clicks on actionButton "Input Liabilities" ---->
vectorsAll <- reactive({
if (is.null(input$modRates)){df <- NULL}
else {
if(input$modRates < 1){df <- cbind(Period = 1:60,BaseRate = pct(0.2))} # define what you want to display by default
else {
req(input$base_input)
df <- cbind(Period = 1:60,BaseRate = pct(yield()[,2]))
} # close 2nd else
} # close 1st else
df
}) # close reactive
output$table1 <- renderTable({vectorsAll()})
# --- Below produces vector values after clicking "Vector Values" button; see above for pre-click ---->
observeEvent(input$showRatesValueBtn,
{showResults$showme <-
tagList(tableOutput("table1"))
},ignoreNULL = FALSE)
# --- Below produces vector plots -------------------------------------------------------------------->
output$graph1 <-renderPlot(vectorPlot(vectorsAll(),"A Variable","Period","Rate"))
observeEvent(input$showRatesPlotBtn,{showResults$showme <- plotOutput("graph1")})
# --- Below sends both vector plots and vector values to UI section above ---------------------------->
output$showResults <- renderUI({showResults$showme})
# --- Below for modal dialog inputs ------------------------------------------------------------------>
observeEvent(input$modRates,
{showModal(modalDialog(
matrix1Input("base_input", if(is.null(input$base_input)) mDefaults else input$base_input),
div(style = "margin-top: 0px"),
useShinyjs(),
) # close modalDialog
) # close showModal
} # close showModal function
) # close observeEvent
}) # close server
shinyApp(ui, server)
我添加了默认参数。当你的 table 存在时，我使用现有值而不是默认值。
在下面的第一个 MWE 代码中，它完美地工作 - 用户点击“修改”操作按钮，在弹出的模式对话框中用户对矩阵用户输入网格进行更改，用户关闭模式对话框，再次单击“修改”，这些用户输入将保留（或“保留”）在矩阵输入网格（和输出 table）中，而不会进行任何类型的重置回默认设置。完美，按预期工作。
在下面的第二个 MWE 代码中，在“负债模块”选项卡内，用户输入不会从一次单击“修改...”操作按钮（呈现在侧边栏面板中）到下一次保留。每次单击“修改...”都会将用户输入网格重置为默认值。
我一直在尝试将反应链从第一个 MWE 复制到第二个 MWE，但没有成功。我对反应性的理解不够深入。有人可以帮我解决这个问题，并解释需要做什么以及可能的原因吗？
用户输入正确保留的第一个 MWE 代码：
library(shiny)
library(shinyMatrix)
library(shinyjs)
# Function assigns row headers to input matrix grid
matrix3Headers <- function(){
c('A','B','C','D')}
# Assigns default values to first column of input matrix grid
matrix3Default <- matrix(c(1,24,0,100),4,1,dimnames=list(matrix3Headers(),NULL))
# Automatically assigns names to column headers
colnames(matrix3Default) <- paste0("Series ",1:ncol(matrix3Default))
# Matrix input function
matrix3Input <- function(x, matrix3Default){
matrixInput(x,
label = 'Input series terms into below grid, formatted version shown at bottom:',
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
ui <- fluidPage(
useShinyjs(),
titlePanel('Liabilities Inputs'),
fluidRow(actionButton('show','Show'),
actionButton('modify','Modify'),
actionButton('hide','Hide'),
actionButton('reset','Reset'),
tableOutput('table2')
) # close fluid row
) # close fluid page
server <- function(input, output, session){
rv <- reactiveValues(
mat3=matrix3Input('matrix3',matrix3Default),
input=matrix3Default,
colHeader = colnames(input)
) # close reactive values
hide('table2')
observeEvent(input$modify,{
showModal(modalDialog(
rv$mat3,
tableOutput('table1')
)) # close shown modal and modal dialog
hide('table2')
}) # close observe event
output$table1 <- renderTable({
rv$mat3 <- matrix3Input('matrix3',input$matrix3)
# Indented section below assigns sequential column headers to output tables:
df <- input$matrix3
n <- dim(df)[2]
# Below indented code adds numeric formats to table output
dfA <- format(df[1,],nsmall=0)
dfB <- format(df[2,],nsmall=0)
dfC <- paste(format(df[3,],nsmall=2),'%')
dfD <- paste(format(df[4,],nsmall=2),'%')
df <- rbind(df[0,],dfA,dfB,dfC,dfD)
rownames(df) <- matrix3Headers()
rv$input <- df
colnames(df) <- paste("Series", 1:n)
df
},rownames=TRUE, colnames=TRUE)
observeEvent(input$show,show('table2'))
observeEvent(input$hide, hide('table2'))
observeEvent(input$reset,{
hide('table2')
rv$input <- matrix3Default
rv$mat3 <- matrix3Input('matrix3', matrix3Default)
}) # close observe event
output$table2 <- renderTable({
df <- rv$input
n <- dim(df)[2]
colnames(df) <- paste("Series", 1:n)
df
},rownames=TRUE)
} # close server
shinyApp(ui, server)
第二个需要用户输入的 MWE 代码“留下来”：
library(shiny)
library(shinyMatrix)
library(shinyjs)
library(shinyWidgets)
button2 <- function(x,y){actionButton(x,y,style="width:90px;margin-bottom:5px;font-size:80%")}
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")}
pct <- function(x){paste(format(round(x*100,digits=1),nsmall=1),"%",sep="")} # convert to percentage
vectorBase <- function(x,y){
a <- rep(y,x)
b <- seq(1:x)
c <- data.frame(x = b, y = a)
return(c)}
vectorPlot <- function(w,x,y,z){
plot(w[,1],sapply(w[,2], function(x)gsub("%","",x)), # << per YBS solution Aug 27, 2021
main=x,
xlab=y,
ylab=z,
type="b",
col="blue",
pch=19,cex=1.25
) # close plot
} # close function
ui <-
pageWithSidebar(
headerPanel("Model..."),
sidebarPanel(
fluidRow(helpText(h5(strong("Base Input Panel")),align="center",
style="margin-top:-15px;margin-bottom:5px")),
# Panels rendered with uiOuput & renderUI in server to stop flashing at invocation
uiOutput("Panels")
), # close sidebar panel
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(
button2('showRatesValueBtn','Rates values'),
button2('showRatesPlotBtn','Rates plots'),
), # close fluid row
div(style = "margin-top: 5px"),
# Shows outputs on each page of main panel
uiOutput('showResults')),
id = "tabselected"
) # close tabset panel
) # close main panel
) # close page with sidebar
server <- function(input,output,session)({
base_input <- reactive(input$base_input)
showResults <- reactiveValues()
yield <- function(){vectorBase(60,input$base_input[1,1])} # Must remain in server section
# --- Conditional panels rendered here rather than in UI to eliminate invocation flashing ------------>
output$Panels <- renderUI({
tagList(
conditionalPanel(
condition="input.tabselected==4",
actionButton('modRates','Modify Rates and Coupons',
style='width:100%;background-color:LightGrey'
),
setShadow(id='modRates'),
div(style = "margin-bottom: 10px"),
), # close conditional panel
conditionalPanel(condition="input.tabselected==3"),
conditionalPanel(condition="input.tabselected==4")
) # close tagList
}) # close renderUI
# --- Below defines the vectorsAll object before user clicks on actionButton "Input Liabilities" ---->
vectorsAll <- reactive({
if (is.null(input$modRates)){df <- NULL}
else {
if(input$modRates < 1){df <- cbind(Period = 1:60,BaseRate = pct(0.2))} # define what you want to display by default
else {
req(input$base_input)
df <- cbind(Period = 1:60,BaseRate = pct(yield()[,2]))
} # close 2nd else
} # close 1st else
df
}) # close reactive
output$table1 <- renderTable({vectorsAll()})
# --- Below produces vector values after clicking "Vector Values" button; see above for pre-click ---->
observeEvent(input$showRatesValueBtn,
{showResults$showme <-
tagList(tableOutput("table1"))
},ignoreNULL = FALSE)
# --- Below produces vector plots -------------------------------------------------------------------->
output$graph1 <-renderPlot(vectorPlot(vectorsAll(),"A Variable","Period","Rate"))
observeEvent(input$showRatesPlotBtn,{showResults$showme <- plotOutput("graph1")})
# --- Below sends both vector plots and vector values to UI section above ---------------------------->
output$showResults <- renderUI({showResults$showme})
# --- Below for modal dialog inputs ------------------------------------------------------------------>
observeEvent(input$modRates,
{showModal(modalDialog(
matrix1Input("base_input"),
div(style = "margin-top: 0px"),
useShinyjs(),
) # close modalDialog
) # close showModal
} # close showModal function
) # close observeEvent
}) # close server
shinyApp(ui, server)
那是因为您的 modalDialog 每次单击按钮时都会重置 table。 matrix1Input 始终使用默认值。你需要把它作为你的第一个例子。渲染 table 时，您不再使用默认值重新渲染它，而是使用旧值。
library(shiny)
library(shinyMatrix)
library(shinyjs)
library(shinyWidgets)
button2 <- function(x,y){actionButton(x,y,style="width:90px;margin-bottom:5px;font-size:80%")}
mDefaults <- matrix(c(0.2), 4, 1,dimnames=list(c("A","B","C","D"),NULL))
matrix1Input <- function(x, defaults){
matrixInput(x,
value = defaults,
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
vectorBase <- function(x,y){
a <- rep(y,x)
b <- seq(1:x)
c <- data.frame(x = b, y = a)
return(c)}
vectorPlot <- function(w,x,y,z){
plot(w[,1],sapply(w[,2], function(x)gsub("%","",x)), # << per YBS solution Aug 27, 2021
main=x,
xlab=y,
ylab=z,
type="b",
col="blue",
pch=19,cex=1.25
) # close plot
} # close function
ui <-
pageWithSidebar(
headerPanel("Model..."),
sidebarPanel(
fluidRow(helpText(h5(strong("Base Input Panel")),align="center",
style="margin-top:-15px;margin-bottom:5px")),
# Panels rendered with uiOuput & renderUI in server to stop flashing at invocation
uiOutput("Panels")
), # close sidebar panel
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(
button2('showRatesValueBtn','Rates values'),
button2('showRatesPlotBtn','Rates plots'),
), # close fluid row
div(style = "margin-top: 5px"),
# Shows outputs on each page of main panel
uiOutput('showResults')),
id = "tabselected"
) # close tabset panel
) # close main panel
) # close page with sidebar
server <- function(input,output,session)({
base_input <- reactive(input$base_input)
showResults <- reactiveValues()
yield <- function(){vectorBase(60,input$base_input[1,1])} # Must remain in server section
# --- Conditional panels rendered here rather than in UI to eliminate invocation flashing ------------>
output$Panels <- renderUI({
tagList(
conditionalPanel(
condition="input.tabselected==4",
actionButton('modRates','Modify Rates and Coupons',
style='width:100%;background-color:LightGrey'
),
setShadow(id='modRates'),
div(style = "margin-bottom: 10px"),
), # close conditional panel
conditionalPanel(condition="input.tabselected==3"),
conditionalPanel(condition="input.tabselected==4")
) # close tagList
}) # close renderUI
# --- Below defines the vectorsAll object before user clicks on actionButton "Input Liabilities" ---->
vectorsAll <- reactive({
if (is.null(input$modRates)){df <- NULL}
else {
if(input$modRates < 1){df <- cbind(Period = 1:60,BaseRate = pct(0.2))} # define what you want to display by default
else {
req(input$base_input)
df <- cbind(Period = 1:60,BaseRate = pct(yield()[,2]))
} # close 2nd else
} # close 1st else
df
}) # close reactive
output$table1 <- renderTable({vectorsAll()})
# --- Below produces vector values after clicking "Vector Values" button; see above for pre-click ---->
observeEvent(input$showRatesValueBtn,
{showResults$showme <-
tagList(tableOutput("table1"))
},ignoreNULL = FALSE)
# --- Below produces vector plots -------------------------------------------------------------------->
output$graph1 <-renderPlot(vectorPlot(vectorsAll(),"A Variable","Period","Rate"))
observeEvent(input$showRatesPlotBtn,{showResults$showme <- plotOutput("graph1")})
# --- Below sends both vector plots and vector values to UI section above ---------------------------->
output$showResults <- renderUI({showResults$showme})
# --- Below for modal dialog inputs ------------------------------------------------------------------>
observeEvent(input$modRates,
{showModal(modalDialog(
matrix1Input("base_input", if(is.null(input$base_input)) mDefaults else input$base_input),
div(style = "margin-top: 0px"),
useShinyjs(),
) # close modalDialog
) # close showModal
} # close showModal function
) # close observeEvent
}) # close server
shinyApp(ui, server)
我添加了默认参数。当你的 table 存在时，我使用现有值而不是默认值。