r语言 - 我不能得到一个闪亮的模块作为服务器工作.只有当服务器作为一组单独的命令分开时才有效

Question

我有一个闪亮的模块，我有一个巨大的问题让它的工作。我正在尝试创建一个具有多个选项卡的仪表板，并正在探索模块以减少重复的数量。

如果我用代码显式地硬编码服务器，我可以让应用程序工作，但是当我为服务器部分创建模块时，它不会工作。我真的很感激任何帮助，因为我已经尝试到处寻找一个可行的例子，下面是一个可重复的例子，我想模块化的代码的比例，

datasetInput <- function(id, Taxhead = NULL) {
ns <- NS(id)

names <- colnames(mtcars)

if (!is.null(Taxhead)) {
pattern <- paste0(Taxhead)
names <-names$name[sapply(names, function(x){ grepl(pattern,x, ignore.case = TRUE)})]  #### filter for a match
}
selectInput(ns("dataset"), "Pick a Report", choices = names)
}

#### Server 1
#### Collect the data set based on the selection in datasetInput
datasetServer <- function(id) {
moduleServer(id, function(input, output, session) {
#### Outputs the data set

#### reactive(  read.csv(paste0("Data/",input$dataset,".csv")) )
reactive(  mtcars )
})}

#### Display the variables of interest
selectVarInput <- function(id){
ns <- NS(id)
tagList(
selectInput(ns("var"), "Select grouping Variables", choices = NULL, multiple = TRUE) ,

selectInput(ns("var2"), "Select Measure Variables", choices = NULL, multiple = TRUE)
)  }

##### Server 2
#### Returns the data as a reactive
selectVarServer <- function(id, data) {

find_vars <- function(data, filter) { names(data)}

moduleServer(id, function(input, output, session) {
observeEvent(data(), {
updateSelectInput(session, "var", choices = find_vars(data()))
})

observeEvent(data(), {
updateSelectInput(session, "var2", choices = find_vars(data()))
})

reactive(data() %>% group_by(across(all_of(input$var))) %>% summarise(across(all_of(input$var2),sum), n = n()))
})}


selectDataVarUI <- function(id, Taxhead =NULL) {

ns <- NS(id)

tagList(
datasetInput(ns("data"), Taxhead ),
selectVarInput(ns("var"))
)}

#### Server 3
selectDataVarServer <- function(id) {
moduleServer(id, function(input, output, session) {
data <- datasetServer("data")
var <- selectVarServer("var", data)
var })}

Date_Range_UI <- function(id) {

ns <- NS(id)
# Sidebar to demonstrate various slider options ----
tagList(
# Sidebar with a slider input
# # Select form input for checking
radioButtons(ns("Period"),
label = "Select Desired Comparison Period",
choices = c( "Daily", "Monthly","Yearly"),
selected = "Monthly")
,
# Only show this panel if Monthly or Quarterly is selected
conditionalPanel(
condition =  "input.Period != 'Yearly'", ns = ns,
dateRangeInput(ns('dateRange'),
label = 'Date range input',
start = Sys.Date()-180,
end = Sys.Date() ,
min = NULL, max = Sys.Date() ,
separator = " - ", format = "MM-yyyy",
startview = 'year', language = 'en', weekstart = 0,autoclose = TRUE))
,
# Only show this panel if Custom is selected
conditionalPanel(
condition = "input.Period == 'Yearly'", ns = ns,
sliderInput(ns("yearly"), "Years", min = 2000, max = as.integer(format(Sys.Date(),"%Y")), value = c(2008,2021), round = TRUE,step = 1)),


) ### close side bar layout
### close fluid page layout
}

Date_Range_Server <- function(id ) {

moduleServer(id,
function(input, output, session) {

x <- reactive({input$Period})

return(
list(
Startdate =  reactive(if(x() == "Yearly") {input$yearly[1]
}
else if(x() == "Monthly") {
as.integer(format(input$dateRange[1],"%Y%m"))
}else{
as.integer(format(input$dateRange[1],"%Y%m%d"))})
,

Enddate = reactive(if(x() == "Yearly") {input$yearly[2]
}
else if(x() == "Monthly") {
as.integer(format(input$dateRange[2],"%Y%m"))
}else{
as.integer(format(input$dateRange[2],"%Y%m%d"))})
,
Choice = reactive(input$Period )))

})}
###### this won't work!
betting_UI <-   function(id) {
ns <- NS(id)
sidebarLayout(
sidebarPanel(
Date_Range_UI("data_range"),
selectDataVarUI(id = "var", Taxhead =NULL)),
mainPanel(
tableOutput(ns("table")),
verbatimTextOutput (ns("test"))
))  }

Betting_Server <- function(input, output, session) {

date_range <- Date_Range_Server("data_range")

output$test <- renderPrint( date_range$Startdate())
output$table <- renderTable(var(), width = 40)             
}
ui <- fluidPage(
betting_UI("betting")
)
server <- function(input, output, session) {
Betting_Server("betting")
}
shinyApp(ui, server)**

##### this works fine I thought putting the modules into the server would work as above?????
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
Date_Range_UI("data_range"),
selectDataVarUI(id = "var", Taxhead =NULL)),
mainPanel(
tableOutput("table"),
verbatimTextOutput ("test")
))  )

#### Server
server <- function(input, output, session) {
var <- selectDataVarServer("var")
date_range <- Date_Range_Server("data_range")

output$test <- renderPrint( date_range$Startdate())
output$table <- renderTable(var(), width = 40)

} 
shinyApp(ui, server)

Answer 1

您必须在您的模块UI中使用ns()

betting_UI <-   function(id) {
ns <- NS(id)
sidebarLayout(
sidebarPanel(
Date_Range_UI(ns("data_range")),
selectDataVarUI(id = ns("var"), Taxhead = NULL)
),
mainPanel(tableOutput(ns("table")),
verbatimTextOutput (ns("test")))
)
}

您还必须使用moduleServer()创建模块服务器

Betting_Server <- function(id) {
moduleServer(id,
function(input, output, session) {
var <- selectDataVarServer("var")
date_range <- Date_Range_Server("data_range")

output$test <- renderPrint(date_range$Startdate())
output$table <- renderTable(var(), width = 40)
})
}