在 R Shiny 中，如何为一系列链接矩阵输入建立反应链？
In R Shiny, how to establish a reactivity chain for a series of linked matrix inputs?
在下面的“简化”代码中，有一系列 3 个链接的用户输入矩阵。用户可以选择仅修改矩阵 1（在滑块输入周期 X 内给出直线输出，值为 Y）。用户可以选择通过将 X 和 Y 值输入矩阵 2 来向矩阵 1“Y”值添加曲线，随着用户添加输入，矩阵会垂直扩展（添加行）。除了 Matrix 2 中生成的第一条曲线之外，用户还可以选择添加曲线场景，方法是将 X 和 Y 值输入到 Matrix 3 中，该矩阵在水平和垂直方向上都展开。在绘图中，矩阵 3 优先于矩阵 2，矩阵 2 优先于矩阵 1。“曲线”是指 interpolation/extrapolation 函数 (UDF interpol())。 Matrix 1 馈入 Matrix 2，后者又馈入 Matrix 3。这些下游馈送似乎工作正常，除非如下所述从 Matrix 2 转到 Matrix 3。
当 运行 下面时，矩阵 1-only 输入工作正常（如下面第一张图所示）。仅矩阵 3 输入工作正常（如下面第三张图片所示）。但是 Matrix 2 输入不能正常工作：正如您在下面的第二张图片中看到的，Matrix 2 输入不能正确地下游到 Matrix 3。
我做错了什么？
代码：
library(ggplot2)
library(shiny)
library(shinyMatrix)
interpol <- function(a, b) { # [a] = modeled periods, [b] = matrix inputs
c <- b
c[,1][c[,1] > a] <- a
d <- diff(c[,1, drop = FALSE])
d[d <= 0] <- NA
d <- c(1,d)
c <- cbind(c,d)
c <- na.omit(c)
c <- c[,-c(3),drop=FALSE]
e <- rep(NA, a)
e[c[,1]] <- c[,2]
e[seq_len(min(c[,1])-1)] <- e[min(c[,1])]
if(max(c[,1]) < a){e[seq(max(c[,1]) + 1, a, 1)] <- 0}
e <- approx(seq_along(e)[!is.na(e)], e[!is.na(e)], seq_along(e))$y # Interpolates
return(e)
}
ui <- fluidPage(
uiOutput("slider"),
h5(strong("Matrix 1:")), uiOutput("mat1"),
h5(strong("Matrix 2:")), uiOutput("mat2"),
h5(strong("Matrix 3:")), uiOutput("mat3"),
plotOutput("plot")
)
server <- function(input, output, session){
output$slider <- renderUI({sliderInput('periods', 'Modeled periods (X):', min=1, max=10, value=10)})
output$mat1 <- renderUI({
matrixInput("matrix1",
value = matrix(c(5), 1, 1, dimnames = list("Base rate (Y)",NULL)),
rows = list(extend = FALSE, names = TRUE),
cols = list(names = FALSE),
class = "numeric")
})
output$mat2 <- renderUI({
matrixInput("matrix2",
value = matrix(c(input$periods, input$matrix1[1,1]), 1, 2, dimnames = list(NULL,c("X","Y"))),
rows = list(extend = TRUE, names = TRUE, delete = TRUE),
class = "numeric")
})
output$mat3 <- renderUI({
matrixInput("matrix3",
value = matrix(c(input$matrix2[,1], input$matrix2[,2]), 1, 2, dimnames = list(NULL, rep("Scenario 1", 2))),
rows = list(extend = TRUE, delta = 1, names = TRUE, delete = TRUE),
cols = list(extend = TRUE, delta = 2, names = TRUE, delete = TRUE, multiheader = TRUE),
class = "numeric")
})
observeEvent(input$matrix2, {
if(any(rownames(input$matrix2) == "")){
tmpMatrix <- input$matrix2
rownames(tmpMatrix) <- paste("Row", seq_len(nrow(input$matrix2)))
isolate(updateMatrixInput(session, inputId = "matrix2", value = tmpMatrix))
}
input$matrix2
})
observeEvent(input$matrix3, {
if(any(colnames(input$matrix3) == "")){
tmpMatrix <- input$matrix3
colnames(tmpMatrix) <- paste("Scenario",rep(1:ncol(tmpMatrix),each=2,length.out=ncol(tmpMatrix)))
isolate(updateMatrixInput(session, inputId = "matrix3", value = tmpMatrix))
}
input$matrix3
})
plotData <- reactive({
req(input$periods)
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 = interpol(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)
替代代码，不使用 renderUI 而是依赖 observeEvent 嵌入 updateMatrixInput:
ui <- fluidPage(
sliderInput('periods', 'Modeled periods (X):', min=1, max=10, value=10),
h5(strong("Matrix 1 is omitted for MWE")),
h5(strong("Matrix 2:")),
matrixInput("matrix2",
value = matrix(c(10, 5), 1, 2, dimnames = list(NULL,c("X","Y"))),
rows = list(extend = TRUE, names = TRUE, delete = TRUE),
class = "numeric"),
h5(strong("Matrix 3:")),
matrixInput("matrix3",
value = matrix(c(10,5), ncol = 2, dimnames = list(NULL, rep("Scenario 1", 2))),
rows = list(extend = TRUE, delta = 1, names = TRUE, delete = TRUE),
cols = list(extend = TRUE, delta = 2, names = TRUE, delete = TRUE, multiheader = TRUE),
class = "numeric"),
plotOutput("plot")
)
server <- function(input, output, session){
observeEvent(input$periods, {
updateMatrixInput(session, inputId = "matrix2",
value = matrix(c(input$periods, 5), 1, 2, dimnames = list(NULL,c("X","Y"))))
})
observeEvent(input$matrix2, {
if(any(rownames(input$matrix2) == "")){
tmpMatrix <- input$matrix2
rownames(tmpMatrix) <- paste("Row", seq_len(nrow(input$matrix2)))
isolate(updateMatrixInput(session, inputId = "matrix2", value = tmpMatrix))
isolate(updateMatrixInput(session, inputId = "matrix3",
value = tmpMatrix))
}
input$matrix2
isolate(
updateMatrixInput(
session,
inputId = "matrix3",
value = matrix(
c(input$matrix2[,1],input$matrix2[,2]),
ncol = 2,
dimnames = list(NULL, rep("Scenario 1", 2)))
)
)
})
observeEvent(input$matrix3, {
if(any(colnames(input$matrix3) == "")){
tmpMatrix <- input$matrix3
colnames(tmpMatrix) <- paste("Scenario",rep(1:ncol(tmpMatrix),each=2,length.out=ncol(tmpMatrix)))
isolate(updateMatrixInput(session, inputId = "matrix3", value = tmpMatrix))
}
input$matrix3
})
plotData <- reactive({
req(input$periods)
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 = interpol(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)
在 renderUI 对 mat3 的调用中，您定义了 nrow = 1，每次重新渲染 matrixInput 时都会考虑到这一点。
您需要删除此参数以允许添加行。
正如您现在可能知道的那样，一般来说，我建议放弃那些 renderUI 电话。
我会在应用程序启动时渲染 matrixInputs 并通过 updateMatrixInput 修改它们 - 这样速度更快并且在 UI 和服务器之间保持清晰的分离。
library(ggplot2)
library(shiny)
library(shinyMatrix)
interpol <- function(a, b) { # [a] = modeled periods, [b] = matrix inputs
c <- b
c[,1][c[,1] > a] <- a
d <- diff(c[,1, drop = FALSE])
d[d <= 0] <- NA
d <- c(1,d)
c <- cbind(c,d)
c <- na.omit(c)
c <- c[,-c(3),drop=FALSE]
e <- rep(NA, a)
e[c[,1]] <- c[,2]
e[seq_len(min(c[,1])-1)] <- e[min(c[,1])]
if(max(c[,1]) < a){e[seq(max(c[,1]) + 1, a, 1)] <- 0}
e <- approx(seq_along(e)[!is.na(e)], e[!is.na(e)], seq_along(e))$y # Interpolates
return(e)
}
ui <- fluidPage(
uiOutput("slider"),
h5(strong("Matrix 1:")), uiOutput("mat1"),
h5(strong("Matrix 2:")), uiOutput("mat2"),
h5(strong("Matrix 3:")), uiOutput("mat3"),
plotOutput("plot")
)
server <- function(input, output, session){
output$slider <- renderUI({sliderInput('periods', 'Modeled periods (X):', min=1, max=10, value=10)})
output$mat1 <- renderUI({
matrixInput("matrix1",
value = matrix(c(5), 1, 1, dimnames = list("Base rate (Y)",NULL)),
rows = list(extend = FALSE, names = TRUE),
cols = list(names = FALSE),
class = "numeric")
})
output$mat2 <- renderUI({
req(input$periods)
req(input$matrix1)
matrixInput("matrix2",
value = matrix(c(input$periods, input$matrix1[1,1]), 1, 2, dimnames = list(NULL,c("X","Y"))),
rows = list(extend = TRUE, names = TRUE, delete = TRUE),
class = "numeric")
})
output$mat3 <- renderUI({
req(input$matrix2)
matrixInput("matrix3",
value = matrix(c(input$matrix2[,1], input$matrix2[,2]), ncol = 2, dimnames = list(NULL, rep("Scenario 1", 2))),
rows = list(extend = TRUE, delta = 1, names = TRUE, delete = TRUE),
cols = list(extend = TRUE, delta = 2, names = TRUE, delete = TRUE, multiheader = TRUE),
class = "numeric")
})
observeEvent(input$matrix2, {
if(any(rownames(input$matrix2) == "")){
tmpMatrix <- input$matrix2
rownames(tmpMatrix) <- paste("Row", seq_len(nrow(input$matrix2)))
isolate(updateMatrixInput(session, inputId = "matrix2", value = tmpMatrix))
}
input$matrix2
})
observeEvent(input$matrix3, {
if(any(colnames(input$matrix3) == "")){
tmpMatrix <- input$matrix3
colnames(tmpMatrix) <- paste("Scenario",rep(1:ncol(tmpMatrix),each=2,length.out=ncol(tmpMatrix)))
isolate(updateMatrixInput(session, inputId = "matrix3", value = tmpMatrix))
}
input$matrix3
})
plotData <- reactive({
req(input$periods)
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 = interpol(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（在滑块输入周期 X 内给出直线输出，值为 Y）。用户可以选择通过将 X 和 Y 值输入矩阵 2 来向矩阵 1“Y”值添加曲线，随着用户添加输入，矩阵会垂直扩展（添加行）。除了 Matrix 2 中生成的第一条曲线之外，用户还可以选择添加曲线场景，方法是将 X 和 Y 值输入到 Matrix 3 中，该矩阵在水平和垂直方向上都展开。在绘图中，矩阵 3 优先于矩阵 2，矩阵 2 优先于矩阵 1。“曲线”是指 interpolation/extrapolation 函数 (UDF interpol())。 Matrix 1 馈入 Matrix 2，后者又馈入 Matrix 3。这些下游馈送似乎工作正常，除非如下所述从 Matrix 2 转到 Matrix 3。
当 运行 下面时，矩阵 1-only 输入工作正常（如下面第一张图所示）。仅矩阵 3 输入工作正常（如下面第三张图片所示）。但是 Matrix 2 输入不能正常工作：正如您在下面的第二张图片中看到的，Matrix 2 输入不能正确地下游到 Matrix 3。
我做错了什么？
代码：
library(ggplot2)
library(shiny)
library(shinyMatrix)
interpol <- function(a, b) { # [a] = modeled periods, [b] = matrix inputs
c <- b
c[,1][c[,1] > a] <- a
d <- diff(c[,1, drop = FALSE])
d[d <= 0] <- NA
d <- c(1,d)
c <- cbind(c,d)
c <- na.omit(c)
c <- c[,-c(3),drop=FALSE]
e <- rep(NA, a)
e[c[,1]] <- c[,2]
e[seq_len(min(c[,1])-1)] <- e[min(c[,1])]
if(max(c[,1]) < a){e[seq(max(c[,1]) + 1, a, 1)] <- 0}
e <- approx(seq_along(e)[!is.na(e)], e[!is.na(e)], seq_along(e))$y # Interpolates
return(e)
}
ui <- fluidPage(
uiOutput("slider"),
h5(strong("Matrix 1:")), uiOutput("mat1"),
h5(strong("Matrix 2:")), uiOutput("mat2"),
h5(strong("Matrix 3:")), uiOutput("mat3"),
plotOutput("plot")
)
server <- function(input, output, session){
output$slider <- renderUI({sliderInput('periods', 'Modeled periods (X):', min=1, max=10, value=10)})
output$mat1 <- renderUI({
matrixInput("matrix1",
value = matrix(c(5), 1, 1, dimnames = list("Base rate (Y)",NULL)),
rows = list(extend = FALSE, names = TRUE),
cols = list(names = FALSE),
class = "numeric")
})
output$mat2 <- renderUI({
matrixInput("matrix2",
value = matrix(c(input$periods, input$matrix1[1,1]), 1, 2, dimnames = list(NULL,c("X","Y"))),
rows = list(extend = TRUE, names = TRUE, delete = TRUE),
class = "numeric")
})
output$mat3 <- renderUI({
matrixInput("matrix3",
value = matrix(c(input$matrix2[,1], input$matrix2[,2]), 1, 2, dimnames = list(NULL, rep("Scenario 1", 2))),
rows = list(extend = TRUE, delta = 1, names = TRUE, delete = TRUE),
cols = list(extend = TRUE, delta = 2, names = TRUE, delete = TRUE, multiheader = TRUE),
class = "numeric")
})
observeEvent(input$matrix2, {
if(any(rownames(input$matrix2) == "")){
tmpMatrix <- input$matrix2
rownames(tmpMatrix) <- paste("Row", seq_len(nrow(input$matrix2)))
isolate(updateMatrixInput(session, inputId = "matrix2", value = tmpMatrix))
}
input$matrix2
})
observeEvent(input$matrix3, {
if(any(colnames(input$matrix3) == "")){
tmpMatrix <- input$matrix3
colnames(tmpMatrix) <- paste("Scenario",rep(1:ncol(tmpMatrix),each=2,length.out=ncol(tmpMatrix)))
isolate(updateMatrixInput(session, inputId = "matrix3", value = tmpMatrix))
}
input$matrix3
})
plotData <- reactive({
req(input$periods)
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 = interpol(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)
替代代码，不使用 renderUI 而是依赖 observeEvent 嵌入 updateMatrixInput:
ui <- fluidPage(
sliderInput('periods', 'Modeled periods (X):', min=1, max=10, value=10),
h5(strong("Matrix 1 is omitted for MWE")),
h5(strong("Matrix 2:")),
matrixInput("matrix2",
value = matrix(c(10, 5), 1, 2, dimnames = list(NULL,c("X","Y"))),
rows = list(extend = TRUE, names = TRUE, delete = TRUE),
class = "numeric"),
h5(strong("Matrix 3:")),
matrixInput("matrix3",
value = matrix(c(10,5), ncol = 2, dimnames = list(NULL, rep("Scenario 1", 2))),
rows = list(extend = TRUE, delta = 1, names = TRUE, delete = TRUE),
cols = list(extend = TRUE, delta = 2, names = TRUE, delete = TRUE, multiheader = TRUE),
class = "numeric"),
plotOutput("plot")
)
server <- function(input, output, session){
observeEvent(input$periods, {
updateMatrixInput(session, inputId = "matrix2",
value = matrix(c(input$periods, 5), 1, 2, dimnames = list(NULL,c("X","Y"))))
})
observeEvent(input$matrix2, {
if(any(rownames(input$matrix2) == "")){
tmpMatrix <- input$matrix2
rownames(tmpMatrix) <- paste("Row", seq_len(nrow(input$matrix2)))
isolate(updateMatrixInput(session, inputId = "matrix2", value = tmpMatrix))
isolate(updateMatrixInput(session, inputId = "matrix3",
value = tmpMatrix))
}
input$matrix2
isolate(
updateMatrixInput(
session,
inputId = "matrix3",
value = matrix(
c(input$matrix2[,1],input$matrix2[,2]),
ncol = 2,
dimnames = list(NULL, rep("Scenario 1", 2)))
)
)
})
observeEvent(input$matrix3, {
if(any(colnames(input$matrix3) == "")){
tmpMatrix <- input$matrix3
colnames(tmpMatrix) <- paste("Scenario",rep(1:ncol(tmpMatrix),each=2,length.out=ncol(tmpMatrix)))
isolate(updateMatrixInput(session, inputId = "matrix3", value = tmpMatrix))
}
input$matrix3
})
plotData <- reactive({
req(input$periods)
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 = interpol(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)
在 renderUI 对 mat3 的调用中，您定义了 nrow = 1，每次重新渲染 matrixInput 时都会考虑到这一点。
您需要删除此参数以允许添加行。
正如您现在可能知道的那样，一般来说，我建议放弃那些 renderUI 电话。
我会在应用程序启动时渲染 matrixInputs 并通过 updateMatrixInput 修改它们 - 这样速度更快并且在 UI 和服务器之间保持清晰的分离。
library(ggplot2)
library(shiny)
library(shinyMatrix)
interpol <- function(a, b) { # [a] = modeled periods, [b] = matrix inputs
c <- b
c[,1][c[,1] > a] <- a
d <- diff(c[,1, drop = FALSE])
d[d <= 0] <- NA
d <- c(1,d)
c <- cbind(c,d)
c <- na.omit(c)
c <- c[,-c(3),drop=FALSE]
e <- rep(NA, a)
e[c[,1]] <- c[,2]
e[seq_len(min(c[,1])-1)] <- e[min(c[,1])]
if(max(c[,1]) < a){e[seq(max(c[,1]) + 1, a, 1)] <- 0}
e <- approx(seq_along(e)[!is.na(e)], e[!is.na(e)], seq_along(e))$y # Interpolates
return(e)
}
ui <- fluidPage(
uiOutput("slider"),
h5(strong("Matrix 1:")), uiOutput("mat1"),
h5(strong("Matrix 2:")), uiOutput("mat2"),
h5(strong("Matrix 3:")), uiOutput("mat3"),
plotOutput("plot")
)
server <- function(input, output, session){
output$slider <- renderUI({sliderInput('periods', 'Modeled periods (X):', min=1, max=10, value=10)})
output$mat1 <- renderUI({
matrixInput("matrix1",
value = matrix(c(5), 1, 1, dimnames = list("Base rate (Y)",NULL)),
rows = list(extend = FALSE, names = TRUE),
cols = list(names = FALSE),
class = "numeric")
})
output$mat2 <- renderUI({
req(input$periods)
req(input$matrix1)
matrixInput("matrix2",
value = matrix(c(input$periods, input$matrix1[1,1]), 1, 2, dimnames = list(NULL,c("X","Y"))),
rows = list(extend = TRUE, names = TRUE, delete = TRUE),
class = "numeric")
})
output$mat3 <- renderUI({
req(input$matrix2)
matrixInput("matrix3",
value = matrix(c(input$matrix2[,1], input$matrix2[,2]), ncol = 2, dimnames = list(NULL, rep("Scenario 1", 2))),
rows = list(extend = TRUE, delta = 1, names = TRUE, delete = TRUE),
cols = list(extend = TRUE, delta = 2, names = TRUE, delete = TRUE, multiheader = TRUE),
class = "numeric")
})
observeEvent(input$matrix2, {
if(any(rownames(input$matrix2) == "")){
tmpMatrix <- input$matrix2
rownames(tmpMatrix) <- paste("Row", seq_len(nrow(input$matrix2)))
isolate(updateMatrixInput(session, inputId = "matrix2", value = tmpMatrix))
}
input$matrix2
})
observeEvent(input$matrix3, {
if(any(colnames(input$matrix3) == "")){
tmpMatrix <- input$matrix3
colnames(tmpMatrix) <- paste("Scenario",rep(1:ncol(tmpMatrix),each=2,length.out=ncol(tmpMatrix)))
isolate(updateMatrixInput(session, inputId = "matrix3", value = tmpMatrix))
}
input$matrix3
})
plotData <- reactive({
req(input$periods)
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 = interpol(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)