r语言 - 为多个时间序列绘制交替绘制 x 值而不是完整集 - 使用 ggplotly 的 Shinydashboard

Question

我已经完成了99%的闪亮应用程序，但终其一生都无法弄清楚为什么当我从"区域"输入选择器向第一个图表中的图表添加多个系列时，x值被更改/跳过。

当我只有一个序列(默认 = 澳大利亚(时，绘制了所有月份。当我添加一个额外的区域(例如。维多利亚(，每隔一个月为每个系列绘制一次(交替(，当我添加第三个区域时，每三个月绘制一次(再次交替(。最终，这会导致看不到每行的最大值/最小值和每月值。

可添加到图中的区域集在原始数据集中共享相同的日期值(即从 1978 年 2 月到 2020 年 4 月的月值(。

检索数据

## app.R ##
library(dplyr)
library(raustats)
library(ggplot2)
library(lubridate)
library(shiny)
library(shinydashboard)
library(plotly)

#retrieve labour force dataset from ABS via abs.stat API
labour_force <- abs_stats(dataset = "LF", filter = list(ITEM=c(10,14,15,16), AGE=1599, TSEST=c(20, 30)))
lf <- select(labour_force, -c(frequency, obs_status, unknown, agency_id,agency_name, dataset_name))

#change datatype of 'time' to date format 
lf$time <- paste("01", lf$time, sep = "-")
lf$time <- strptime(lf$time, format = "%d-%b-%Y")
lf$time <- as.Date(lf$time, format = "%d-%b-%Y")
str(lf)

用户界面

#UI
ui <- dashboardPage(
dashboardHeader(title = "this is a title"),
## Sidebar content
dashboardSidebar(
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
menuItem("menu item", tabName = "menuItem1", icon = icon("th")),
menuItem("ABS website", icon = icon("th"), href = "https://abs.gov.au"),
menuSubItem("submenu")
)
),
dashboardBody(
tabItems(
# First tab content
tabItem(tabName = "dashboard",
# Boxes need to be put in a row or a column
fluidRow(
box(
title = "Labour Force Data Description",
status = "warning",
solidHeader = TRUE,
width = 9,
height = 250
)
),
fluidRow(
box(
title = "Labour Force Data",
status = "success",
solidHeader = TRUE,
dateRangeInput(
inputId = "dateRange",
label = "Select the date range:",
start = min(lf$time),
end = max(lf$time),
min = min(lf$time),
max = max(lf$time),
format = "d M yyyy",
startview = "year",
separator = "to",
autoclose = TRUE,
),
actionButton("resetDate", label = "Reset date range"),
selectizeInput(
inputId = "dataItem",
label = "Select data series:",
choices = unique(lf$data_item),
selected = "Unemployment rate (%)",
multiple = FALSE
),
selectizeInput(
inputId = "regionID",
label = "Select a region:",
choices = unique(lf$region),
selected = "Australia",
multiple = TRUE
),
selectizeInput(
inputId = "adjustment",
label = "Select estimate type:",
choices = unique(lf$adjustment_type),
selected = "Seasonally Adjusted",
multiple = FALSE
),
downloadButton(outputId = "downloadLF1", label = "Download"),
width = 2
),
box(
title = 'Plot 1',
status = "success",
solidHeader = TRUE,
plotlyOutput("LFplot1", height = 500),
width = 10,
)
),

fluidRow(
box(
title = "Labour Force Data",
status = "warning",
solidHeader = TRUE,
dateRangeInput(
inputId = "dateRangeGender",
label = "Select the date range:",
start = min(lf$time),
end = max(lf$time),
min = min(lf$time),
max = max(lf$time),
format = "d M yyyy",
startview = "year",
separator = "to",
autoclose = TRUE,
),
actionButton("resetDateGender", label = "Reset date range"),
selectizeInput(
inputId = "dataItemGender",
label = "Select data series:",
choices = unique(lf$data_item),
selected = "Unemployment rate (%)",
multiple = FALSE
),
selectizeInput(
inputId = "adjustmentGender",
label = "Select estimate type:",
choices = unique(lf$adjustment_type),
selected = "Seasonally Adjusted",
multiple = FALSE
),
downloadButton(outputId = "downloadLF2", label = "Download"),
width = 2
),
box(
title = 'plot 2',
status = "warning",
solidHeader = TRUE,
plotlyOutput("LFplot2", height = 500),
width = 10
)          
),
),
# Second tab content
tabItem(tabName = "menuItem1",
h2("welcome to menu item 1")
),
# third tab content
tabItem(tabName = "SUBSUB",
h2("Widgets tab content 111222")
)
)
)
)

服务器

server <- function(input, output, session) {
selector1 <- reactive({
print(input$dateRange)
lf %>% 
dplyr::filter(time >= input$dateRange[1], time <= input$dateRange[2], 
adjustment_type == input$adjustment, data_item == input$dataItem, region == input$regionID)
})

selector2 <- reactive({
print(input$dateRangeGender)
lf %>% 
dplyr::filter(time >= input$dateRangeGender[1], time <= input$dateRangeGender[2],
adjustment_type == input$adjustmentGender, data_item == input$dataItemGender)
})

observeEvent(input$resetDate, {
updateDateRangeInput(session, "dateRange", 
start = min(lf$time),
end = max(lf$time),
min = min(lf$time),
max = max(lf$time)
)
})
observeEvent(input$resetDateGender, {
updateDateRangeInput(session, "dateRangeGender", 
start = min(lf$time),
end = max(lf$time),
min = min(lf$time),
max = max(lf$time)
)
})

output$downloadLF1 <- downloadHandler(
filename = function() {
paste(input$dataItem, ".csv", sep = "")
},
content = function(file) {
write.csv(selector1(), file, row.names = FALSE)
}
)

output$downloadLF2 <- downloadHandler(
filename = function() {
paste(input$dataItemGender, ".csv", sep = "")
},
content = function(file) {
write.csv(selector2(), file, row.names = FALSE)
}
)
output$LFplot1 <- renderPlotly({
print(nrow(selector1()))
req(nrow(selector1()) > 0)
LFplt_1 <- selector1() %>%
dplyr::filter(sex == "Persons") %>%
ggplot() +
geom_line(mapping = aes(x= time, y= values,colour= region))
ggplotly(LFplt_1)
})

output$LFplot2 <- renderPlotly({
print(nrow(selector2()))
req(nrow(selector2()) > 0)
LFplt_2 <- selector2() %>%
dplyr::filter(region == "Australia") %>%
ggplot() +
geom_line(mapping = aes(x= time, y= values, colour= sex))
ggplotly(LFplt_2)
})

}
shinyApp(ui, server)

Answer 1

您的闪亮仪表板应用程序有很多活动部件，因此诊断这一点有点困难。我没有时间浏览所有细节，但这里有一些初步的想法：

1. 我认为您试图在选择器中做太多事情。 例如，在选择器1中，您正在尝试同时选择日期范围，adjustment_type，data_item和地区。

selector1 <- reactive({
print(input$dateRange)
lf %>% 
dplyr::filter(time >= input$dateRange[1], time <= input$dateRange[2], 
adjustment_type == input$adjustment, 
data_item == input$dataItem, 
region == input$regionID)
})

您最好将其分解为多个部分 - 每个部分的不同选择器adjustment_type，data_item和区域。

2. 日期范围选择器是否绝对必要？Plotly 已经允许您放大特定日期范围，您可能不需要单独的日期范围选择器。我知道您也将其用于下载按钮，但也许可以考虑省略日期范围选择器，直到您找出其他问题。

3. 通常，当我将过滤器函数连接到 selectInput 选项时，我会直接将 selectInput 放在 dplyr：：filter 行中。

# you have
output$LFplot2 <- renderPlotly({
print(nrow(selector2()))
req(nrow(selector2()) > 0)
LFplt_2 <- selector2() %>%
dplyr::filter(region == "Australia") %>%
ggplot() +
geom_line(mapping = aes(x= time, y= values, colour= sex))
ggplotly(LFplt_2)
})
# consider something like:
output$LFplot2 <- renderPlotly({
print(nrow(selector2()))
req(nrow(selector2()) > 0)
LFplt_2 <- selector2() %>%
dplyr::filter(region == input$regionID) %>%  # region selection in filter here
ggplot() +
geom_line(mapping = aes(x= time, y= values, colour= sex))
ggplotly(LFplt_2)
})

看看这是否有帮助。稍后会花更多的时间在这上面。

Answer 2

将 output$LFplot1 中的==运算符更改为%in%可以解决此问题：

反应函数更改为：

selector1 <- reactive({
print(input$dateRange)
lf %>% 
dplyr::filter(time >= input$dateRange[1], time <= input$dateRange[2],
adjustment_type == input$adjustment, 
data_item == input$dataItem)
})

输出图更改为：

output$LFplot1 <- renderPlotly({
print("number of rows is: ")
print(nrow(selector1()))
req(nrow(selector1()) > 0)
LFplt_1 <- selector1() %>%
dplyr::filter(sex == "Persons", region %in% input$regionID) %>%
ggplot() +
geom_line(mapping = aes(x= time, y= values,colour= region))
ggplotly(LFplt_1)
})