我正在开发一个 R Shiny 仪表板，该仪表板的尺寸已显着增大，并且还在继续扩展。服务器端代码变得难以管理，因此我通过使用
source("code/table_x1.R", local = TRUE)但是，我还没有找到一个好的方法来以类似的方式模块化UI代码。作为中级 R 用户，我该如何做到这一点？
您可以在下面找到代码的工作示例。具体来说，我想将
dashboardSidebar()tabItem(...)library(shiny)
library(shinydashboard)
library(reactable)
d1 <- data.frame(
name = c("Frank", "Emma", "Kurt", "Johanna", "Anna", "Ben", "Chris", "David", "Eva", "Felix", "Gina", "Hannah", "Iris", "Jack", "Karen", "Leo", "Mia", "Nina", "Omar", "Paul"),
team = c("A", "A", "B", "B", "A", "B", "A", "B", "A", "B", "A", "B", "A", "B", "A", "B", "A", "B", "A", "B"),
score = c(12, 15, 13, 13, 14, 11, 10, 16, 9, 8, 17, 14, 12, 13, 15, 16, 11, 10, 9, 8)
)
d2 <- data.frame(
name = c(
"Frank", "Frank", "Frank",
"Emma", "Emma", "Emma",
"Kurt", "Kurt", "Kurt",
"Johanna", "Johanna", "Johanna",
"Anna", "Anna", "Anna",
"Ben", "Ben", "Ben",
"Chris", "Chris", "Chris",
"David", "David", "David",
"Eva", "Eva", "Eva",
"Felix", "Felix", "Felix",
"Gina", "Gina", "Gina",
"Hannah", "Hannah", "Hannah",
"Iris", "Iris", "Iris",
"Jack", "Jack", "Jack",
"Karen", "Karen", "Karen",
"Leo", "Leo", "Leo",
"Mia", "Mia", "Mia",
"Nina", "Nina", "Nina",
"Omar", "Omar", "Omar",
"Paul", "Paul", "Paul"
),
match = c(
1, 2, 3, # Frank
1, 2, 3, # Emma
1, 2, 3, # Kurt
1, 2, 3, # Johanna
1, 2, 3, # Anna
1, 2, 3, # Ben
1, 2, 3, # Chris
1, 2, 3, # David
1, 2, 3, # Eva
1, 2, 3, # Felix
1, 2, 3, # Gina
1, 2, 3, # Hannah
1, 2, 3, # Iris
1, 2, 3, # Jack
1, 2, 3, # Karen
1, 2, 3, # Leo
1, 2, 3, # Mia
1, 2, 3, # Nina
1, 2, 3, # Omar
1, 2, 3 # Paul
),
score = c(
4, 4, 4, # Frank (12)
5, 5, 5, # Emma (15)
4, 4, 5, # Kurt (13)
4, 4, 5, # Johanna (13)
5, 4, 5, # Anna (14)
4, 4, 3, # Ben (11)
4, 3, 3, # Chris (10)
6, 5, 5, # David (16)
3, 3, 3, # Eva (9)
3, 3, 2, # Felix (8)
6, 6, 5, # Gina (17)
5, 5, 4, # Hannah (14)
4, 4, 4, # Iris (12)
4, 4, 5, # Jack (13)
5, 5, 5, # Karen (15)
6, 5, 5, # Leo (16)
4, 4, 3, # Mia (11)
4, 3, 3, # Nina (10)
3, 3, 3, # Omar (9)
3, 3, 2 # Paul (8)
)
)
ui <- dashboardPage(
dashboardHeader(title = "Test"),
dashboardSidebar(
sidebarMenu(
id = "tabs",
menuItem("Table 1", tabName = "table1", icon = icon("table")),
menuItem("Table 2", tabName = "table2", icon = icon("table")),
menuItem("Add new Row", tabName = "addRow", icon = icon("plus"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "table1",
fluidRow(
box(width = 12,
title = "Table 1",
reactableOutput("table1"))
)
),
tabItem(tabName = "table2",
fluidRow(
box(width = 12,
title = "Table 2",
reactableOutput("table2"))
)
),
tabItem(tabName = "addRow",
fluidRow(
box(width = 12,
title = "Add New Row",
textInput("name", "Name", ""),
textInput("team", "Team", ""),
numericInput("score", "Score", value = 0, min = 0, max = 100),
actionButton("addBtn", "Add"),
br(),
textOutput("msg") # Output for the "Row added" message
)
)
)
)
)
)
server <- function(input, output, session) {
d1 <- reactiveVal(d1) # Make d1 reactive
output$table1 <- renderReactable({
reactable(
d1(),
filterable = TRUE,
columns = list(
score = colDef(footer = JS(
c(
"function(column, state) {",
" let total = 0",
" state.sortedData.forEach(function(row) {",
" total += row[column.id] ",
" })",
" return total",
"}"
)
)),
name = colDef(footer = "Total")
),
defaultSorted = "score",
defaultSortOrder = "desc",
defaultPageSize = 5,
onClick = JS(
c(
"function(rowInfo, colInfo, column) {",
" if (colInfo.id == 'name') {",
" Reactable.setAllFilters('table2', []);", # clear all filters
" Reactable.setFilter('table2', 'name', rowInfo.values.name);",
" Shiny.setInputValue('switchTab', {tab: 'table2'}, {priority:'event'});",
" }",
" return",
" }"
)
),
rowStyle = list(cursor = "pointer")
)
})
output$table2 <- renderReactable({
reactable(
d2,
filterable = TRUE,
columns = list(
score = colDef(footer = JS(
c(
"function(column, state) {",
" let total = 0",
" state.sortedData.forEach(function(row) {",
" total += row[column.id] ",
" })",
" return total",
"}"
)
)),
name = colDef(footer = "Total")
),
defaultSorted = "score",
defaultSortOrder = "desc",
defaultPageSize = 5
)
})
observeEvent(input$switchTab, {
updateTabItems(session, "tabs", input$switchTab$tab)
})
outputOptions(output, "table2", suspendWhenHidden = FALSE)
observeEvent(input$addBtn, {
# Check if fields are filled
if (input$name != "" && input$team != "" && input$score >= 0) {
# Append the new row to d1
new_row <- data.frame(
name = input$name,
team = input$team,
score = input$score,
stringsAsFactors = FALSE
)
d1(rbind(d1(), new_row))
# Display success message
output$msg <- renderText("Row added")
# Clear the input fields
updateTextInput(session, "name", value = "")
updateTextInput(session, "team", value = "")
updateNumericInput(session, "score", value = 0)
}
})
}
shinyApp(ui, server)
如果您不想/不能使用 shiny 的模块，为什么不使用您提到的模式来组织 UI 的服务器代码：
library(shiny)
writeLines(text = "tags$p('This is my UI content.')", con = "outsourced_UI.R")
ui <- fluidPage(
source("outsourced_UI.R", local = TRUE)[1]
)
server <- function(input, output, session) {}
shinyApp(ui, server)