Heute schauen wir uns an, wie wir Umweltdaten in Kombination mit einem Vorhersage-Modell in einem interaktiven Dashboard visualisieren und dieses dann unseren Nutzern zur Verfügung stellen können. Wir erstellen dazu zunächst ein Dashboard mit R Shiny und deployen dieses final über Heroku.
Spätestens seit Corona kennt sie jeder: Dashboards. Das sind interaktive Datenvisualisierungen, die es Nutzern beispielsweise erlauben durch Eingaben (Inputs) die dargestellten Daten zu filtern oder die Darstellungsweise zu manipulieren. Damit bieten Dashboards einen extrem niedrigschwelligen Zugang zu teils sehr komplexen Datensätzen und sind heute in Unternehmen, aber auch beispielsweise in der Presse nicht mehr wegzudenken.
Was brauchen wir nun für die heutige Übung?
Zunächst einmal Daten. Diese stammen von einer Wetterstation in Kaiserslautern in Rheinland-Pfalz und wurden über die NCEI data ordering services der National Oceanic and Atmospheric Administration bezogen.
Auf Basis dieser Daten wurde dann eine Shiny-App gebastelt, die auch eine Option zur Zeitreihenanalyse bzw. -vorhersage beinhaltet. Final musste diese App dann noch auf einen Server gepackt werden; dazu kam der Service Heroku zum Einsatz.
Und so sieht das finale Produkt aus:
Wer das Ganze in Aktion ausprobieren möchte, der klickt hier.
Und nun, lasst uns beginnen.
Shiny-Apps haben immer drei Teile: eine User Interface-Funktion (analog zum Frontend), eine Serverfunktion (analog zum Backend) und final die Funktion shinyApp(). Für unsere App packen wir all diese Teile in ein Skript und nennen dieses app.R. Warum wir diesen Namen wählen, sehen wir im weiteren Verlauf.
In diesem Skript laden wir dann zunächst alle Libraries, die wir für unsere App brauchen und anschließend unsere Daten.
# Libraries
library("shiny")
library("shinydashboard")
library("shinyjs")
library("ggplot2")
library("dplyr")
library("readr")
library("zoo")
library("forecast")
library("plotly")
# Load data ----
dat <- read_csv(file = "KA_Climate_year_clean.csv")Nun noch schnell zwei kleine helper functions. Diese dienen dazu, die Variablennamen in unserem Datensatz in der App etwas schöner darzustellen. Unterstriche werden durch Leerzeichen ersetzt, kleine Anfangsbuchstaben durch große.
#Helper functions ----
metric_choices <- colnames(dat)[2:ncol(dat)]
metric_names <- gsub("_", " ", metric_choices)
metric_names <- paste0(toupper(substr(metric_names,1,1)), substr(metric_names,2,nchar(metric_names)))
metric_list <- as.list(metric_choices)
names(metric_list) <- metric_names
name_fix <- function(x){
s1 <- gsub("_", " ", x)
s2 <- paste0(toupper(substr(s1,1,1)), substr(s1,2,nchar(s1)))
return(s2)
}Nun geht es mit der Funktion ui(), also dem User Interface ans Eingemachte.
Dann setzen wir den Rahmen für die Seitenleiste. Hier passiert tatsächlich nicht viel, außer, dass wir für einen kleinen Effekt JavaScript verfügbar machen (shinyjs) und auf die in der Server-Funktion definierten Inputs verweisen (uiOutput).
Dann kommen wir unter „Panels“ zum Dashboard-Body. Hier wird zunächst definiert, dass wir zwei Tabs in der App haben wollen; einen für Temperaturdaten und einen für Niederschlagsdaten. Im jeweiligen Tab wird dann der entsprechende Plot sowie das Vorhersage-Panel aufgerufen.
# UI ----
ui <- dashboardPage(
skin = "green",
#### Header ----
dashboardHeader(
title = "Kaiserslautern Climate Dashboard",
titleWidth = 350,
tags$li(a(href = 'https://zubrod-eds.de', target="_blank",
img(src = 'Mail_Logo.png',
title = "Zubrod EDS", height = "30px"),
style = "padding-top:10px; padding-bottom:10px;"),
class = "dropdown")
),
#### Sidebar ----
dashboardSidebar(
shinyjs::useShinyjs(),
width = 350,
br(),
h4("Select your inputs ", style = "padding-left:20px"),
uiOutput("sidebar")
),
#### Panels ----
dashboardBody(
tabsetPanel(
type = "tabs",
id = "tab_selected",
tabPanel(
title = "Temperature",
plotlyOutput("temp_plot"),
uiOutput("temp_forecast_panel")
),
tabPanel(
# 2 - Regional View ----
title = "Precipitation",
plotlyOutput("prec_plot"),
uiOutput("prec_forecast_panel")
)
)
)
)Jetzt wird es in der Server-Funktion noch ein wenig komplexer. Ich stelle sie daher unten häppchenweise vor. Ihr könnt sie euch aber in meinem GitHub-Repository auch in Gänze anschauen.
Zunächst brauchen wir eine logische Kontrolle für die Vorhersagen. Bei jedem Neuladen der App und bei jedem Tab-Wechsel soll der Grundzustand (d.h. keine Vorhersage) erreicht werden.
Dann werden die Daten entsprechend der Nutzer-Inputs gefiltert (anhand des gewählten Zeitraums) und selektiert (anhand der gewählten Metriken).
# Server ----
server <- function(input, output) {
#### Control forecast ----
make_forecast_temp <- reactiveValues(value=0)
make_forecast_prec <- reactiveValues(value=0)
observeEvent(input$tab_selected, {
make_forecast_temp$value <- 0
make_forecast_prec$value <- 0
})
#### Clean data ----
clean_data <- reactive({
req(input$year_range)
dat %>%
filter(year >= input$year_range[1] & year <= input$year_range[2]) %>%
select(year, input$metric) %>%
arrange(year)
})Dann kommen wir zur etwas mächtigen Plot-Funktion, die sich das Paket Plotly zunutze macht, das als interaktiver Wrapper um ggplot fungiert. Nach kleineren Vorarbeiten, kommen wir hier schnell zu einer Schleife, die für jede vom Nutzer gewählte Metrik einmal durchlaufen wird und für jede Metrik dem Plot eine Trace hinzufügt.
Innerhalb der Schleife gibt es dann zwei if-Abfragen. Die erste fragt ab, ob der Nutzer ein Moving Average erfragt. Wenn ja, wird dieses berechnet und ebenfalls als Trace dem Plot hinzugefügt.
Die zweite if-Abfrage dient der Vorhersage. Falls vom Nutzer gewünscht, wird hier eine Auto-ARIMA (AutoRegressive Integrated Moving Averages)zur Zeitreihenanalyse herangezogen. Für diese werden dem Plot dann je Metrik drei zusätzliche Traces hinzugefügt: die mittlere Vorhersage sowie das untere und obere 95%-Konfidenzlimit.
Falls ihr das später in der App ausprobiert: die Auto-ARIMA-Vorhersagen sind relativ nichtssagend, da sie nur einen gleichbleibenden Wert produzieren. Entweder Auto-ARIMA war hier nicht das Mittel der Wahl oder die Daten beinhalten keinen klaren Trend. Mir ging es hier aber darum, euch die technische Implementierung von Modellvorhersagen in einem Dashboard nahezubringen. Für diesen Zweck ist Auto-ARIMA ausreichend.
Zuletzt rendern wir in diesem Abschnitt noch die Plots, damit sie an das User Interface übergeben werden können.
#### Plot data ----
plot_data <- function(data){
L <- colnames(data)[2:ncol(data)]
x <- list(title = "Year")
ifelse(input$tab_selected == "Temperature", y <- list( title = "Temperature in °C"),
y <- list( title = "Precipitation in mm"))
coleurs <- c("orange", "blue", "green", "red", "purple")
plt <- plot_ly(data = data)
for(k in 1:length(L)) {
dfk <- data.frame(y=data[[L[k]]], year=data$year)
plt <- add_trace(plt, y=~y, x=~year, data=dfk,
type="scatter", mode="lines+markers", name = name_fix(L[k]),
color = coleurs[k], hovertemplate = paste(
paste0('<extra>Actuals</extra>',name_fix(L[k]),': %{y}\nYear: %{x}'))
)
if( input$moving_average == TRUE & !is.null(input$moving_average_years) ){
dfk <- data.frame(y=rollmean(data[[L[k]]],ma_years(),mean,align='right',fill=NA),
year = data$year)
plt <- add_trace(plt, y=~y, x=~year, data=dfk,
type="scatter", mode='lines', line=list(dash="dash"), showlegend=F,
name = name_fix(L[k]), color = coleurs[k], hovertemplate = paste(
paste0('<extra>Moving average</extra>',name_fix(L[k]),': %{y}\nYear: %{x}'))
)
}
if( make_forecast_temp$value == 1 | make_forecast_prec$value == 1 ){
auto_forecast <- forecast(auto.arima(data[L[k]]),forecast_years())
new_years <- max(data$year) + c(1:forecast_years())
dfk <- data.frame(mean=auto_forecast$mean, lcl=auto_forecast$lower[2],
ucl=auto_forecast$upper[2], year = new_years)
plt <- add_trace(plt, y=~mean, x=~year, data= dfk,
type="scatter", mode='lines', line=list(dash="dot"), showlegend=F,
name = name_fix(L[k]), color = coleurs[k], hovertemplate = paste(
paste0('<extra>Forecast mean</extra>',name_fix(L[k]),': %{y}\nYear: %{x}'))
)
plt <- add_trace(plt, y=~lcl, x=~year, data= dfk,
type="scatter", mode='lines', line=list(dash="dot", width=0.5), showlegend=F,
name = name_fix(L[k]), color = coleurs[k], hovertemplate = paste(
paste0('<extra>Forecast LCL</extra>',name_fix(L[k]),': %{y}\nYear: %{x}'))
)
plt <- add_trace(plt, y=~ucl, x=~year, data= dfk,
type="scatter", mode='lines', line=list(dash="dot", width=0.5), showlegend=F,
name = name_fix(L[k]), color = coleurs[k], hovertemplate = paste(
paste0('<extra>Forecast UCL</extra>',name_fix(L[k]),': %{y}\nYear: %{x}'))
)
}
}
plt <- layout(plt, title = '', yaxis = y, xaxis = x)
highlight(plt)
}
##### Render plots ----
output$temp_plot <- renderPlotly({
req( input$metric )
if( input$tab_selected == "Temperature"){
return(plot_data( clean_data() ) )
}
})
output$prec_plot <- renderPlotly({
req( input$metric )
if( input$tab_selected == "Precipitation"){
return(plot_data( clean_data() ) )
}
})Eine App wäre nichts ohne Buttons. Daher kümmern wir uns nun um deren Verhalten; also, was passiert, wenn welcher Button gedrückt wird. Und zum Schluss wird eine kleine JavaScript-Animation definiert, die das Ein- und Ausblenden des Moving Average-Menüs steuert.
#### Buttons ----
ma_years <- eventReactive(input$moving_average_bttn,{
req(input$moving_average_years)
input$moving_average_years
},ignoreNULL = FALSE)
observeEvent(input$temp_forecast_bttn, {
if(input$tab_selected=="Temperature"){
make_forecast_temp$value <- 1
}
})
observeEvent(input$prec_forecast_bttn, {
if(input$tab_selected=="Precipitation"){
make_forecast_prec$value <- 1
}
})
observeEvent(input$temp_remove_forecast_bttn, {
if(input$tab_selected=="Temperature"){
make_forecast_temp$value <- 0
}
})
observeEvent(input$prec_remove_forecast_bttn, {
if(input$tab_selected=="Precipitation"){
make_forecast_prec$value <- 0
}
})
temp_forecast_years <- eventReactive(input$temp_forecast_bttn,{
input$temp_forecast
})
prec_forecast_years <- eventReactive(input$prec_forecast_bttn,{
input$prec_forecast
})
forecast_years <- reactive( {
if (input$tab_selected == "Temperature" & make_forecast_temp$value == 1){
forecast_years <- temp_forecast_years()
} else if (input$tab_selected == "Precipitation" & make_forecast_prec$value == 1){
forecast_years <- prec_forecast_years()
}
})
#### Fade-in moving average ----
observeEvent(input$moving_average, {
if( input$moving_average == TRUE )
shinyjs::show(id = "moving_average_years", anim = TRUE, animType = "fade")
else {
shinyjs::hide(id = "moving_average_years", anim = TRUE, animType = "fade")
}
})Nun zum letzten Teil der App, wo wir alle Inputs rendern, die an das User Interface übergeben werden. Das sind eine Menge Select-, Slider- und Button-Inputs, insbesondere, weil wir das meiste für beide Tabs der App doppeln müssen. Sehr viel Fleißarbeit 😉
Dafür ist der dritte und letzte Teil mit nur einer Zeile Code abgehandelt. Wir übergeben die ui- und die server-Funktionen an ShinyApp() und erhalten dadurch ein App-Objekt.
#### Inputs ----
output$metric_temp <- renderUI({
selectInput(
inputId = "metric",
label = strong("Select metrics", style = "font-family: 'arial'; font-si28pt"),
choices = metric_list[1:5],
selected = metric_list[1],
multiple = TRUE
)
})
output$metric_prec <- renderUI({
selectInput(
inputId = "metric",
label = strong("Select metrics", style = "font-family: 'arial'; font-si28pt"),
choices = metric_list[6:7],
selected = metric_list[6],
multiple = TRUE
)
})
output$year_range <- renderUI({
sliderInput(
inputId = "year_range",
label = "Select year range",
min = 1901,
max = 2020,
value = c(1901, 2020),
sep = ""
)
})
output$moving_average <- renderUI({
checkboxInput(
inputId = "moving_average",
label = div("Include moving average", style = "font-size: 12pt"),
#style = "font-size: 28pt",
value = FALSE
)
})
output$moving_average_years <- renderUI({
div(
numericInput(
inputId = "moving_average_years",
label = "Number of years for moving average",
value = 5,
min = 0,
max = 30,
step = 1
),
actionButton(inputId = "moving_average_bttn",
style = "color: white;",
label = "Update moving average",
class = "btn-success"
)
)
})
output$temp_forecast <- renderUI({
numericInput(
inputId = "temp_forecast",
label = "Number of years to forecast",
value = 20, min = 0, max = 100, step = 1
)
})
output$prec_forecast <- renderUI({
numericInput(
inputId = "prec_forecast",
label = "Number of years to forecast",
value = 20, min = 0, max = 100, step = 1
)
})
output$temp_forecast_bttn <- renderUI({
actionButton(inputId = "temp_forecast_bttn",
icon = icon("sun", lib = "font-awesome"),
style = "color: white;",
label = " Make forecast",
class = "btn btn-lg btn-success"
)
})
output$prec_forecast_bttn <- renderUI({
actionButton(inputId = "prec_forecast_bttn",
icon = icon("cloud-rain", lib = "font-awesome"),
style = "color: white;",
label = " Make forecast",
class = "btn btn-lg btn-success"
)
})
output$temp_remove_forecast_bttn <- renderUI({
actionButton(inputId = "temp_remove_forecast_bttn",
icon = icon("ban", lib = "font-awesome"),
style = "color: white;",
label = "Stop forecast",
class = "btn btn-lg btn-danger"
)
})
output$prec_remove_forecast_bttn <- renderUI({
actionButton(inputId = "prec_remove_forecast_bttn",
icon = icon("ban", lib = "font-awesome"),
style = "color: white;",
label = "Stop forecast",
class = "btn btn-lg btn-danger"
)
})
text <- div(
br(),
br(),
strong("This dashboard is part of the ",
a("Environmental Data Science Playground",
href="https://zubrod-eds.de/en/playground/",
target="_blank")),
br(),
br(),
strong("Data was retrieved from ", a("NOAA",
href="https://www.noaa.gov",
target="_blank")),
br(),
br(),
br()
)
output$temp_forecast_panel <- renderUI({
div(
class = "jumbotron",
div(
class = "container bg-success",
br(),
p(strong("Make a forecast for temperature")),
uiOutput("temp_forecast"),
uiOutput("temp_forecast_bttn"),
br(),
uiOutput("temp_remove_forecast_bttn"),
br(),
text
)
)
})
output$prec_forecast_panel <- renderUI({
div(
class = "jumbotron",
div(
class = "container bg-success",
br(),
p(strong("Make a forecast for precipitation")),
uiOutput("prec_forecast"),
uiOutput("prec_forecast_bttn"),
br(),
uiOutput("prec_remove_forecast_bttn"),
br(),
text
)
)
})
output$sidebar <- renderUI({
if( input$tab_selected == "Temperature"){
div(
uiOutput("metric_temp"),
uiOutput("year_range"),
uiOutput("moving_average"),
uiOutput("moving_average_years") %>% hidden()
)
} else if ( input$tab_selected == "Precipitation" ) {
div(
uiOutput("metric_prec"),
uiOutput("year_range"),
uiOutput("moving_average"),
uiOutput("moving_average_years") %>% hidden()
)
}
})
}
shinyApp(ui, server)Das war’s. Wir haben uns ein kleines Klima-Dashboard gebaut und können dieses durch Ausführen des Skripts lokal laufen lassen (vorher alle Libraries installieren!).
OK. Aber was, wenn wir diese App mit anderen teilen wollen???
Es gibt zahlreiche Möglichkeiten Shiny-Apps zu deployen, vielfach sind die Anbieter sogar auf Shiny spezialisiert. Ich will euch hier aber einen Service zeigen, der das gerade nicht ist und somit auch Apps bereitstellen kann, die mit anderen Frameworks produziert wurden: Heroku.
Dazu brauchen wir aber zunächst noch zwei Mini-Skripte, eine init.R (diese installiert all eure Libraries, die für eure App benötigt werden, falls nicht vorhanden) und eine run.R. Wegen der Namenskonventionen von Heroku hatten wir unser App-Skript übrigens auch app.R genannt.
# init.R
# Load/install libraries ----
my_packages = c("shinydashboard", "shinyjs", "ggplot2", "dplyr", "readr",
"forecast", "plotly", "zoo")
install_if_missing = function(p) {
if (p %in% rownames(installed.packages()) == FALSE) {
install.packages(p)
}
}
invisible(sapply(my_packages, install_if_missing))# run.R
library(shiny)
port <- Sys.getenv('PORT')
shiny::runApp(
appDir = getwd(),
host = '0.0.0.0',
port = as.numeric(port)
)Nun sind wir startklar. Packt diese drei R-Skripte sowie alle weiteren für eure App benötigten Dateien in einen lokalen Ordner und fügt sie einem neuen GitHub-Repository hinzu. Falls ihr das noch nie gemacht habt, gibt es hier eine Schritt-für-Schritt-Anleitung. Im Anschluss erstellt ihr für euch einen Heroku-Account (aktuell komplett kostenlos, sofern man gewisse Einschränkungen in Kauf nimmt). Nun habt ihr zwei Möglichkeiten. Entweder ihr arbeitet über Herokus CLI (also über die Kommandozeile) oder aber, und das funktioniert fast noch komfortabler, ihr verknüpft euer GitHub-Repository mit Heroku.
Noch drei Tipps, damit der Build und das Deployment eurer Apps reibungslos funktioniert.
1) Achtet darauf, alle nötigen Libraries über app.R und init.R zu laden bzw. zu installieren.
2) Nutzt keine unnötigen Libraries. Heroku hat ein fixes Zeitlimit von 15 Minuten für den Build einer App. Wird dieses überschritten, bricht er ab. Durch die vielen Abhängigkeiten bei der Nutzung mehrerer Libraries, knackt man das Zeitlimit aber sehr leicht. Ladet also z.B. nicht das komplette tidyverse sondern nur die Komponenten, die ihr benötigt.
3) Achtet auf die Namenskonvention: app.R (oder ui.R und server.R), init.R und run.R.
Geschafft 🙂
Hier nochmal der Link zur auf Heroku gehosteten Shiny-App zum Ausprobieren und Herumspielen 😉
Falls ihr Fragen, Anmerkungen, Ideen zu diesem Post habt, schreibt mir gerne eine Mail.
