#r #function #shiny
Вопрос:
Я работаю над приложением, которое позволяет пользователю при необходимости расширять базовый начальный ввод ( firstInput в приведенном ниже MWE). SecondInput позволяет пользователю вертикально расширять свои предположения (не работает в этом MWE, но в полном приложении он выполняет экстраполяции и интерполяции, и он расширяется вертикально, хорошо вписываясь в боковую панель). ThirdInput ниже приведена кастрация для простоты иллюстрации. FourthInput , появляющийся в modalDialog , позволяет пользователю расширять предположения по горизонтали. Входы последовательно соединены ( firstInput — > > secondInput — > > fourthInput ), причем последний вход имеет приоритет. Цепочка работает нормально.
В полном приложении у меня работает вертикальное расширение. Теперь мне нужна помощь с расширением горизонтального предположения.
Как показано на изображении внизу, в модальном каталоге, как я могу нажать кнопку «Добавить сценарий» actionButton , чтобы добавить другую входную матрицу справа, называемую «Пятый вход»? Еще один щелчок добавит «sixthInput» справа и т. Д. Это то, что я подразумеваю под «горизонтальным расширением». Что касается цепочки, то эти новые матрицы входных данных будут прикованы secondInput точно так же, как fourthInput и is. Щелчок кнопки «Удалить выше» actionButton приведет к удалению входной матрицы непосредственно над ней. Я не уверен, насколько велика modalDialog коробка, но мне может понадобиться какая-то коробка, которая позволяет выполнять вертикальную/горизонтальную прокрутку. Если это немного чересчур, мне интересно, есть ли какой-нибудь пакет, который помогает или помогает в этом.
Код MWE:
library(shiny)
library(shinyjs)
library(shinyMatrix)
f <- function(action,i){as.character(checkboxInput(paste0(action,i),label=NULL))}
actions <- c("show", "reset")
tbl <- t(outer(actions, c(1,2), FUN = Vectorize(f)))
colnames(tbl) <- c("Show", "Reset")
rownames(tbl) <- c("2nd input", "3rd input")
firstInput <- function(inputId){
matrixInput(inputId,
value = matrix(c(5), 1, 1, dimnames = list(c("1st input"),NULL)),
rows = list(extend = FALSE, names = TRUE),
cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
class = "numeric")}
secondInput <- function(inputId,x){
matrixInput(inputId,
value = matrix(c(x), 1, 1, dimnames = list(c("2nd input"),NULL)),
rows = list(extend = FALSE, names = TRUE),
cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
class = "numeric")}
fourthInput <- function(inputId,x){
matrixInput(inputId,
value = matrix(c(x), 1, 1, dimnames = list(c("4th input"),NULL)),
rows = list(extend = FALSE, names = TRUE),
cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
class = "numeric")}
ui <- fluidPage(
tags$head(
tags$style(HTML(
"td .checkbox {margin-top: 0; margin-bottom: 0;}
td .form-group {margin-bottom: 0;}"
))
),
br(),
sidebarLayout(
sidebarPanel(
uiOutput("panel"),
hidden(uiOutput("secondInput")),
actionButton("showFourth","Show 4th input (in modal)",width = "100%") # ADDED
),
mainPanel(plotOutput("plot1"))
)
)
server <- function(input, output){
input1 <- reactive(input$input1)
input2 <- reactive(input$input2)
input4 <- reactive(input$input4)
output$panel <- renderUI({
tagList(
useShinyjs(),
firstInput("input1"),
strong(helpText("Generate curves (Y|X):")),
tableOutput("checkboxes")
)
})
output[["checkboxes"]] <-
renderTable({tbl},
rownames = TRUE, align = "c",
sanitize.text.function = function(x) x
)
observeEvent(input[["show1"]], {
if(input[["show1"]]){shinyjs::show("secondInput")} else
{shinyjs::hide("secondInput")}
})
observeEvent(input$showFourth,{
showModal(
modalDialog(
column(4,
actionButton("add","Add scenario"), div(style = "margin-bottom: 10px"),
fourthInput("input4",if(isTruthy(input$input4)){input$input4} else {input$input2[1,1]}),
actionButton("remove","Remove above")
),
footer = modalButton("Close")
)) # close showModal and modalDialog
})
output$secondInput <- renderUI({
req(input1())
secondInput("input2",input$input1[1,1])
})
outputOptions(output,"secondInput",suspendWhenHidden = FALSE)
output$plot1 <-renderPlot({
req(input2())
plot(rep(if(isTruthy(input$input4)){input4()} else {input2()}, times=5))
})
}
shinyApp(ui, server)
Ответ №1:
Я всегда недооцениваю пакет shinyMatrix, оказывается, у него есть функция горизонтального расширения, которую я ищу, и расширения могут быть сгруппированы в 2 по мере необходимости. Смотрите измененный код MWE, отражающий это использование shinyMatrix для расширений. В основном для спецификаций столбцов matrixInput (в пользовательской функции fourthInput ) все, что я сделал, это добавил extend = TRUE, delta = 2, delete = TRUE, .... Расширение, что означает, что матрица может быть расширена (по столбцам, поскольку это указано в разделе параметры столбца), дельта 2 = матрица расширяется в группировке 2, удалить = столбцы можно удалить.
Однако вывод shinyMatrix-не самая красивая вещь на свете, я открыт для других решений или пакетов!!
Код MWE:
library(shiny)
library(shinyjs)
f <- function(action,i){as.character(checkboxInput(paste0(action,i),label=NULL))}
actions <- c("show", "reset")
tbl <- t(outer(actions, c(1,2), FUN = Vectorize(f)))
colnames(tbl) <- c("Show", "Reset")
rownames(tbl) <- c("2nd input", "3rd input")
xDflt <- 10
yDflt <- 5
userInput <- function(inputId,x,y,z){
matrixInput(inputId,
value = matrix(c(x,y), 1, 2, dimnames = list(c(z),c("X and Y",""))),
rows = list(extend = FALSE, names = TRUE),
cols = list(
extend = FALSE,
names = TRUE,
editableNames = FALSE,
multiheader=TRUE
),
class = "numeric")}
fourthInput <- function(inputId,x,y,z){
matrixInput(inputId,
value = matrix(c(x,y), 1, 2, dimnames = list(c(z),c("X and Y",""))),
label = "Add, delete, or modify matrix parameters:",
rows = list(extend = FALSE, names = TRUE),
cols = list(
extend = TRUE,
delta = 2,
delete = TRUE,
names = TRUE,
editableNames = FALSE,
multiheader=TRUE
),
class = "numeric")}
ui <- fluidPage(
tags$head(
tags$style(HTML(
"td .checkbox {margin-top: 0; margin-bottom: 0;}
td .form-group {margin-bottom: 0;}"
))
),
br(),
sidebarLayout(
sidebarPanel(
uiOutput("panel"),
hidden(uiOutput("secondInput")),
actionButton("showFourth","Show 4th input (in modal)",width = "100%")
),
mainPanel(plotOutput("plot1"))
)
)
server <- function(input, output){
input1 <- reactive(input$input1)
input2 <- reactive(input$input2)
input4 <- reactive(input$input4)
output$panel <- renderUI({
tagList(
useShinyjs(),
userInput("input1",xDflt,yDflt,"1st input"),
strong(helpText("Generate curves (Y|X):")),
tableOutput("checkboxes")
)
})
output[["checkboxes"]] <-
renderTable({tbl},
rownames = TRUE, align = "c",
sanitize.text.function = function(x) x
)
observeEvent(input[["show1"]], {
if(input[["show1"]]){shinyjs::show("secondInput")} else
{shinyjs::hide("secondInput")}
})
observeEvent(input$showFourth,{
showModal(
modalDialog(
fourthInput("input4",
xDflt,
if(isTruthy(input$input4)){input$input4[1,2]} else
{input$input2[1,2]},
"4th input"),
footer = modalButton("Close")
))
})
output$secondInput <- renderUI({
req(input1())
userInput("input2",xDflt,input$input1[1,2],"2nd Input")
})
outputOptions(output,"secondInput",suspendWhenHidden = FALSE)
output$plot1 <-renderPlot({
req(input2())
plot(rep(if(isTruthy(input$input4)){input4()[1,2]} else {input2()[1,2]}, times=10))
})
}
shinyApp(ui, server)