在 R Shiny 中，如何翻转函数以便它从 left-right 而不是 up-down 读取矩阵？
In R Shiny, how to flip a function around so it reads a matrix from left-right instead of up-down?
下面的三张图片有助于解释。 MWE 代码 1 反应性地插入用户输入值，如第一张图片所示，但用户输入矩阵需要在两个值的对中水平向右扩展以插入而不是垂直（向下）扩展目前在 MWE 代码 1 中使用。具有两个值的输入对的水平扩展矩阵显示在第二张图片及其下面 MWE 代码 2 中的代码中。 MWE 代码 2 并不像 MWE 代码 1 那样完全起作用，但它说明了所需的 horizontally-expanding 值对矩阵中的两个。
请注意在 MWE 代码 2 中，要插值的两个输入变量如何“配对”或分组在标记为“场景 1”、“场景 2”等的单个列标题下.. 这种配对是必要的。 MWE 代码 2 中显示了沿矩阵水平扩展为两列分组的公式，其中 trunc(1:ncol(mm)/2)+1.
如何修改 MWE 代码 1 使其像 MWE 代码 2 一样水平扩展，而不是像目前那样垂直扩展？
很容易更改 matrixInput 函数的参数以重新定向其扩展和配对，如 MWE 代码 2 中所做的那样；棘手的部分是修改矩阵的功能，特别是在 plotData <- reactive({… 开始的部分中使用 lapply... 等 MWE 代码 1.
MWE 代码 1：
library(shiny)
library(shinyMatrix)
library(dplyr)
library(ggplot2)
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 # this interpolates
return(c)
}
ui <- fluidPage(
sliderInput('periods','Periods to interpolate:',min=2,max=10,value=10),
matrixInput(
"myMatrixInput",
label = "Values to interpolate (myMatrixInput):",
value = matrix(c(1, 5), 1, 2, dimnames = list("Scenario 1", c("Value 1", "Value 2"))),
cols = list(extend = FALSE, names = TRUE, editableNames = FALSE),
rows = list(names = TRUE,delete = TRUE, extend = TRUE, delta = 1),
class = "numeric"),
plotOutput("plot")
)
server <- function(input, output, session) {
sanitizedMat <- reactiveVal()
observeEvent(input$myMatrixInput, {
if(any(rownames(input$myMatrixInput) == "")){
tmpMatrix <- input$myMatrixInput
rownames(tmpMatrix) <- paste("Scenario", seq_len(nrow(input$myMatrixInput)))
updateMatrixInput(session, inputId = "myMatrixInput", value = tmpMatrix)
}
sanitizedMat(na.omit(input$myMatrixInput))
})
plotData <- reactive({
req(dim(sanitizedMat())[1] >= 1)
lapply(seq_len(nrow(sanitizedMat())),
function(i){
tibble(
Scenario = rownames(sanitizedMat())[i],
X = 1:input$periods,
Y = interpol(input$periods, sanitizedMat()[i, 1:2])
)
}) %>% bind_rows()
})
output$plot <- renderPlot({
req(nrow(plotData()) > 0)
plotData() %>% ggplot() + geom_line(aes(
x = X,
y = Y,
colour = as.factor(Scenario)
))
})
}
shinyApp(ui, server)
MWE 代码 2（使用与上述相同的包和 interpol() 函数）：
ui <- fluidPage(
sliderInput('input1','Interpolate over periods (X):',min=2,max=12,value=6),
matrixInput("input2",
label = "Input into empty 2nd row cells to add interpolation scenario:",
value = matrix(c(1, 5), 1, 2, dimnames = list("Begin|end value", c("Scenario 1", ""))),
rows = list(names = TRUE),
cols = list(names = TRUE,
extend = TRUE,
delta = 2,
delete = TRUE,
multiheader=TRUE),
class = "numeric"),
actionButton("add","Add scenario"),
plotOutput("plot")
)
server <- function(input, output, session){
results <- function(){interpol(req(input$input1),req(input$input2))}
numScenarios <- reactiveValues(numS=1)
observeEvent(input$add,{numScenarios$numS <- (numScenarios$numS+1)})
observe({
req(input$input2)
mm <- input$input2
colnames(mm) <- paste("Scenario ", trunc(1:ncol(mm)/2)+1)
isolate(updateMatrixInput(session, "input2", mm))
})
output$plot <-renderPlot({
req(input$input1,input$input2)
v <- lapply(
1:numScenarios$numS,
function(i) tibble(Scenario=i,X=1:input$input1,Y=results())
) %>%
bind_rows()
v %>% ggplot() +
geom_line(aes(x=X, y=Y, colour=as.factor(Scenario))) +
geom_point(aes(x=X, y=Y))
})
}
shinyApp(ui, server)
参考2021年10月17日post，完全解决了问题并改进了以下代码，删除了删除输入时的一些错误：“How to automatically delete a matrix column in R if there otherwise would是下标越界错误？
对于麻烦的问题深表歉意。下面的代码提供了一个解决方案。希望这对社区中的新手有所帮助，他们可以看到可以使用公式使矩阵索引动态化。这打开了很多可能性。解决方案涉及：
- Re-orienting
matrixInput()规格如下图（本
是简单的部分）。另请注意 multiheader = TRUE 和 delta = 2 用于 matrixInput() 列规范，因此要插值的变量在每个场景标题下以 2 对的形式水平分组。
- 调整函数引用输入矩阵的矩阵索引，以便矩阵索引引用“动态地”以 2 列的步长水平跳过。例如，在下面的
plotData 函数中，请参阅 [i*2-1] 和 [1,(i*2-1):(i*2)] 的矩阵索引，以 2 的跳跃水平跳过矩阵。这部分对我来说有点棘手但是现在可以使用了。
代码：
library(shiny)
library(shinyMatrix)
library(dplyr)
library(ggplot2)
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(
sliderInput('periods','Periods to interpolate:',min=2,max=10,value=10),
matrixInput(
"myMatrixInput",
label = "Values to interpolate paired under each scenario heading:",
value = matrix(c(1, 5), 1, 2, dimnames = list(NULL, c("Scenario 1", "NULL"))),
cols = list(extend = TRUE, delta = 2, names = TRUE, delete = TRUE, multiheader = TRUE),
rows = list(extend = FALSE, delta = 1, names = FALSE, delete = FALSE),
class = "numeric"),
plotOutput("plot")
)
server <- function(input, output, session) {
sanitizedMat <- reactiveVal()
observeEvent(input$myMatrixInput, {
if(any(colnames(input$myMatrixInput) == "")){
tmpMatrix <- input$myMatrixInput
colnames(tmpMatrix) <- paste("Scenario", trunc(1:ncol(input$myMatrixInput)/2+1))
updateMatrixInput(session, inputId = "myMatrixInput", value = tmpMatrix)
}
sanitizedMat(na.omit(input$myMatrixInput))
})
plotData <- reactive({
lapply(seq_len(ncol(sanitizedMat())/2),
function(i){
tibble(
Scenario = colnames(sanitizedMat())[i*2-1],
X = 1:input$periods,
Y = interpol(input$periods, sanitizedMat()[1,(i*2-1):(i*2)])
)
}) %>% bind_rows()
})
output$plot <- renderPlot({
plotData() %>% ggplot() + geom_line(aes(
x = X,
y = Y,
colour = as.factor(Scenario)
))
})
}
shinyApp(ui, server)
下面的三张图片有助于解释。 MWE 代码 1 反应性地插入用户输入值，如第一张图片所示，但用户输入矩阵需要在两个值的对中水平向右扩展以插入而不是垂直（向下）扩展目前在 MWE 代码 1 中使用。具有两个值的输入对的水平扩展矩阵显示在第二张图片及其下面 MWE 代码 2 中的代码中。 MWE 代码 2 并不像 MWE 代码 1 那样完全起作用，但它说明了所需的 horizontally-expanding 值对矩阵中的两个。
请注意在 MWE 代码 2 中，要插值的两个输入变量如何“配对”或分组在标记为“场景 1”、“场景 2”等的单个列标题下.. 这种配对是必要的。 MWE 代码 2 中显示了沿矩阵水平扩展为两列分组的公式，其中 trunc(1:ncol(mm)/2)+1.
如何修改 MWE 代码 1 使其像 MWE 代码 2 一样水平扩展，而不是像目前那样垂直扩展？
很容易更改 matrixInput 函数的参数以重新定向其扩展和配对，如 MWE 代码 2 中所做的那样；棘手的部分是修改矩阵的功能，特别是在 plotData <- reactive({… 开始的部分中使用 lapply... 等 MWE 代码 1.
MWE 代码 1：
library(shiny)
library(shinyMatrix)
library(dplyr)
library(ggplot2)
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 # this interpolates
return(c)
}
ui <- fluidPage(
sliderInput('periods','Periods to interpolate:',min=2,max=10,value=10),
matrixInput(
"myMatrixInput",
label = "Values to interpolate (myMatrixInput):",
value = matrix(c(1, 5), 1, 2, dimnames = list("Scenario 1", c("Value 1", "Value 2"))),
cols = list(extend = FALSE, names = TRUE, editableNames = FALSE),
rows = list(names = TRUE,delete = TRUE, extend = TRUE, delta = 1),
class = "numeric"),
plotOutput("plot")
)
server <- function(input, output, session) {
sanitizedMat <- reactiveVal()
observeEvent(input$myMatrixInput, {
if(any(rownames(input$myMatrixInput) == "")){
tmpMatrix <- input$myMatrixInput
rownames(tmpMatrix) <- paste("Scenario", seq_len(nrow(input$myMatrixInput)))
updateMatrixInput(session, inputId = "myMatrixInput", value = tmpMatrix)
}
sanitizedMat(na.omit(input$myMatrixInput))
})
plotData <- reactive({
req(dim(sanitizedMat())[1] >= 1)
lapply(seq_len(nrow(sanitizedMat())),
function(i){
tibble(
Scenario = rownames(sanitizedMat())[i],
X = 1:input$periods,
Y = interpol(input$periods, sanitizedMat()[i, 1:2])
)
}) %>% bind_rows()
})
output$plot <- renderPlot({
req(nrow(plotData()) > 0)
plotData() %>% ggplot() + geom_line(aes(
x = X,
y = Y,
colour = as.factor(Scenario)
))
})
}
shinyApp(ui, server)
MWE 代码 2（使用与上述相同的包和 interpol() 函数）：
ui <- fluidPage(
sliderInput('input1','Interpolate over periods (X):',min=2,max=12,value=6),
matrixInput("input2",
label = "Input into empty 2nd row cells to add interpolation scenario:",
value = matrix(c(1, 5), 1, 2, dimnames = list("Begin|end value", c("Scenario 1", ""))),
rows = list(names = TRUE),
cols = list(names = TRUE,
extend = TRUE,
delta = 2,
delete = TRUE,
multiheader=TRUE),
class = "numeric"),
actionButton("add","Add scenario"),
plotOutput("plot")
)
server <- function(input, output, session){
results <- function(){interpol(req(input$input1),req(input$input2))}
numScenarios <- reactiveValues(numS=1)
observeEvent(input$add,{numScenarios$numS <- (numScenarios$numS+1)})
observe({
req(input$input2)
mm <- input$input2
colnames(mm) <- paste("Scenario ", trunc(1:ncol(mm)/2)+1)
isolate(updateMatrixInput(session, "input2", mm))
})
output$plot <-renderPlot({
req(input$input1,input$input2)
v <- lapply(
1:numScenarios$numS,
function(i) tibble(Scenario=i,X=1:input$input1,Y=results())
) %>%
bind_rows()
v %>% ggplot() +
geom_line(aes(x=X, y=Y, colour=as.factor(Scenario))) +
geom_point(aes(x=X, y=Y))
})
}
shinyApp(ui, server)
参考2021年10月17日post，完全解决了问题并改进了以下代码，删除了删除输入时的一些错误：“How to automatically delete a matrix column in R if there otherwise would是下标越界错误？
对于麻烦的问题深表歉意。下面的代码提供了一个解决方案。希望这对社区中的新手有所帮助，他们可以看到可以使用公式使矩阵索引动态化。这打开了很多可能性。解决方案涉及：
- Re-orienting
matrixInput()规格如下图（本 是简单的部分）。另请注意multiheader = TRUE和delta = 2用于matrixInput()列规范，因此要插值的变量在每个场景标题下以 2 对的形式水平分组。 - 调整函数引用输入矩阵的矩阵索引，以便矩阵索引引用“动态地”以 2 列的步长水平跳过。例如，在下面的
plotData函数中，请参阅[i*2-1]和[1,(i*2-1):(i*2)]的矩阵索引，以 2 的跳跃水平跳过矩阵。这部分对我来说有点棘手但是现在可以使用了。
代码：
library(shiny)
library(shinyMatrix)
library(dplyr)
library(ggplot2)
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(
sliderInput('periods','Periods to interpolate:',min=2,max=10,value=10),
matrixInput(
"myMatrixInput",
label = "Values to interpolate paired under each scenario heading:",
value = matrix(c(1, 5), 1, 2, dimnames = list(NULL, c("Scenario 1", "NULL"))),
cols = list(extend = TRUE, delta = 2, names = TRUE, delete = TRUE, multiheader = TRUE),
rows = list(extend = FALSE, delta = 1, names = FALSE, delete = FALSE),
class = "numeric"),
plotOutput("plot")
)
server <- function(input, output, session) {
sanitizedMat <- reactiveVal()
observeEvent(input$myMatrixInput, {
if(any(colnames(input$myMatrixInput) == "")){
tmpMatrix <- input$myMatrixInput
colnames(tmpMatrix) <- paste("Scenario", trunc(1:ncol(input$myMatrixInput)/2+1))
updateMatrixInput(session, inputId = "myMatrixInput", value = tmpMatrix)
}
sanitizedMat(na.omit(input$myMatrixInput))
})
plotData <- reactive({
lapply(seq_len(ncol(sanitizedMat())/2),
function(i){
tibble(
Scenario = colnames(sanitizedMat())[i*2-1],
X = 1:input$periods,
Y = interpol(input$periods, sanitizedMat()[1,(i*2-1):(i*2)])
)
}) %>% bind_rows()
})
output$plot <- renderPlot({
plotData() %>% ggplot() + geom_line(aes(
x = X,
y = Y,
colour = as.factor(Scenario)
))
})
}
shinyApp(ui, server)