This post is a bit much. Will post a simpler question getting to the same issue...
The below MWE code is adapted from a matrix that expanded horizontally, but now I'm trying to make it expand in 2 directions, horizontally and vertically. I'm encountering "Error in [: (subscript) logical subscript too long" and in some instances unresponsive matrix inputs, as shown in the images at the bottom.
I'm pretty sure the heart of the problems lie in the matrix indexing buried in lapply(...Y = interpol(input$periods, sanitizedMat()[,(i*2-1):(i*2), drop = FALSE])...
Any ideas how to resolve?
I imagine this takes some mastery of dynamic matrix indexing and nested lapply and/or sapply functions.
The custom interpol() function works fine though it looks nasty. It allows the user to build a curve of values over a time horizon (limited by the overarching "modeled periods" per the slider input), with the left sub-column in each scenario specifying the period and the right sub-column the value to apply in that period, and it:
- Runs error checks and some input correction
- If a row 1 period is > 1, the corresponding right-column value is help constant over those initial periods
- If the last period in a sub-column is < than the max periods per the slider input (for overarching modeled periods), then remaining periods are 0
- Any right-column values with period gaps are interpolated, as shown in the images at the bottom. Main objective of this function is interpolation
Matrix input expands horizontally for additional scenarios. Expands vertically to expand scenario curves. The images at the bottom explain it all.
MWE Code:
library(shiny)
library(shinyMatrix)
library(dplyr)
library(ggplot2)
interpol <- function(a, b) {
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
return(e)
}
ui <- fluidPage(
sliderInput('periods', 'Periods to model:', min=1, max=10, value=10),
matrixInput(
"myMatrixInput",
label = "Build curves: input periods and variables in left and right columns for each scenario (period gaps interpolated)",
value = matrix(c(1, 5), 1, 2, dimnames = list(NULL, rep("Scenario 1", 2))),
cols = list(extend = TRUE, delta = 2, names = TRUE, delete = TRUE, multiheader = TRUE),
rows = list(extend = TRUE, delta = 1, names = FALSE, delete = FALSE),
class = "numeric"),
plotOutput("plot")
)
server <- function(input, output, session) {
sanitizedMat <- reactiveVal() # < necessary for vertical matrix expansion
observeEvent(input$myMatrixInput, {
if(any(colnames(input$myMatrixInput) == "")){
tmpMatrix <- input$myMatrixInput
empty_columns <- sapply(tmpMatrix, function(x) all(is.na(x) | x == ""))
tmpMatrix <- tmpMatrix[, !empty_columns, drop = FALSE]
colnames(tmpMatrix) <- paste("Scenario", rep(1:ncol(tmpMatrix), each = 2, length.out = ncol(tmpMatrix)))
isolate(updateMatrixInput(session, inputId = "myMatrixInput", value = tmpMatrix))
}
sanitizedMat(na.omit(input$myMatrixInput))
})
plotData <- reactive({
tryCatch(
lapply(seq_len(ncol(sanitizedMat())/2),
function(i){
tibble(
Scenario = colnames(sanitizedMat())[i*2-1],
X = seq_len(input$periods),
Y = interpol(input$periods, sanitizedMat()[,(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)
