在 R Shiny 中,如何响应 link 一系列可扩展的用户输入矩阵?
In R Shiny, how to reactively link a series of expandable user input matrices?
在下面的缩短代码中,用户输入“链接”在一系列 3 个用户输入矩阵中(也在下图中说明):
矩阵 1:如果用户想要 运行 粗略快速的场景,用户只需输入矩阵 1。一个变量,只有一种情况。
矩阵 2:如果用户想要 运行 更复杂的场景,用户可以选择输入矩阵 2,矩阵 1 输入“下游”到矩阵的第 1 行/第 2 列2 为了播种它。矩阵 2 垂直扩展以容纳用于生成曲线的额外用户输入。
矩阵 3:如果用户想要 运行 多个复杂场景,用户可以选择输入矩阵 3,矩阵 3 的场景 1 是矩阵 2 的下游镜像反射。矩阵 3垂直和水平扩展,以适应用户输入 + 其他场景。
注意更完整的App 运行s inter/extrapolation 生成曲线的计算。为了简单起见,下面的代码 运行 是一个简单的(无意义的)sumProduct。但是计算不是这个post.
的重点
我已经使用 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)
以下图片显示了哪些有效,哪些无效:
不,简单的 observe
不能解决问题。继续使用 observeEvent
。最初发布的代码存在错误,在 observeEvent(input$matrix2, {...
下的 server
部分开始 if(any(rownames(input$matrix2) == "")){...
,其中矩阵 2 和矩阵 3 都已更新。在矩阵 2 输入的 observeEvent
下的本节中不应更新矩阵 3,其中为矩阵 2 添加了行标签。在下面解析的代码中,查看 rownames
函数如何移动到对于矩阵 3 的任何输入更改,单独 observeEvent
。通过此修复,代码现在可以正常工作。
解析代码:
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]) # 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$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) == "")){
tmpMat2 <- input$matrix2
rownames(tmpMat2) <- paste("Row", seq_len(nrow(input$matrix2)))
updateMatrixInput(session, inputId = "matrix2", value = tmpMat2)
}
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)))
updateMatrixInput(session, inputId = "matrix3", value = tmpMat3)
}
if(any(rownames(input$matrix3) == "")){
tmpMat3 <- input$matrix3
rownames(tmpMat3) <- paste("Row", seq_len(nrow(input$matrix3)))
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)
在下面的缩短代码中,用户输入“链接”在一系列 3 个用户输入矩阵中(也在下图中说明):
矩阵 1:如果用户想要 运行 粗略快速的场景,用户只需输入矩阵 1。一个变量,只有一种情况。
矩阵 2:如果用户想要 运行 更复杂的场景,用户可以选择输入矩阵 2,矩阵 1 输入“下游”到矩阵的第 1 行/第 2 列2 为了播种它。矩阵 2 垂直扩展以容纳用于生成曲线的额外用户输入。
矩阵 3:如果用户想要 运行 多个复杂场景,用户可以选择输入矩阵 3,矩阵 3 的场景 1 是矩阵 2 的下游镜像反射。矩阵 3垂直和水平扩展,以适应用户输入 + 其他场景。
注意更完整的App 运行s inter/extrapolation 生成曲线的计算。为了简单起见,下面的代码 运行 是一个简单的(无意义的)sumProduct。但是计算不是这个post.
的重点我已经使用 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)
以下图片显示了哪些有效,哪些无效:
不,简单的 observe
不能解决问题。继续使用 observeEvent
。最初发布的代码存在错误,在 observeEvent(input$matrix2, {...
下的 server
部分开始 if(any(rownames(input$matrix2) == "")){...
,其中矩阵 2 和矩阵 3 都已更新。在矩阵 2 输入的 observeEvent
下的本节中不应更新矩阵 3,其中为矩阵 2 添加了行标签。在下面解析的代码中,查看 rownames
函数如何移动到对于矩阵 3 的任何输入更改,单独 observeEvent
。通过此修复,代码现在可以正常工作。
解析代码:
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]) # 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$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) == "")){
tmpMat2 <- input$matrix2
rownames(tmpMat2) <- paste("Row", seq_len(nrow(input$matrix2)))
updateMatrixInput(session, inputId = "matrix2", value = tmpMat2)
}
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)))
updateMatrixInput(session, inputId = "matrix3", value = tmpMat3)
}
if(any(rownames(input$matrix3) == "")){
tmpMat3 <- input$matrix3
rownames(tmpMat3) <- paste("Row", seq_len(nrow(input$matrix3)))
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)