如何 运行 观察在模态对话框中呈现的对象的函数?
How to run an observe function for an object rendered in modal dialog?
进一步注意:取消注释 observe()
部分并在 input$periods
下方插入 req(input$matrix2)
似乎有效,除非用户在输入后更改 input$periods
进入 matrix2 在这种情况下 input$periods
限制被忽略。
在下面的代码中,我试图 运行 在 modalDialog()
中渲染的 matrix2 的注释掉 observe()
函数。 Observe()
应该在 input$periods 处限制 matrix2 左列中元素的值。我尝试将此 observe()
放在模态中,但没有用。当在没有 modalDialog()
的 UI
部分中呈现 matrix2 时,此 observe()
效果很好。但是我想在 modalDialog.Is 中使用 matrix2,有办法将 observe()
放在 modalDialog()
中吗?或者有其他方法可以 运行 这个 observe()
功能吗?
library(dplyr)
library(ggplot2)
library(shiny)
library(shinyMatrix)
interpol <- function(a, b) { # a = periods, b = matrix inputs
c <- rep(NA, a)
c[1] <- b[1]
c[a] <- b[2]
c <- approx(seq_along(c)[!is.na(c)], c[!is.na(c)], seq_along(c))$y # << interpolates
return(c)
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput('periods', 'Modeled periods (X variable):', min=1, max=10, value=10),
matrixInput("matrix1",
label = "Matrix 1",
value = matrix(c(5), ncol = 1, dimnames = list("Base rate",NULL)),
cols = list(names = FALSE),
class = "numeric"),
actionButton("matrix2show","Add scenarios (via Matrix 2)",width = "100%")
),
mainPanel(
plotOutput("plot")
)
)
)
server <- function(input, output, session){
# observe({
# input$periods
# tmpMat2 <- input$matrix2
# tmpMat2[,c(TRUE, FALSE)] <- apply(tmpMat2[,c(TRUE, FALSE),drop=FALSE], 2,
# function(x) pmin(x, input$periods))
# updateMatrixInput(session,
# inputId="matrix2",
# value=tmpMat2
# )
# })
observeEvent(input$matrix1, {
tmpMat2 <- c(input$matrix2[,1],input$matrix2[,2]) # convert to vector
tmpMat2[length(input$matrix2)/2+1] <- input$matrix1[,1] # drop matrix 1 value into row 1/col 2 of matrix 2
updateMatrixInput(session,
inputId="matrix2",
value=matrix(tmpMat2,ncol=2,dimnames=list(NULL,c("X","Y")))
)
})
observeEvent(input$matrix2show,{
showModal(
modalDialog(
matrixInput("matrix2",
label = "Matrix 2 (will link to Matrix 1)",
value = if(is.null(input$matrix2)){
matrix(c(10,5), ncol = 2, dimnames = list(NULL,c("X","Y")))}
else {input$matrix2},
rows = list(extend = TRUE, delete = TRUE),
class = "numeric"),
footer = modalButton("Close")
))
})
plotData <- reactive({
tryCatch(
tibble(
X = seq_len(input$periods),
Y = if(isTruthy(input$matrix2)){interpol(input$periods,input$matrix2)}
else {input$matrix1}
),
error = function(e) NULL
)
})
output$plot <- renderPlot({
req(plotData())
plotData() %>% ggplot() +
geom_line(aes(x = X, y = Y)) +
theme(legend.title=element_blank())
})
}
shinyApp(ui, server)
您需要确保 input$matrix2
不为 NULL。这可以做到,例如使用 req
:
library(dplyr)
library(ggplot2)
library(shiny)
library(shinyMatrix)
interpol <- function(a, b) { # a = periods, b = matrix inputs
c <- rep(NA, a)
c[1] <- b[1]
c[a] <- b[2]
c <- approx(seq_along(c)[!is.na(c)], c[!is.na(c)], seq_along(c))$y # << interpolates
return(c)
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput('periods', 'Modeled periods (X variable):', min=1, max=10, value=10),
matrixInput("matrix1",
label = "Matrix 1",
value = matrix(c(5), ncol = 1, dimnames = list("Base rate",NULL)),
cols = list(names = FALSE),
class = "numeric"),
actionButton("matrix2show","Add scenarios (via Matrix 2)",width = "100%")
),
mainPanel(
plotOutput("plot")
)
)
)
server <- function(input, output, session){
observeEvent(c(input$matrix2show, input$matrix2), {
tmpMat2 <- req(input$matrix2)
tmpMat2[,c(TRUE, FALSE)] <- apply(tmpMat2[,c(TRUE, FALSE), drop=FALSE], 2,
function(x) pmin(x, input$periods))
updateMatrixInput(session,
inputId="matrix2",
value=tmpMat2
)
})
observeEvent(input$matrix1, {
tmpMat2 <- c(input$matrix2[,1],input$matrix2[,2]) # convert to vector
tmpMat2[length(input$matrix2)/2+1] <- input$matrix1[,1] # drop matrix 1 value into row 1/col 2 of matrix 2
updateMatrixInput(session,
inputId="matrix2",
value=matrix(tmpMat2,ncol=2,dimnames=list(NULL,c("X","Y")))
)
})
observeEvent(input$matrix2show,{
showModal(
modalDialog(
matrixInput("matrix2",
label = "Matrix 2 (will link to Matrix 1)",
value = if(is.null(input$matrix2)){
matrix(c(10,5), ncol = 2, dimnames = list(NULL,c("X","Y")))}
else {input$matrix2},
rows = list(extend = TRUE, delete = TRUE),
class = "numeric"),
footer = modalButton("Close")
))
})
plotData <- reactive({
tryCatch(
tibble(
X = seq_len(input$periods),
Y = if(isTruthy(input$matrix2)){interpol(input$periods,input$matrix2)}
else {input$matrix1}
),
error = function(e) NULL
)
})
output$plot <- renderPlot({
req(plotData())
plotData() %>% ggplot() +
geom_line(aes(x = X, y = Y)) +
theme(legend.title=element_blank())
})
}
shinyApp(ui, server)
进一步注意:取消注释 observe()
部分并在 input$periods
下方插入 req(input$matrix2)
似乎有效,除非用户在输入后更改 input$periods
进入 matrix2 在这种情况下 input$periods
限制被忽略。
在下面的代码中,我试图 运行 在 modalDialog()
中渲染的 matrix2 的注释掉 observe()
函数。 Observe()
应该在 input$periods 处限制 matrix2 左列中元素的值。我尝试将此 observe()
放在模态中,但没有用。当在没有 modalDialog()
的 UI
部分中呈现 matrix2 时,此 observe()
效果很好。但是我想在 modalDialog.Is 中使用 matrix2,有办法将 observe()
放在 modalDialog()
中吗?或者有其他方法可以 运行 这个 observe()
功能吗?
library(dplyr)
library(ggplot2)
library(shiny)
library(shinyMatrix)
interpol <- function(a, b) { # a = periods, b = matrix inputs
c <- rep(NA, a)
c[1] <- b[1]
c[a] <- b[2]
c <- approx(seq_along(c)[!is.na(c)], c[!is.na(c)], seq_along(c))$y # << interpolates
return(c)
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput('periods', 'Modeled periods (X variable):', min=1, max=10, value=10),
matrixInput("matrix1",
label = "Matrix 1",
value = matrix(c(5), ncol = 1, dimnames = list("Base rate",NULL)),
cols = list(names = FALSE),
class = "numeric"),
actionButton("matrix2show","Add scenarios (via Matrix 2)",width = "100%")
),
mainPanel(
plotOutput("plot")
)
)
)
server <- function(input, output, session){
# observe({
# input$periods
# tmpMat2 <- input$matrix2
# tmpMat2[,c(TRUE, FALSE)] <- apply(tmpMat2[,c(TRUE, FALSE),drop=FALSE], 2,
# function(x) pmin(x, input$periods))
# updateMatrixInput(session,
# inputId="matrix2",
# value=tmpMat2
# )
# })
observeEvent(input$matrix1, {
tmpMat2 <- c(input$matrix2[,1],input$matrix2[,2]) # convert to vector
tmpMat2[length(input$matrix2)/2+1] <- input$matrix1[,1] # drop matrix 1 value into row 1/col 2 of matrix 2
updateMatrixInput(session,
inputId="matrix2",
value=matrix(tmpMat2,ncol=2,dimnames=list(NULL,c("X","Y")))
)
})
observeEvent(input$matrix2show,{
showModal(
modalDialog(
matrixInput("matrix2",
label = "Matrix 2 (will link to Matrix 1)",
value = if(is.null(input$matrix2)){
matrix(c(10,5), ncol = 2, dimnames = list(NULL,c("X","Y")))}
else {input$matrix2},
rows = list(extend = TRUE, delete = TRUE),
class = "numeric"),
footer = modalButton("Close")
))
})
plotData <- reactive({
tryCatch(
tibble(
X = seq_len(input$periods),
Y = if(isTruthy(input$matrix2)){interpol(input$periods,input$matrix2)}
else {input$matrix1}
),
error = function(e) NULL
)
})
output$plot <- renderPlot({
req(plotData())
plotData() %>% ggplot() +
geom_line(aes(x = X, y = Y)) +
theme(legend.title=element_blank())
})
}
shinyApp(ui, server)
您需要确保 input$matrix2
不为 NULL。这可以做到,例如使用 req
:
library(dplyr)
library(ggplot2)
library(shiny)
library(shinyMatrix)
interpol <- function(a, b) { # a = periods, b = matrix inputs
c <- rep(NA, a)
c[1] <- b[1]
c[a] <- b[2]
c <- approx(seq_along(c)[!is.na(c)], c[!is.na(c)], seq_along(c))$y # << interpolates
return(c)
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput('periods', 'Modeled periods (X variable):', min=1, max=10, value=10),
matrixInput("matrix1",
label = "Matrix 1",
value = matrix(c(5), ncol = 1, dimnames = list("Base rate",NULL)),
cols = list(names = FALSE),
class = "numeric"),
actionButton("matrix2show","Add scenarios (via Matrix 2)",width = "100%")
),
mainPanel(
plotOutput("plot")
)
)
)
server <- function(input, output, session){
observeEvent(c(input$matrix2show, input$matrix2), {
tmpMat2 <- req(input$matrix2)
tmpMat2[,c(TRUE, FALSE)] <- apply(tmpMat2[,c(TRUE, FALSE), drop=FALSE], 2,
function(x) pmin(x, input$periods))
updateMatrixInput(session,
inputId="matrix2",
value=tmpMat2
)
})
observeEvent(input$matrix1, {
tmpMat2 <- c(input$matrix2[,1],input$matrix2[,2]) # convert to vector
tmpMat2[length(input$matrix2)/2+1] <- input$matrix1[,1] # drop matrix 1 value into row 1/col 2 of matrix 2
updateMatrixInput(session,
inputId="matrix2",
value=matrix(tmpMat2,ncol=2,dimnames=list(NULL,c("X","Y")))
)
})
observeEvent(input$matrix2show,{
showModal(
modalDialog(
matrixInput("matrix2",
label = "Matrix 2 (will link to Matrix 1)",
value = if(is.null(input$matrix2)){
matrix(c(10,5), ncol = 2, dimnames = list(NULL,c("X","Y")))}
else {input$matrix2},
rows = list(extend = TRUE, delete = TRUE),
class = "numeric"),
footer = modalButton("Close")
))
})
plotData <- reactive({
tryCatch(
tibble(
X = seq_len(input$periods),
Y = if(isTruthy(input$matrix2)){interpol(input$periods,input$matrix2)}
else {input$matrix1}
),
error = function(e) NULL
)
})
output$plot <- renderPlot({
req(plotData())
plotData() %>% ggplot() +
geom_line(aes(x = X, y = Y)) +
theme(legend.title=element_blank())
})
}
shinyApp(ui, server)