【发布时间】：2021-12-20 14:16:27
【问题描述】：
在以下缩短的代码中，用户输入被“链接”在一系列 3 个用户输入矩阵中（也如下图所示）：
-
矩阵1：如果用户想运行一个粗略和快速的场景，用户将只输入矩阵1。一个变量，一个场景。
-
矩阵 2：如果用户想要运行更复杂的场景，用户可以选择将矩阵 1 输入到矩阵 2 中，并将矩阵 1 输入“下游”到矩阵 2 的第 1 行/第 2 列，以便为其播种。矩阵 2 垂直扩展以适应用于生成曲线的其他用户输入。
-
矩阵3：如果用户想要运行多个复杂的场景，用户可以选择输入矩阵3，矩阵3的场景1是矩阵2的下游镜像。矩阵3垂直和水平扩展，以适应用户输入+附加场景。
请注意，更完整的 App 会运行内推/外推计算以生成曲线。为简单起见，下面的代码运行一个简单（且无意义）的 sumProduct 代替。但计算不是本文的重点。
我已经使用observeEvent 成功地下游了以下用户输入：
-
observeEvent(input$matrix1...将用户输入从矩阵 1 传递到矩阵 2，并且 -
observeEvent(input$matrix2...将用户输入从矩阵 2 传输到矩阵 3 的场景 1，同时将所有输入保留到矩阵 3 中 > 1 的场景中。
我一直无法做的是让用户输入到矩阵 1 中，而不是删除那些用户输入到矩阵 3 场景 > 1 中，如底部的最后一张图片所示。我已经尝试了各种observeEvents，但没有运气。我应该改用observe 吗？矩阵 3 只是观察矩阵 2 发生了什么？关于如何做到这一点的任何想法？
当使用observeEvent(input$matrix2... 下显示的代码更改矩阵 2 时，我已经能够保留矩阵 3 场景 > 1 输入，但是当我尝试在observeEvent(input$matrix1... 下包含此类代码时，它不起作用。
代码如下：
library(dplyr)
library(ggplot2)
library(shiny)
library(shinyMatrix)
sumProd <- function(a, b) {
c <- rep(NA, a)
c[] <- sum(b[,1], na.rm = T) %*% sum(b[,2],na.rm = T)
return(c)
}
ui <- fluidPage(
sliderInput('periods', 'Modeled periods (X):', min=1, max=10, value=10),
matrixInput("matrix1",
value = matrix(c(5), nrow = 1, ncol = 1, dimnames = list("Base rate (Y)",NULL)),
cols = list(names = FALSE),
class = "numeric"),
matrixInput("matrix2",
value = matrix(c(10,5), nrow = 1, ncol = 2, dimnames = list(NULL,c("X","Y"))),
rows = list(extend = TRUE, delete = TRUE),
class = "numeric"),
matrixInput("matrix3",
value = matrix(c(10,5), ncol = 2, dimnames = list(NULL, rep("Scenario 1", 2))),
rows = list(extend = TRUE, delete = TRUE),
cols = list(extend = TRUE, delta = 2, delete = TRUE, multiheader = TRUE),
class = "numeric"),
plotOutput("plot")
)
server <- function(input, output, session){
observeEvent(input$matrix1, {
tmpMat2 <- c(input$matrix2[,1],input$matrix2[,2])
tmpMat2[length(input$matrix2)/2+1] <- input$matrix1[,1]
updateMatrixInput(session,inputId="matrix2",value=matrix(tmpMat2,ncol=2,dimnames=list(NULL,c("X","Y")))
)
})
observeEvent(input$matrix2, {
a <- apply(input$matrix3,2,'length<-',max(nrow(input$matrix3),nrow(input$matrix2)))
b <- apply(input$matrix2,2,'length<-',max(nrow(input$matrix3),nrow(input$matrix2)))
c <- if(length(a) == 2){c(b)} else {c(b,a[,-1:-2])}
d <- ncol(input$matrix3)
tmpMat3 <- matrix(c(c), ncol = d)
colnames(tmpMat3) <- paste("Scenario",rep(1:ncol(tmpMat3),each=2,length.out=ncol(tmpMat3)))
if(any(rownames(input$matrix2) == "")){
tmpMat3 <- input$matrix2
rownames(tmpMat3) <- paste("Row", seq_len(nrow(input$matrix2)))
isolate(updateMatrixInput(session, inputId = "matrix2", value = tmpMat3))
isolate(updateMatrixInput(session, inputId = "matrix3", value = tmpMat3))
}
input$matrix2
updateMatrixInput(session, inputId = "matrix3", value = tmpMat3
)
})
observeEvent(input$matrix3, {
if(any(colnames(input$matrix3) == "")){
tmpMat3 <- input$matrix3
colnames(tmpMat3) <- paste("Scenario",rep(1:ncol(tmpMat3),each=2,length.out=ncol(tmpMat3)))
isolate(updateMatrixInput(session, inputId = "matrix3", value = tmpMat3))
}
input$matrix3
})
plotData <- reactive({
tryCatch(
lapply(seq_len(ncol(input$matrix3)/2), # column counter to set matrix index as it expands
function(i){
tibble(
Scenario = colnames(input$matrix3)[i*2-1],
X = seq_len(input$periods),
Y = sumProd(input$periods,input$matrix3[,(i*2-1):(i*2), drop = FALSE])
)
}) %>% bind_rows(),
error = function(e) NULL
)
})
output$plot <- renderPlot({
req(plotData())
plotData() %>% ggplot() +
geom_line(aes(x = X, y = Y, colour = as.factor(Scenario))) +
theme(legend.title=element_blank())
})
}
shinyApp(ui, server)
以下图片展示了哪些有效，哪些无效：
【问题讨论】：
标签： r shiny observers shiny-reactivity