#r #module #shiny
#r #модуль #блестящий
Вопрос:
Я пытаюсь обобщить модули Shiny, чтобы можно было передавать разные функции, но ожидаемое поведение reactivity не работает — может кто-нибудь указать мне правильное направление? Ниже у меня есть повторный запрос, который иллюстрирует мою проблему.
Я ожидаю, что динамический выбор view_id изменит значения в функции renderShiny(). Это работает при загрузке приложения, но изменение выбора не выполняется.
Это как-то связано со средой, в которой создается функция модуля?
library(shiny)
create_shiny_module_funcs <- function(data_f,
model_f,
outputShiny,
renderShiny){
server_func <- function(input, output, session, view_id, ...){
gadata <- shiny::reactive({
# BUG: this view_id is not reactive but I want it to be
data_f(view_id(), ...)
})
model_output <- shiny::reactive({
shiny::validate(shiny::need(gadata(),
message = "Waiting for data"))
model_f(gadata(), ...)
})
output$ui_out <- renderShiny({
shiny::validate(shiny::need(model_output(),
message = "Waiting for model output"))
message("Rendering model output")
model_output()
}, ...)
return(model_output)
}
ui_func <- function(id, ...){
ns <- shiny::NS(id)
outputShiny(outputId = ns("ui_out"), ...)
}
list(
shiny_module = list(
server = server_func,
ui = ui_func
)
)
}
# create the shiny module
ff <- create_shiny_module_funcs(
data_f = function(view_id) mtcars[, view_id],
model_f = function(x) mean(x),
outputShiny = shiny::textOutput,
renderShiny = function(x) shiny::renderText(paste("Mean is: ", x))
)
## ui.R
ui <- fluidPage(title = "module bug Shiny Demo",
h1("Debugging"),
selectInput("select", label = "Select", choices = c("mpg","cyl","disp")),
textOutput("view_id"),
ff$shiny_module$ui("demo1"),
br()
)
## server.R
server <- function(input, output, session){
view_id <- reactive({
req(input$select)
input$select
})
callModule(ff$shiny_module$server, "demo1", view_id = view_id)
output$view_id <- renderText(paste("Selected: ", input$select))
}
# run the app
shinyApp(ui, server)
Ответ №1:
Проблема заключалась в том, что renderShiny функции необходимо обернуть другую функцию, которая создает фактический вывод, так что на самом деле я путаю две отдельные возможности как одну: renderShiny должна принимать вывод другой функции, которая фактически создает объект для рендеринга. Затем работает приведенное ниже:
library(shiny)
module_factory <- function(data_f = function(x) mtcars[, x],
model_f = function(x) mean(x),
output_shiny = shiny::plotOutput,
render_shiny = shiny::renderPlot,
render_shiny_input = function(x) plot(x),
...){
ui <- function(id, ...){
ns <- NS(id)
output_shiny(ns("ui_out"), ...)
}
server <- function(input, output, session, view_id){
gadata <- shiny::reactive({
data_f(view_id(), ...)
})
model <- shiny::reactive({
shiny::validate(shiny::need(gadata(),
message = "Waiting for data"))
model_f(gadata(), ...)
})
output$ui_out <- render_shiny({
shiny::validate(shiny::need(model(),
message = "Waiting for model output"))
render_shiny_input(gadata())
})
return(model)
}
list(
module = list(
ui = ui,
server = server
)
)
}
made_module <- module_factory()
## ui.R
ui <- fluidPage(title = "module bug Shiny Demo",
h1("Debugging"),
selectInput("select", label = "Select", choices = c("mpg","cyl","disp")),
textOutput("view_id"),
made_module$module$ui("factory1"),
br()
)
## server.R
server <- function(input, output, session){
callModule(made_module$module$server, "factory1", view_id = reactive(input$select))
output$view_id <- renderText(paste("Selected: ", input$select))
}
# run the app
shinyApp(ui, server)
Ответ №2:
Я думаю, вы хотите что-то вроде этого.
library(shiny)
library(plyr)
library(dplyr)
library(DT)
library(data.table)
ui <- pageWithSidebar(
headerPanel = headerPanel('data'),
sidebarPanel = sidebarPanel(fileInput(
'mtcars', h4('Uplaodmtcardata in csv format')
),
uiOutput('tabnamesui')),
mainPanel(uiOutput("tabsets"))
)
server <- function(input, output, session) {
mtcarsFile <- reactive({
input$mtcars
})
xxmtcars <-
reactive({
read.table(
file = mtcarsFile()$datapath,
sep = ',',
header = T,
stringsAsFactors = T
)
})
tabsnames <- reactive({
names(xxmtcars())
})
output$tabnamesui <- renderUI({
req(mtcarsFile())
selectInput(
'tabnamesui',
h5('Tab names'),
choices = as.list(tabsnames()),
multiple = T
# selected = SalesGlobalDataFilter1Val()
)
})
tabnamesinput <- reactive({
input$tabnamesui
})
output$tabsets <- renderUI({
req(mtcarsFile())
tabs <-
reactive({
lapply(tabnamesinput(), function(x)
tabPanel(title = basename(x)
,fluidRow(splitLayout(cellWidths = c("50%", "50%"),
plotOutput(paste0('plot1',x)),
plotOutput(paste0('plot2',x)
))),fluidRow(splitLayout(cellWidths =
c("50%", "50%"),
plotOutput(paste0('plot3',x)),
plotOutput(paste0('plot4',x)
))),
dataTableOutput(paste0('table',x))))
})
do.call(tabsetPanel, c(tabs()))
})
# Save your sub data here
subsetdata<-reactive({
list_of_subdata<-lapply(tabnamesinput(), function(x) {
as.data.table((select(xxmtcars(),x)))
})
names(list_of_subdata)<-tabnamesinput()
return(list_of_subdata)
})
observe(
lapply(tabnamesinput(), function(x) {
output[[paste0('table',x)]] <-
renderDataTable({
subsetdata()[[x]]
})}))
observe(
lapply(tabnamesinput(), function(x) {
for(i in paste0("plot",1:4)){
output[[paste0(i,x)]] <-
renderPlot({subsetdata()[[x]]%>%plot()#CODE REPEATED
})
}
})
)
}
runApp(list(ui = ui, server = server))
Источник данных:
Комментарии:
1. Извините, я думаю, вы неправильно поняли мой вопрос