【发布时间】：2021-12-11 12:42:55
【问题描述】：
在下面的“简化”代码中，有一系列 3 个链接的用户输入矩阵。用户可以选择仅修改矩阵 1（在滑块输入周期 X 上给出值 Y 的直线输出）。用户可以通过将 X 和 Y 值输入到矩阵 2 中来选择将曲线添加到矩阵 1“Y”值，当用户添加输入时，矩阵会垂直扩展（添加行）。除了矩阵 2 中生成的第一条曲线外，用户还可以选择添加曲线场景，方法是将 X 和 Y 值输入到矩阵 3 中，该矩阵水平和垂直扩展。在绘图中，矩阵 3 优先于矩阵 2，矩阵 2 优先于矩阵 1。“曲线”是指插值/外推函数 (UDF interpol())。矩阵 1 馈入矩阵 2，矩阵 2 又馈入矩阵 3。这些下游馈送似乎工作正常，除非从矩阵 2 转到矩阵 3，如下所述。
运行下面的代码时，仅矩阵 1 的输入工作正常（如下面的第一张图片所示）。 Matrix 3-only 输入工作正常（如下图第三张所示）。但是 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)
【问题讨论】：
标签： r shiny shiny-reactivity