【发布时间】：2020-01-21 02:23:20
【问题描述】：
我可以通过两次调用 plot 函数来成功渲染两个闪亮的饼图。当调用 plot 函数时，它将参数值分别传递给 plot1 和 plot2 的 ggplot。这意味着 ggplot 的代码只需要编写一次。
复选框小部件允许用户勾选任何日期组合，并且绘图成功更新。馅饼中的 % 是 100% 正确的。
问题是图例标签中的颜色与饼图中的段颜色不一致。
例如，图例标签“01 月”是黄色的，而饼图中的黄色部分表示 25%。但 25% 应该是“06 个月”部分。图例标签“06 个月”是橙色，馅饼中的橙色部分表示 19%。但是 19% 应该是“超过一年”部分”.. 以此类推，其余 4 个部分与饼图部分颜色不匹配。
有趣的是，如果 ggplot 的代码分别为 plot1 和 plot2 编写，这不是问题。只有将 ggplot 封装在函数中并调用时才会出现问题。
我无法在堆栈溢出中找到类似的问题，因此希望有人可以帮助我解决这个问题。我已经包含了完整的 ui 和服务器代码 + 库 + 一个示例 data.frame 用于这个练习。必须有某种方法将图例标签与正确的颜色相关联，以与饼图段的颜色相关联。
图例标签来自 plot1 的 age_group 变量和 plot2 的 Outcome 变量。我为age_group 的6 个级别定义了6 种颜色，为Outcome 的4 个级别定义了4 种颜色。
library(shiny)
library(ggplot2)
library(dplyr)
# use the below if you want to increase the file size being inputed to 9MB
# options(shiny.maxRequestSize = 9.1024^2)
ui <- shinyUI(navbarPage("Example",
tabPanel("Data",
sidebarLayout(
sidebarPanel(
"Nothing here at the moment"),
mainPanel("Select Dashboard Panel for results.Click on Select/All to make the plots
render"))
),
tabPanel("Dashboard",
sidebarLayout(
sidebarPanel(
checkboxInput('all', 'Select All/None', value = TRUE),
uiOutput("year_month"),
tags$head(tags$style("#year_month{color:red; font-size:12px; font-style:italic;
overflow-y:scroll; max-height: 100px; background: ghostwhite;}"))),
mainPanel(
uiOutput("tb")))
)
))
complaint_id <-
c(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,
31,32,33)
age_group <- c("Over a year", "06 Months", "01 Months", "Over a year", "06 Months", "09 Months",
"01 Months", "03 Months", "06 Months", "03 Months", "12 Months", "09 Months",
"01 Months", "06 Months", "01 Months", "12 Months", "01 Months", "09 Months",
"06 Months", "09 Months", "Over a year", "Over a year", "01 Months", "12 Months",
"06 Months", "01 Months", "09 Months", "12 Months", "03 Months", "01 Months",
"Over a year", "01 Months", "01 Months")
closed_date_ym <- c("2019-08", "2019-09", "2019-08", "2019-08", "2019-08", "2019-08", "2019-09",
"2018-08", "2019-08", "2019-09", "2019-09", "2019-09", "2019-08", "2019-08",
"2019-09", "2019-09", "2019-08", "2019-09", "2019-09", "2019-09", "2019-09",
"2019-09", "2019-09", "2019-09", "2019-08", "2019-08", "2019-09", "2019-08",
"2019-08", "2019-08", "2019-08", "2019-09", "2019-09"
)
officer <- c("E", "D", "B", "A", "A", "D", "C", "C", "C", "D", "C", "B", "C", "D", "A", "A",
"D",
"A", "E", "C", "B", "C", "E", "E", "E", "A", "A", "A", "B", "E", "C", "D", "B")
Outcome <- c("Excellent", "Poor", "OK", "Excellent", "Poor", "Good", "Poor", "Good", "Poor",
"Excellent",
"Poor", "Good", "Excellent", "Good", "Poor", "Poor", "Excellent", "Poor", "Poor", "Good",
"OK", "OK", "Excellent", "Poor", "Good", "OK", "Good", "OK", "Good", "Excellent",
"Excellent", "Excellent", "Excellent")
sample_data <- data.frame(complaint_id, age_group, closed_date_ym, officer, Outcome)
server <- shinyServer(function(session, input, output){
# Make it reactive
data <- reactive({
sample_data
})
# Have to modify the reactive data object to add a column of 1s(Ones) inorder
# that the Pie chart %s are calculated correctly within the segments. We apply
# this modification to a new reactive object, data_mod()
data_mod <- reactive({
req(data())
data_mod <-
data() %>% select(complaint_id, age_group, closed_date_ym, officer, Outcome)
data_mod$Ones <- rep(1, nrow(data()))
data_mod
})
# creates a selectInput widget with unique YYYY-MM variables ordered from most
# recent to oldest time period
output$year_month <- renderUI({
req(data_mod())
data_ordered <-
order(data_mod()$closed_date_ym, decreasing = TRUE)
data_ordered <- data_mod()[data_ordered,]
checkboxGroupInput("variable_month",
"Select Month",
choices = unique(data_ordered$closed_date_ym))
})
observe({
req(data_mod())
data_ordered <-
order(data_mod()$closed_date_ym, decreasing = TRUE)
data_ordered <- data_mod()[data_ordered,]
updateCheckboxGroupInput(
session,
"variable_month",
choices = unique(data_ordered$closed_date_ym),
selected = if (input$all)
unique(data_ordered$closed_date_ym)
)
})
# This subsets the dataset based on what "variable month" above is selected
# and renders it into a Table
output$table <- renderTable({
req(data_mod())
dftable <- data_mod()
df_subset <- dftable[, 1:5][dftable$closed_date_ym %in%
input$variable_month, ]
},
options = list(scrollX = TRUE))
# This takes the modified reactive data object data_mod(), assigns it to a
# dataframe df. The dataset in df is subsetted based on the selected variable
# month above and assigned into a new data frame, DF. The Pie chart is
# built on the variables within DF
plot_func <- function(DF, grp_vars, title, scale) {
group_by(DF, DF[[grp_vars]]) %>%
summarize(volume = sum(Ones)) %>%
mutate(share = volume / sum(volume) * 100.0) %>%
arrange(desc(volume)) %>%
ggplot(aes("", share, fill = unique(DF[[grp_vars]]))) +
geom_bar(
width = 1,
size = 1,
color = "white",
stat = "identity"
) +
coord_polar("y") +
geom_text(aes(label = paste0(round(share), "%")),#share,digits=2
position = position_stack(vjust = 0.5)) +
labs(
x = NULL,
y = NULL,
fill = NULL,
title = title
) +
guides(fill = guide_legend(reverse = TRUE)) +
scale_fill_manual(values = scale) +
theme_classic() +
theme(
axis.line = element_blank(),
axis.text = element_blank(),
axis.ticks = element_blank(),
plot.title = element_text(hjust = 0.5, color = "#666666")
)
}
output$plot1 <- renderPlot({
req(data_mod(), input$variable_month)
plot_func(
DF = data_mod()[, 1:6][data_mod()$closed_date_ym %in% input$variable_month, ],
grp_vars = "age_group",
title = "Age Group Segmentation",
scale = c(
"#ffd700",
"#bcbcbc",
"#ffa500",
"#254290",
"#f0e68c",
"#808000"
)
)
})
output$plot2 <- renderPlot({
req(data_mod(), input$variable_month)
plot_func(
DF = data_mod()[, 1:6][data_mod()$closed_date_ym %in% input$variable_month, ],
grp_vars = "Outcome",
title = "Outcome Segmentation",
scale = c("#ffd700", "#bcbcbc", "#ffa500", "#254290")
)
})
# the following renderUI is used to dynamically gnerate the tabsets when the file is loaded
output$tb <- renderUI({
req(data())
tabsetPanel(tabPanel("Plot",
plotOutput("plot1"), plotOutput("plot2")),
tabPanel("Data", tableOutput("table")))
})
})
shinyApp(ui, server)
【问题讨论】：
-
查看minimal reproducible example 中的“最小”部分，并确保如果问题实际上与 Shiny 相关，那么这是一个 Shiny 应用程序，人们将能够轻松运行
-
是的，这可以按原样运行，只需按原样复制到 ui.r 和 server.r 文件中，然后在 RStudio 中运行应用程序。
-
我更新了代码，所以它可以在单个文件“app.R”中运行，这在stackoverflow上比较常见。