#r #shiny #dashboard
#r #блестящий #Информационная панель
Вопрос:
Я новичок в R и Shiny, поэтому, пожалуйста, простите мое невежество. У меня есть большой набор данных (184 171 наблюдений и 10 переменных) в виде tibble. Я пытаюсь создать блестящее приложение, которое использует эту таблицу данных. Пользователь выбирает показатель, затем переменную для анализа, диапазон лет, а затем хочет, чтобы переменная агрегировалась ежегодно или ежемесячно. На основе входных данных он создаст 3 графика и карту местоположения для выбранного датчика, а также сводную статистику. У меня нет проблем при запуске моей части пользовательского интерфейса. Я знаю, что проблемы кроются в моем сервере. Я хочу знать, правильно ли я использую реактивные значения () и правильно ли наблюдаю событие.
Исходный набор данных — shinydata, и я пытаюсь создать таблицу реактивных данных, которая фильтрует на основе пользовательских данных. Мои ошибки включают:
В окне вывода листовки не отображается
применимый метод для метаданных, примененных к объекту класса reactive Expr, reactive, function
данные должны быть 2-мерными (например, фрейм данных или матрица)
, отображаемые в окне сводной статистики -> Я знаю, это потому, что мне нужно использовать текстовый вывод вместо таблицы данных для сводной статистики
Отображает в поле и выводит график временных рядов
объект 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] amp;
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)
Комментарии:
1. Можете ли вы поделиться образцом своих данных, чтобы создать воспроизводимый пример? Возможно
dput(head(shinydata2)), а затем отредактируйте свой вопрос с результатом.2. Да, я только что добавил это. Спасибо, я не был уверен, как это сделать.
Ответ №1:
Ниже приведена рабочая версия для дальнейшей адаптации к вашим потребностям. Одна из общих рекомендаций — начать с небольшого рабочего примера, прежде чем добавлять дополнительные компоненты / сложность.
Некоторые из ваших ошибок возникли из-за того, как фильтровались данные. Например, у вас есть:
filter(GaugeID == input$gauge1)
Но GaugeID во фрейме данных shinydata2 :
[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 помощью и choices в вашем temporal1 radioButtons (как я сделал ниже). Это также очень поможет с точки зрения сокращения ненужного кода.
Еще одна рекомендация — объединить множество ваших filter select операторов and , чтобы у вас было одно reactive выражение для получения данных, необходимых для разных результатов. Я создал shiny_data это выражение — и чтобы ссылаться на него, вы используете shiny_data() .
Аналогично, для вызова gaugeLoc from renderLeaflet вам нужно вызвать его как gaugeLoc() . Кроме того, проблема с filter there заключается в том, что 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)