由于反应困难导致 Shiny 应用程序出错
Errors in Shiny app due to reactivity difficulties
我是 R 和 Shiny 的新手，所以请原谅我的无知。我有一个大数据集（184,171 个观察值和 10 个变量）作为 tibble。我正在尝试创建一个使用此数据 table 的 Shiny 应用程序。用户选择一个量表，然后选择一个要分析的变量、一个年份范围，然后选择他们希望每年还是每月汇总变量。根据输入，它将为所选仪表创建 3 个地块和一个位置图，以及汇总统计数据。 运行 我的用户界面部分没有问题。我知道问题出在我的服务器上。我想知道我是否在使用响应式 Values() 并正确观察事件。
原始数据集是 shinydata，我正在尝试制作一个基于用户输入进行过滤的反应性数据 table。我的错误包括：
在传单输出箱中展示
没有适用于元数据的适用方法应用于 class 反应式 Expr、反应式、函数
的对象
显示在摘要统计框中
数据必须是二维的（例如数据框或矩阵） -> 我知道这是因为我需要使用文本输出而不是数据 table 来获取摘要统计信息
在方框中显示和时间序列图输出
未找到对象 annual1
我已经为此苦苦挣扎了 3 天，并在网上搜索答案。任何见解将不胜感激！
# load libraries
library(shiny)
library(shinydashboard)
library(lubridate)
library(DT)
library(ggplot2)
library(dplyr)
library(leaflet)
library(tidyr)
# Read in datatable/tibble that was saved and exported as RDS
# from gauge script
# Modify table by removing columns SWE, RAIM, MOD_RUN
# and move date column from the last row to second row
shinydata = readRDS("C:/Users/.../shinydata.rds")
shinydata2 = shinydata[-c(5,7,11)]
shinydata2 = shinydata2 %>% relocate(DATE, .before = "YR")
> dput(head(shinydata2))
structure(list(GaugeID = c("06814000", "06814000", "06814000",
"06814000", "06814000", "06814000"), DATE = structure(c(4018,
4019, 4020, 4021, 4022, 4023), class = "Date"), YR = c(1981,
1981, 1981, 1981, 1981, 1981), MNTH = c(1, 1, 1, 1, 1, 1), DY = c(1,
2, 3, 4, 5, 6), PRCP = c(0, 0, 0, 0, 0, 0), TAIR = c(2.36, 0.71,
-1.62, -7.365, -3.03, 0.185), PET = c(0.4185, 0.3206, 0.3215,
0.3189, 0.3441, 0.4074), ET = c(0.4064, 0.31, 0.3102, 0.307,
0.3308, 0.3909), OBS_RUN = c(0.0171, 0.0171, 0.0154, 0.0137,
0.0137, 0.0154)), row.names = c(NA, -6L), class = c("tbl_df",
"tbl", "data.frame"))
# shinydata2 with 10 variables and 184,171 observations
# Column number and header
# 1 - GaugeID (8 digit USGS gauge number, character)
# 2 - DATE (combined YR, MNTH, DY lubridate, date)
# 3 - YR (4 digit year, 1981 - 2014, numeric)
# 4 - MNTH (1 digit month, 1 - 12, numeric)
# 5 - DY (numeric )
# 6 - PRCP (precipitation (PRCP) in mm/day)
# 7 - TAIR (mean daily air temp (TAIR) in celcius)
# 8 - PET (potential evapotranspiration (PET) in mm/day)
# 9 - ET (evapotranspiration (ET) in mm/day from SAC model)
# 10 - OBS_RUN (observed runoff (OBS_RUN) in mm/day from USGS)
# Names correspond to column headers from shinydata2 (PRCP, TAIR, PET, ET, OB_RUN),
# columns 6 through 10, data all numeric
varNames = c("Precipitation",
"Air Temperature",
"Potential ET",
"Actual ET",
"Runoff")
# years are from 1981 to 2014
# column 3 in shinydata2, numeric
years = unique(shinydata2$YR)
months = c("January","February","March","April","May","June",
"July","August","September","October","November","December")
# 8 digit USGS gauge number, 15 total gauges
# column 1 in shinydata2 table, character
gaugeIds = unique(shinydata2$GaugeID)
gaugeNames = c("Turkey Creek near Seneca (06814000)",
"Soldier Creek near Delia (06889200)",
"Marais Des Cygnes River near Reading (06910800)",
"Dragoon Creek near Burlingame (06911900)",
"Chikaskia River near Corbin (07151500)",
"Cedar Creek near Cedar Point (07180500)",
"Timber Creek near Collinsville (08050800)",
"North Fork Guadalupe River near Kyle (08171300)",
"Blanco River near Kyle (08189500)",
"Mission River at Refugio (08189500)",
"East Fork White River near Fort Apache (09492400)",
"White River near Fort Apache (09494000)",
"Cibecue Creek near Chysotile (09497800)",
"Cherry Creek near Globe (09497980)",
"Los Gatos Creek near Coalinga (11224500)")
# gauge latitude values
gaugeLat = as.numeric(c(39.94778, 39.23833, 38.56701, 38.71069, 37.12891,
38.19645, 33.55455, 30.0641, 29.97938, 28.29195,
33.82227, 33.73644, 33.84311, 33.82783, 36.21468))
# gauge longitude values
gaugeLong = as.numeric(c(-96.10862, -95.8886, -95.96163, -95.83603, -97.60144,
-96.82458, -96.94723, -99.38699, -97.91, -97.27916,
-109.81454, -110.16677, -110.55761, -110.85623, -120.47071))
# combine gauge id, latitude and longitude into table
gaugeLatLong = tibble(x = gaugeIds, y = gaugeLat, z = gaugeLong)
# Define user interface
ui = dashboardPage(
dashboardHeader(title = "Test app"),
dashboardSidebar(
# choose which of the 15 gauges to analyze
selectizeInput(inputId = "gauge1",
label = "Choose USGS Stream Gauge",
choices = gaugeNames),
# choose one of the 5 variables
radioButtons(inputId = "variable1",
label = "Choose variable",
choices = varNames),
# select starting year and ending year (time span) for
# analysis, allows for smaller window of time
sliderInput(inputId = "yrRange1",
label = "Select the range of years:",
min = 1981, max = 2014,
value = c(1990, 2000)),
# View outputs for the variable on an annual time scale or monthly
# Monthly will be for the entire year range selected, for example
# range is 1990 - 2000, then the months will be Jan - Dec, totaled or
# averaged over the 10 year span
radioButtons(inputId = "temporal1",
label = "Temporal aggregation:",
choices = c("Annual", "Monthly"))
),
dashboardBody(
fluidRow(
# output summary statistics for the selected variable
# THIS IS NOT DATATABLE, should be TXT, fix
box(title = "Summary Statistics",
solidHeader = TRUE,
DT::dataTableOutput("statsTable"),
width = 4),
# output map that shows the location of the gauge selected
box(leafletOutput("map"), width = 8)
),
fluidRow(
# histogram plot for selected variable, over selected years annually or monthly
box(title = "Histogram",
solidHeader = TRUE,
plotOutput("histPlot"), width = 4),
# boxplot for selected variable over selected range, annually or monthly
box(title = "Box Plot",
solidHeader = TRUE,
plotOutput("boxPlot"),
width = 4),
# line plot for variable over years or months (for all selected years)
box(title = "Time Series Plot",
solidHeader = TRUE,
plotOutput("timePlot"), width = 4)
)
)
)
######### Server
server = function(input, output) {
# create reactive datatable that will update based on user
# inputs for gauge, variable, and time frame
values = reactiveValues(allData = NULL)
# filter datatable based on gauge selected, product table with only
# that gauge (based on shinydata2 table)
observeEvent(input$gauge1, {
values$allData = shinydata2 %>%
group_by(GaugeID, YR, MNTH) %>%
filter(GaugeID == input$gauge1)
})
# now filter the table for the selected gauge by the variable selected,
# table now has the gauge and one variable
observeEvent(input$variable1, {
if(input$variable1 == "Precipitation") {
values$allData = values$allData %>%
group_by(YR, MNTH) %>%
select(PRCP)
} else if(input$variable1 == "Air Temperature") {
values$allData = values$allData %>%
group_by(YR, MNTH) %>%
select(TAIR)
} else if(input$variable1 == "Potential ET") {
values$allData = values$allData %>%
group_by(YR, MNTH) %>%
select(PET)
} else if(input$variable1 == "Actual ET") {
values$allData = values$allData %>%
group_by(YR, MNTH) %>%
select(ET)
} else {
values$allData = values$allData %>%
group_by(YR, MNTH) %>%
select(OBS_RUN)
}
})
# filter the data table that has 1 gauge, 1 variable and select just
# the range of years based on slider
observeEvent(input$yrRange1, {
values$allData = values$allData %>%
group_by(YR, MNTH) %>%
filter(YR >= input$yrRange1[1] &
YR <= input$yrRange1[2])
})
# summary stats for the filtered table (one gauge, one variable, years)
# NOT TABLE
output$statsTable = renderDataTable({
summary(values$allData[[4]])
})
# create reactive to choose the lat/long from gaugeLatLong table
# that corresponds to the gauge selected
gaugeLoc = reactive({
gaugeLatLong %>%
filter(input$gauge1)
})
# show the gauge location on the map for the selected gauge only,
output$map = renderLeaflet({
leaflet(data = gaugeLoc) %>%
addProviderTiles("Jawg.Terrain") %>%
addMarkers(lng = ~z, lat = ~y, popup = ~x)
})
# plots
# selected annual aggregation
output$histPlot = renderPlot({
if (input$temporal1 == "Annual") {
annual1 = values$allData %>%
group_by(YR) %>%
summarise(yr_total = sum(values$allData[[4]]),
yr_mean = mean(values$allData[[4]]))
annualHistPlot = ggplot(data = annual1, aes(x = yr_total)) +
geom_histogram()
#selected monthly aggregation
} else {
month1 = values$allData %>%
group_by(MNTH) %>%
summarise(mnth_total = sum(values$allData[[4]]),
mnth_mean = mean(values$allData[[4]]))
monthHistPlot = ggplot(data = month1, aes(x = month_total)) +
geom_histogram()
}
})
output$timePlot = renderPlot({
if (input$temporal1 == "Annual") {
annual1 = values$allData %>%
group_by(YR) %>%
summarise(yr_total = sum(values$allData[[4]]),
yr_mean = mean(values$allData[[4]]))
annualTimePlot = ggplot(data = annual1, aes(x = YR)) +
geom_line(aes(y = yr_total))
} else {
month1 = values$allData %>%
group_by(MNTH) %>%
summarise(mnth_total = sum(values$allData[[4]]),
mnth_mean = mean(values$allData[[4]]))
monthTimePlot = ggplot(data = annual1, aes(x = MNTH)) +
geom_line(aes(y = mnth_total))
}
})
output$boxPlot = renderPlot({
if (input$temporal1 == "Annual") {
annual1 = values$allData %>%
group_by(YR) %>%
summarise(yr_total = sum(values$allData[[4]]),
yr_mean = mean(values$allData[[4]]))
annualboxPlot = ggplot(data = annual1, aes(x = YR, y = yr_total)) +
geom_boxplot()
} else {
month1 = values$allData %>%
group_by(MNTH) %>%
summarise(mnth_total = sum(values$allData[[4]]),
mnth_mean = mean(values$allData[[4]]))
monthboxPlot = ggplot(data = annual1, aes(x = MNTH, y = mnth_total)) +
geom_boxplot()
}
})
}
shinyApp(ui = ui, server = server)
以下是可进一步适应您的需求的工作版本。一个总体建议是在添加更多 components/complexity.
之前从一个小的工作示例开始
您的一些错误来自数据的过滤方式。例如，您有：
filter(GaugeID == input$gauge1)
但是数据框shinydata2中的GaugeID是：
[1] "06814000" "06814000" "06814000" "06814000" "06814000" "06814000"
但是 input$gauge1 在输入中有来自 choices 的值，这些值来自 gaugeNames 向量：
R> gaugeNames
[1] "Turkey Creek near Seneca (06814000)" "Soldier Creek near Delia (06889200)"
[3] "Marais Des Cygnes River near Reading (06910800)" "Dragoon Creek near Burlingame (06911900)"
[5] "Chikaskia River near Corbin (07151500)" "Cedar Creek near Cedar Point (07180500)"
[7] "Timber Creek near Collinsville (08050800)" "North Fork Guadalupe River near Kyle (08171300)"
[9] "Blanco River near Kyle (08189500)" "Mission River at Refugio (08189500)"
[11] "East Fork White River near Fort Apache (09492400)" "White River near Fort Apache (09494000)"
[13] "Cibecue Creek near Chysotile (09497800)" "Cherry Creek near Globe (09497980)"
[15] "Los Gatos Creek near Coalinga (11224500)"
因此它们永远不会完全匹配，并且过滤器永远不会保留任何数据行。
要解决这个问题，您可以使用命名向量：
gaugeNames = c("Turkey Creek near Seneca (06814000)" = "06814000",
"Soldier Creek near Delia (06889200)" = "06889200",
"Marais Des Cygnes River near Reading (06910800)" = "06910800",
...
然后，当从输入中选择“Turkey Creek near Seneca (06814000)”时，您将获得“06814000”的值，它将与数据框中的 GaugeID 相匹配。
您也可以使用 varNames 和 temporal1 radioButtons 中的 choices 执行此操作（正如我在下面所做的那样）。这对减少不必要的代码也有很大帮助。
另一项建议是合并大量 filter 和 select 语句，这样您就有一个 reactive 表达式来获取不同输出所需的数据。我制作了 shiny_data 这个表达式 - 要引用它，您可以使用 shiny_data().
同样，要从 renderLeaflet 调用 gaugeLoc，您需要将其调用为 gaugeLoc()。另外， filter 的问题是 x 被省略了，你需要：
filter(x == input$gauge1)
为了简化绘图，您可以让每个 renderPlot 使用来自新反应表达式 plot_data 的相同数据。因为你会想要使用group_by和summarise中的输入变量，你可以使用.data[[input$var]]将输入字符串转换为一个符号，以便在dplyr链中使用。
您可能需要为绘图做更多工作才能使它们按您希望的方式工作。但我希望这将有助于前进。祝你好运！
library(shiny)
library(shinydashboard)
library(lubridate)
library(DT)
library(ggplot2)
library(dplyr)
library(leaflet)
library(tidyr)
shinydata2 <- structure(list(GaugeID = c("06814000", "06814000", "06814000",
"06814000", "06814000", "06814000"), DATE = structure(c(4018,
4019, 4020, 4021, 4022, 4023), class = "Date"), YR = c(1981,
1982, 1983, 1984, 1985, 1986), MNTH = c(1, 1, 1, 1, 1, 1), DY = c(1,
2, 3, 4, 5, 6), PRCP = c(0, 0, 0, 0, 0, 0), TAIR = c(2.36, 0.71,
-1.62, -7.365, -3.03, 0.185), PET = c(0.4185, 0.3206, 0.3215,
0.3189, 0.3441, 0.4074), ET = c(0.4064, 0.31, 0.3102, 0.307,
0.3308, 0.3909), OBS_RUN = c(0.0171, 0.0171, 0.0154, 0.0137,
0.0137, 0.0154)), row.names = c(NA, -6L), class = c("tbl_df",
"tbl", "data.frame"))
# Make this a named vector
varNames = c("Precipitation" = "PRCP",
"Air Temperature" = "TAIR",
"Potential ET" = "PET",
"Actual ET" = "ET",
"Runoff" = "OBS_RUN")
years = unique(shinydata2$YR)
# If you need name of months, use "month.name"
gaugeIds = unique(shinydata2$GaugeID)
# Make this a named vector
gaugeNames = c("Turkey Creek near Seneca (06814000)" = "06814000",
"Soldier Creek near Delia (06889200)" = "06889200",
"Marais Des Cygnes River near Reading (06910800)" = "06910800",
"Dragoon Creek near Burlingame (06911900)" = "06911900",
"Chikaskia River near Corbin (07151500)" = "07151500",
"Cedar Creek near Cedar Point (07180500)" = "07180500",
"Timber Creek near Collinsville (08050800)" = "08050800",
"North Fork Guadalupe River near Kyle (08171300)" = "08171300",
"Blanco River near Kyle (08189500)" = "08189500",
"Mission River at Refugio (08189500)" = "08189500",
"East Fork White River near Fort Apache (09492400)" = "09492400",
"White River near Fort Apache (09494000)" = "09494000",
"Cibecue Creek near Chysotile (09497800)" = "09497800",
"Cherry Creek near Globe (09497980)" = "09497980",
"Los Gatos Creek near Coalinga (11224500)" = "11224500")
gaugeLat = as.numeric(c(39.94778, 39.23833, 38.56701, 38.71069, 37.12891,
38.19645, 33.55455, 30.0641, 29.97938, 28.29195,
33.82227, 33.73644, 33.84311, 33.82783, 36.21468))
gaugeLong = as.numeric(c(-96.10862, -95.8886, -95.96163, -95.83603, -97.60144,
-96.82458, -96.94723, -99.38699, -97.91, -97.27916,
-109.81454, -110.16677, -110.55761, -110.85623, -120.47071))
gaugeLatLong = tibble(x = gaugeIds, y = gaugeLat, z = gaugeLong)
# Define user interface
ui = dashboardPage(
dashboardHeader(title = "Test app"),
dashboardSidebar(
selectizeInput(inputId = "gauge1",
label = "Choose USGS Stream Gauge",
choices = gaugeNames),
radioButtons(inputId = "variable1",
label = "Choose variable",
choices = varNames),
sliderInput(inputId = "yrRange1",
label = "Select the range of years:",
min = 1981, max = 2014,
value = c(1981, 2000)),
radioButtons(inputId = "temporal1",
label = "Temporal aggregation:",
choices = c("Annual" = "YR", "Monthly" = "MNTH"))
),
dashboardBody(
fluidRow(
box(title = "Summary Statistics",
solidHeader = TRUE,
verbatimTextOutput("statsTable"),
width = 5),
box(leafletOutput("map"), width = 7)
),
fluidRow(
box(title = "Histogram",
solidHeader = TRUE,
plotOutput("histPlot"), width = 4),
box(title = "Box Plot",
solidHeader = TRUE,
plotOutput("boxPlot"),
width = 4),
box(title = "Time Series Plot",
solidHeader = TRUE,
plotOutput("timePlot"), width = 4)
)
)
)
######### Server
server = function(input, output) {
shiny_data <- reactive({
shinydata2 %>%
group_by(GaugeID, YR, MNTH) %>%
filter(GaugeID == input$gauge1,
YR >= input$yrRange1[1],
YR <= input$yrRange1[2]) %>%
select(YR, MNTH, input$variable1)
})
output$statsTable = renderPrint({
enframe(summary(shiny_data()[[input$variable1]]))
})
gaugeLoc <- reactive({
gaugeLatLong %>%
filter(x == input$gauge1)
})
output$map = renderLeaflet({
leaflet(data = gaugeLoc()) %>%
addProviderTiles("Stamen.Watercolor") %>%
addMarkers(lng = ~z, lat = ~y, popup = ~x)
})
plot_data <- reactive({
shiny_data() %>%
group_by(.data[[input$temporal1]]) %>%
summarise(total = sum(.data[[input$variable1]]),
mean = mean(.data[[input$variable1]]))
})
output$histPlot = renderPlot({
ggplot(data = plot_data(), aes(x = total)) +
geom_histogram(binwidth = 1)
})
output$timePlot = renderPlot({
ggplot(data = plot_data(), aes(x = .data[[input$temporal1]], y = total)) +
geom_line()
})
output$boxPlot = renderPlot({
ggplot(data = plot_data(), aes(x = .data[[input$temporal1]], y = total)) +
geom_boxplot()
})
}
shinyApp(ui = ui, server = server)
我是 R 和 Shiny 的新手，所以请原谅我的无知。我有一个大数据集（184,171 个观察值和 10 个变量）作为 tibble。我正在尝试创建一个使用此数据 table 的 Shiny 应用程序。用户选择一个量表，然后选择一个要分析的变量、一个年份范围，然后选择他们希望每年还是每月汇总变量。根据输入，它将为所选仪表创建 3 个地块和一个位置图，以及汇总统计数据。 运行 我的用户界面部分没有问题。我知道问题出在我的服务器上。我想知道我是否在使用响应式 Values() 并正确观察事件。
原始数据集是 shinydata，我正在尝试制作一个基于用户输入进行过滤的反应性数据 table。我的错误包括：
在传单输出箱中展示 没有适用于元数据的适用方法应用于 class 反应式 Expr、反应式、函数
的对象显示在摘要统计框中 数据必须是二维的（例如数据框或矩阵） -> 我知道这是因为我需要使用文本输出而不是数据 table 来获取摘要统计信息
在方框中显示和时间序列图输出 未找到对象 annual1
我已经为此苦苦挣扎了 3 天，并在网上搜索答案。任何见解将不胜感激！
# load libraries
library(shiny)
library(shinydashboard)
library(lubridate)
library(DT)
library(ggplot2)
library(dplyr)
library(leaflet)
library(tidyr)
# Read in datatable/tibble that was saved and exported as RDS
# from gauge script
# Modify table by removing columns SWE, RAIM, MOD_RUN
# and move date column from the last row to second row
shinydata = readRDS("C:/Users/.../shinydata.rds")
shinydata2 = shinydata[-c(5,7,11)]
shinydata2 = shinydata2 %>% relocate(DATE, .before = "YR")
> dput(head(shinydata2))
structure(list(GaugeID = c("06814000", "06814000", "06814000",
"06814000", "06814000", "06814000"), DATE = structure(c(4018,
4019, 4020, 4021, 4022, 4023), class = "Date"), YR = c(1981,
1981, 1981, 1981, 1981, 1981), MNTH = c(1, 1, 1, 1, 1, 1), DY = c(1,
2, 3, 4, 5, 6), PRCP = c(0, 0, 0, 0, 0, 0), TAIR = c(2.36, 0.71,
-1.62, -7.365, -3.03, 0.185), PET = c(0.4185, 0.3206, 0.3215,
0.3189, 0.3441, 0.4074), ET = c(0.4064, 0.31, 0.3102, 0.307,
0.3308, 0.3909), OBS_RUN = c(0.0171, 0.0171, 0.0154, 0.0137,
0.0137, 0.0154)), row.names = c(NA, -6L), class = c("tbl_df",
"tbl", "data.frame"))
# shinydata2 with 10 variables and 184,171 observations
# Column number and header
# 1 - GaugeID (8 digit USGS gauge number, character)
# 2 - DATE (combined YR, MNTH, DY lubridate, date)
# 3 - YR (4 digit year, 1981 - 2014, numeric)
# 4 - MNTH (1 digit month, 1 - 12, numeric)
# 5 - DY (numeric )
# 6 - PRCP (precipitation (PRCP) in mm/day)
# 7 - TAIR (mean daily air temp (TAIR) in celcius)
# 8 - PET (potential evapotranspiration (PET) in mm/day)
# 9 - ET (evapotranspiration (ET) in mm/day from SAC model)
# 10 - OBS_RUN (observed runoff (OBS_RUN) in mm/day from USGS)
# Names correspond to column headers from shinydata2 (PRCP, TAIR, PET, ET, OB_RUN),
# columns 6 through 10, data all numeric
varNames = c("Precipitation",
"Air Temperature",
"Potential ET",
"Actual ET",
"Runoff")
# years are from 1981 to 2014
# column 3 in shinydata2, numeric
years = unique(shinydata2$YR)
months = c("January","February","March","April","May","June",
"July","August","September","October","November","December")
# 8 digit USGS gauge number, 15 total gauges
# column 1 in shinydata2 table, character
gaugeIds = unique(shinydata2$GaugeID)
gaugeNames = c("Turkey Creek near Seneca (06814000)",
"Soldier Creek near Delia (06889200)",
"Marais Des Cygnes River near Reading (06910800)",
"Dragoon Creek near Burlingame (06911900)",
"Chikaskia River near Corbin (07151500)",
"Cedar Creek near Cedar Point (07180500)",
"Timber Creek near Collinsville (08050800)",
"North Fork Guadalupe River near Kyle (08171300)",
"Blanco River near Kyle (08189500)",
"Mission River at Refugio (08189500)",
"East Fork White River near Fort Apache (09492400)",
"White River near Fort Apache (09494000)",
"Cibecue Creek near Chysotile (09497800)",
"Cherry Creek near Globe (09497980)",
"Los Gatos Creek near Coalinga (11224500)")
# gauge latitude values
gaugeLat = as.numeric(c(39.94778, 39.23833, 38.56701, 38.71069, 37.12891,
38.19645, 33.55455, 30.0641, 29.97938, 28.29195,
33.82227, 33.73644, 33.84311, 33.82783, 36.21468))
# gauge longitude values
gaugeLong = as.numeric(c(-96.10862, -95.8886, -95.96163, -95.83603, -97.60144,
-96.82458, -96.94723, -99.38699, -97.91, -97.27916,
-109.81454, -110.16677, -110.55761, -110.85623, -120.47071))
# combine gauge id, latitude and longitude into table
gaugeLatLong = tibble(x = gaugeIds, y = gaugeLat, z = gaugeLong)
# Define user interface
ui = dashboardPage(
dashboardHeader(title = "Test app"),
dashboardSidebar(
# choose which of the 15 gauges to analyze
selectizeInput(inputId = "gauge1",
label = "Choose USGS Stream Gauge",
choices = gaugeNames),
# choose one of the 5 variables
radioButtons(inputId = "variable1",
label = "Choose variable",
choices = varNames),
# select starting year and ending year (time span) for
# analysis, allows for smaller window of time
sliderInput(inputId = "yrRange1",
label = "Select the range of years:",
min = 1981, max = 2014,
value = c(1990, 2000)),
# View outputs for the variable on an annual time scale or monthly
# Monthly will be for the entire year range selected, for example
# range is 1990 - 2000, then the months will be Jan - Dec, totaled or
# averaged over the 10 year span
radioButtons(inputId = "temporal1",
label = "Temporal aggregation:",
choices = c("Annual", "Monthly"))
),
dashboardBody(
fluidRow(
# output summary statistics for the selected variable
# THIS IS NOT DATATABLE, should be TXT, fix
box(title = "Summary Statistics",
solidHeader = TRUE,
DT::dataTableOutput("statsTable"),
width = 4),
# output map that shows the location of the gauge selected
box(leafletOutput("map"), width = 8)
),
fluidRow(
# histogram plot for selected variable, over selected years annually or monthly
box(title = "Histogram",
solidHeader = TRUE,
plotOutput("histPlot"), width = 4),
# boxplot for selected variable over selected range, annually or monthly
box(title = "Box Plot",
solidHeader = TRUE,
plotOutput("boxPlot"),
width = 4),
# line plot for variable over years or months (for all selected years)
box(title = "Time Series Plot",
solidHeader = TRUE,
plotOutput("timePlot"), width = 4)
)
)
)
######### Server
server = function(input, output) {
# create reactive datatable that will update based on user
# inputs for gauge, variable, and time frame
values = reactiveValues(allData = NULL)
# filter datatable based on gauge selected, product table with only
# that gauge (based on shinydata2 table)
observeEvent(input$gauge1, {
values$allData = shinydata2 %>%
group_by(GaugeID, YR, MNTH) %>%
filter(GaugeID == input$gauge1)
})
# now filter the table for the selected gauge by the variable selected,
# table now has the gauge and one variable
observeEvent(input$variable1, {
if(input$variable1 == "Precipitation") {
values$allData = values$allData %>%
group_by(YR, MNTH) %>%
select(PRCP)
} else if(input$variable1 == "Air Temperature") {
values$allData = values$allData %>%
group_by(YR, MNTH) %>%
select(TAIR)
} else if(input$variable1 == "Potential ET") {
values$allData = values$allData %>%
group_by(YR, MNTH) %>%
select(PET)
} else if(input$variable1 == "Actual ET") {
values$allData = values$allData %>%
group_by(YR, MNTH) %>%
select(ET)
} else {
values$allData = values$allData %>%
group_by(YR, MNTH) %>%
select(OBS_RUN)
}
})
# filter the data table that has 1 gauge, 1 variable and select just
# the range of years based on slider
observeEvent(input$yrRange1, {
values$allData = values$allData %>%
group_by(YR, MNTH) %>%
filter(YR >= input$yrRange1[1] &
YR <= input$yrRange1[2])
})
# summary stats for the filtered table (one gauge, one variable, years)
# NOT TABLE
output$statsTable = renderDataTable({
summary(values$allData[[4]])
})
# create reactive to choose the lat/long from gaugeLatLong table
# that corresponds to the gauge selected
gaugeLoc = reactive({
gaugeLatLong %>%
filter(input$gauge1)
})
# show the gauge location on the map for the selected gauge only,
output$map = renderLeaflet({
leaflet(data = gaugeLoc) %>%
addProviderTiles("Jawg.Terrain") %>%
addMarkers(lng = ~z, lat = ~y, popup = ~x)
})
# plots
# selected annual aggregation
output$histPlot = renderPlot({
if (input$temporal1 == "Annual") {
annual1 = values$allData %>%
group_by(YR) %>%
summarise(yr_total = sum(values$allData[[4]]),
yr_mean = mean(values$allData[[4]]))
annualHistPlot = ggplot(data = annual1, aes(x = yr_total)) +
geom_histogram()
#selected monthly aggregation
} else {
month1 = values$allData %>%
group_by(MNTH) %>%
summarise(mnth_total = sum(values$allData[[4]]),
mnth_mean = mean(values$allData[[4]]))
monthHistPlot = ggplot(data = month1, aes(x = month_total)) +
geom_histogram()
}
})
output$timePlot = renderPlot({
if (input$temporal1 == "Annual") {
annual1 = values$allData %>%
group_by(YR) %>%
summarise(yr_total = sum(values$allData[[4]]),
yr_mean = mean(values$allData[[4]]))
annualTimePlot = ggplot(data = annual1, aes(x = YR)) +
geom_line(aes(y = yr_total))
} else {
month1 = values$allData %>%
group_by(MNTH) %>%
summarise(mnth_total = sum(values$allData[[4]]),
mnth_mean = mean(values$allData[[4]]))
monthTimePlot = ggplot(data = annual1, aes(x = MNTH)) +
geom_line(aes(y = mnth_total))
}
})
output$boxPlot = renderPlot({
if (input$temporal1 == "Annual") {
annual1 = values$allData %>%
group_by(YR) %>%
summarise(yr_total = sum(values$allData[[4]]),
yr_mean = mean(values$allData[[4]]))
annualboxPlot = ggplot(data = annual1, aes(x = YR, y = yr_total)) +
geom_boxplot()
} else {
month1 = values$allData %>%
group_by(MNTH) %>%
summarise(mnth_total = sum(values$allData[[4]]),
mnth_mean = mean(values$allData[[4]]))
monthboxPlot = ggplot(data = annual1, aes(x = MNTH, y = mnth_total)) +
geom_boxplot()
}
})
}
shinyApp(ui = ui, server = server)
以下是可进一步适应您的需求的工作版本。一个总体建议是在添加更多 components/complexity.
之前从一个小的工作示例开始您的一些错误来自数据的过滤方式。例如，您有：
filter(GaugeID == input$gauge1)
但是数据框shinydata2中的GaugeID是：
[1] "06814000" "06814000" "06814000" "06814000" "06814000" "06814000"
但是 input$gauge1 在输入中有来自 choices 的值，这些值来自 gaugeNames 向量：
R> gaugeNames
[1] "Turkey Creek near Seneca (06814000)" "Soldier Creek near Delia (06889200)"
[3] "Marais Des Cygnes River near Reading (06910800)" "Dragoon Creek near Burlingame (06911900)"
[5] "Chikaskia River near Corbin (07151500)" "Cedar Creek near Cedar Point (07180500)"
[7] "Timber Creek near Collinsville (08050800)" "North Fork Guadalupe River near Kyle (08171300)"
[9] "Blanco River near Kyle (08189500)" "Mission River at Refugio (08189500)"
[11] "East Fork White River near Fort Apache (09492400)" "White River near Fort Apache (09494000)"
[13] "Cibecue Creek near Chysotile (09497800)" "Cherry Creek near Globe (09497980)"
[15] "Los Gatos Creek near Coalinga (11224500)"
因此它们永远不会完全匹配，并且过滤器永远不会保留任何数据行。
要解决这个问题，您可以使用命名向量：
gaugeNames = c("Turkey Creek near Seneca (06814000)" = "06814000",
"Soldier Creek near Delia (06889200)" = "06889200",
"Marais Des Cygnes River near Reading (06910800)" = "06910800",
...
然后，当从输入中选择“Turkey Creek near Seneca (06814000)”时，您将获得“06814000”的值，它将与数据框中的 GaugeID 相匹配。
您也可以使用 varNames 和 temporal1 radioButtons 中的 choices 执行此操作（正如我在下面所做的那样）。这对减少不必要的代码也有很大帮助。
另一项建议是合并大量 filter 和 select 语句，这样您就有一个 reactive 表达式来获取不同输出所需的数据。我制作了 shiny_data 这个表达式 - 要引用它，您可以使用 shiny_data().
同样，要从 renderLeaflet 调用 gaugeLoc，您需要将其调用为 gaugeLoc()。另外， filter 的问题是 x 被省略了，你需要：
filter(x == input$gauge1)
为了简化绘图，您可以让每个 renderPlot 使用来自新反应表达式 plot_data 的相同数据。因为你会想要使用group_by和summarise中的输入变量，你可以使用.data[[input$var]]将输入字符串转换为一个符号，以便在dplyr链中使用。
您可能需要为绘图做更多工作才能使它们按您希望的方式工作。但我希望这将有助于前进。祝你好运！
library(shiny)
library(shinydashboard)
library(lubridate)
library(DT)
library(ggplot2)
library(dplyr)
library(leaflet)
library(tidyr)
shinydata2 <- structure(list(GaugeID = c("06814000", "06814000", "06814000",
"06814000", "06814000", "06814000"), DATE = structure(c(4018,
4019, 4020, 4021, 4022, 4023), class = "Date"), YR = c(1981,
1982, 1983, 1984, 1985, 1986), MNTH = c(1, 1, 1, 1, 1, 1), DY = c(1,
2, 3, 4, 5, 6), PRCP = c(0, 0, 0, 0, 0, 0), TAIR = c(2.36, 0.71,
-1.62, -7.365, -3.03, 0.185), PET = c(0.4185, 0.3206, 0.3215,
0.3189, 0.3441, 0.4074), ET = c(0.4064, 0.31, 0.3102, 0.307,
0.3308, 0.3909), OBS_RUN = c(0.0171, 0.0171, 0.0154, 0.0137,
0.0137, 0.0154)), row.names = c(NA, -6L), class = c("tbl_df",
"tbl", "data.frame"))
# Make this a named vector
varNames = c("Precipitation" = "PRCP",
"Air Temperature" = "TAIR",
"Potential ET" = "PET",
"Actual ET" = "ET",
"Runoff" = "OBS_RUN")
years = unique(shinydata2$YR)
# If you need name of months, use "month.name"
gaugeIds = unique(shinydata2$GaugeID)
# Make this a named vector
gaugeNames = c("Turkey Creek near Seneca (06814000)" = "06814000",
"Soldier Creek near Delia (06889200)" = "06889200",
"Marais Des Cygnes River near Reading (06910800)" = "06910800",
"Dragoon Creek near Burlingame (06911900)" = "06911900",
"Chikaskia River near Corbin (07151500)" = "07151500",
"Cedar Creek near Cedar Point (07180500)" = "07180500",
"Timber Creek near Collinsville (08050800)" = "08050800",
"North Fork Guadalupe River near Kyle (08171300)" = "08171300",
"Blanco River near Kyle (08189500)" = "08189500",
"Mission River at Refugio (08189500)" = "08189500",
"East Fork White River near Fort Apache (09492400)" = "09492400",
"White River near Fort Apache (09494000)" = "09494000",
"Cibecue Creek near Chysotile (09497800)" = "09497800",
"Cherry Creek near Globe (09497980)" = "09497980",
"Los Gatos Creek near Coalinga (11224500)" = "11224500")
gaugeLat = as.numeric(c(39.94778, 39.23833, 38.56701, 38.71069, 37.12891,
38.19645, 33.55455, 30.0641, 29.97938, 28.29195,
33.82227, 33.73644, 33.84311, 33.82783, 36.21468))
gaugeLong = as.numeric(c(-96.10862, -95.8886, -95.96163, -95.83603, -97.60144,
-96.82458, -96.94723, -99.38699, -97.91, -97.27916,
-109.81454, -110.16677, -110.55761, -110.85623, -120.47071))
gaugeLatLong = tibble(x = gaugeIds, y = gaugeLat, z = gaugeLong)
# Define user interface
ui = dashboardPage(
dashboardHeader(title = "Test app"),
dashboardSidebar(
selectizeInput(inputId = "gauge1",
label = "Choose USGS Stream Gauge",
choices = gaugeNames),
radioButtons(inputId = "variable1",
label = "Choose variable",
choices = varNames),
sliderInput(inputId = "yrRange1",
label = "Select the range of years:",
min = 1981, max = 2014,
value = c(1981, 2000)),
radioButtons(inputId = "temporal1",
label = "Temporal aggregation:",
choices = c("Annual" = "YR", "Monthly" = "MNTH"))
),
dashboardBody(
fluidRow(
box(title = "Summary Statistics",
solidHeader = TRUE,
verbatimTextOutput("statsTable"),
width = 5),
box(leafletOutput("map"), width = 7)
),
fluidRow(
box(title = "Histogram",
solidHeader = TRUE,
plotOutput("histPlot"), width = 4),
box(title = "Box Plot",
solidHeader = TRUE,
plotOutput("boxPlot"),
width = 4),
box(title = "Time Series Plot",
solidHeader = TRUE,
plotOutput("timePlot"), width = 4)
)
)
)
######### Server
server = function(input, output) {
shiny_data <- reactive({
shinydata2 %>%
group_by(GaugeID, YR, MNTH) %>%
filter(GaugeID == input$gauge1,
YR >= input$yrRange1[1],
YR <= input$yrRange1[2]) %>%
select(YR, MNTH, input$variable1)
})
output$statsTable = renderPrint({
enframe(summary(shiny_data()[[input$variable1]]))
})
gaugeLoc <- reactive({
gaugeLatLong %>%
filter(x == input$gauge1)
})
output$map = renderLeaflet({
leaflet(data = gaugeLoc()) %>%
addProviderTiles("Stamen.Watercolor") %>%
addMarkers(lng = ~z, lat = ~y, popup = ~x)
})
plot_data <- reactive({
shiny_data() %>%
group_by(.data[[input$temporal1]]) %>%
summarise(total = sum(.data[[input$variable1]]),
mean = mean(.data[[input$variable1]]))
})
output$histPlot = renderPlot({
ggplot(data = plot_data(), aes(x = total)) +
geom_histogram(binwidth = 1)
})
output$timePlot = renderPlot({
ggplot(data = plot_data(), aes(x = .data[[input$temporal1]], y = total)) +
geom_line()
})
output$boxPlot = renderPlot({
ggplot(data = plot_data(), aes(x = .data[[input$temporal1]], y = total)) +
geom_boxplot()
})
}
shinyApp(ui = ui, server = server)