---
title: "Past trends | CliRSnow"
output:
flexdashboard::flex_dashboard:
self_contained: false
lib_dir: libs
theme: bootstrap
orientation: rows
vertical_layout: fill
social: menu
source: embed
logo: other/logo_72x48.png
favicon: other/logo_72x48.png
navbar:
- { icon: "fa-share", title: "Main Dash", href: "./", align: right }
---
```{r setup, include=FALSE}
library(flexdashboard)
library(leaflet)
library(highcharter)
library(crosstalk)
library(plotly)
library(ggplot2)
library(sf)
library(dplyr)
div_text_color <- function(text, color){
paste0("", text, "")
}
```
```{r overview-data-prep, include=FALSE}
tbl_elev <- readRDS(here::here("data/mountain-background.rds"))
tbl_elev_sub <- tbl_elev[170: 450, ] %>%
dplyr::mutate(elev_scaled = ifelse(elev_rollmean > 1000,
elev_rollmean/max(elev_rollmean)*4500,
elev_rollmean)) %>%
dplyr::mutate(elev_scaled = ifelse(elev_scaled < 4000 & ii < 280,
scales::rescale(elev_scaled, to = c(-100, 4000)),
elev_scaled))
load(here::here("data/trends_500m.Rdata"))
tbl_xy_pos_500 <- tribble(
~x, ~y, ~ns_fct, ~elev_range,
200, 250, "North", "0-500m",
420, 250, "South", "0-500m",
210, 750, "North", "500-1000m",
410, 750, "South", "500-1000m",
220, 1250, "North", "1000-1500m",
380, 1250, "South", "1000-1500m",
230, 1750, "North", "1500-2000m",
370, 1750, "South", "1500-2000m",
240, 2250, "North", "2000-2500m",
360, 2250, "South", "2000-2500m",
250, 2750, "North", "2500-3000m",
350, 2750, "South", "2500-3000m",
260, 3500, "North", ">3000m",
320, 3500, "South", ">3000m"
)
tbl_3000_2 <- dat_trends_rel %>%
group_by(ns_fct, variable) %>%
summarise(nn_abs = 0, nn_rel = 0, value_abs = 0, value_rel = 0, elev_range = ">3000m")
dat_trends <- left_join(
dat_trends_abs %>% select(elev_fct, ns_fct, variable, value_abs = mean, nn_abs = nn),
dat_trends_rel %>% select(elev_fct, ns_fct, variable, value_rel = mean, nn_rel = nn)
)
tbl_absrel <-
dat_trends %>%
tidyr::separate(elev_fct, c(NA, "elev_min", "elev_max", NA)) %>%
mutate(elev_range = paste0(elev_min, "-", elev_max, "m")) %>%
bind_rows(tbl_3000_2) %>%
left_join(tbl_xy_pos_500) %>%
mutate(label = if_else(y > 3000,
"?",
if_else(startsWith(variable, "SCD"),
sprintf("%+.0f days (%+.1f%%)", value_abs, value_rel),
sprintf("%+.1f cm (%+.1f%%)", value_abs, value_rel))),
value_size = if_else(y < 3000, abs(value_rel), 0.1),
nn_min = pmin(nn_abs, nn_rel),
label_html = if_else(y > 3000,
div_text_color(label, "
if_else(value_rel < 0,
div_text_color(label, "
div_text_color(label, "
x <- c("Elevation", "Change", "Stations")
y <- c("{point.elev_range:s}", "{point.label:s}", "{point.nn_min:f}")
tltip <- tooltip_table(x, y)
cols <- c("
```
### HS DJF
```{r}
highchart() %>%
hc_add_theme(hc_theme_hcrt()) %>%
hc_add_series(tbl_elev_sub,
"line",
hcaes(ii, elev_scaled),
name = "Mountain",
enableMouseTracking = F,
showInLegend = F,
states = list(inactive = list(opacity = 1))) %>%
hc_add_series(tbl_absrel %>% filter(variable == "meanHS_DJF"),
"scatter",
hcaes(x, y, group = ns_fct, size = value_size),
dataLabels = list(enabled = T,
align = "left",
x = 20,
useHTML = T,
format = "{point.label_html}")) %>%
hc_colors(cols) %>%
hc_legend(align = "center",
verticalAlign = "top",
x = -30) %>%
hc_tooltip(useHTML = T,
shape = "callout",
pointFormat = tltip,
headerFormat = "") %>%
hc_yAxis(title = list(text = "Elevation",
rotation = 0,
align = "high",
offset = 10,
y = 10),
labels = list(format = "{value:f} m"),
min = 0, max = 4700,
tickInterval = 1000,
endOnTick = F) %>%
hc_xAxis(visible = F) %>%
hc_title(text = "Change in average winter snow depth 1971-2019") %>%
hc_subtitle(text = "December to February") %>%
hc_caption(text = strwrap(width = 1e6,
"Changes are determined from linear regressions over the whole period,
and averaged over all stations in 500 m elevation bands.
Over 2000 m, only few stations were available, so estimates should be
treated with caution.
Over 3000 m, no stations with such long records exist."))
```
### HS MAM
```{r}
highchart() %>%
hc_add_theme(hc_theme_hcrt()) %>%
hc_add_series(tbl_elev_sub,
"line",
hcaes(ii, elev_scaled),
name = "Mountain",
enableMouseTracking = F,
showInLegend = F,
states = list(inactive = list(opacity = 1))) %>%
hc_add_series(tbl_absrel %>% filter(variable == "meanHS_MAM"),
"scatter",
hcaes(x, y, group = ns_fct, size = value_size),
dataLabels = list(enabled = T,
align = "left",
x = 20,
useHTML = T,
format = "{point.label_html}")) %>%
hc_colors(cols) %>%
hc_legend(align = "center",
verticalAlign = "top",
x = -30) %>%
hc_tooltip(useHTML = T,
shape = "callout",
pointFormat = tltip,
headerFormat = "") %>%
hc_yAxis(title = list(text = "Elevation",
rotation = 0,
align = "high",
offset = 10,
y = 10),
labels = list(format = "{value:f} m"),
min = 0, max = 4700,
tickInterval = 1000,
endOnTick = F) %>%
hc_xAxis(visible = F) %>%
hc_title(text = "Change in average spring snow depth 1971-2019") %>%
hc_subtitle(text = "March to May") %>%
hc_caption(text = strwrap(width = 1e6,
"Changes are determined from linear regressions over the whole period,
and averaged over all stations in 500 m elevation bands.
Over 2000 m, only few stations were available, so estimates should be
treated with caution.
Over 3000 m, no stations with such long records exist."))
```
### SCD NDJF
```{r}
highchart() %>%
hc_add_theme(hc_theme_hcrt()) %>%
hc_add_series(tbl_elev_sub,
"line",
hcaes(ii, elev_scaled),
name = "Mountain",
enableMouseTracking = F,
showInLegend = F,
states = list(inactive = list(opacity = 1))) %>%
hc_add_series(tbl_absrel %>% filter(variable == "SCD_NDJF"),
"scatter",
hcaes(x, y, group = ns_fct, size = value_size),
dataLabels = list(enabled = T,
align = "left",
x = 20,
useHTML = T,
format = "{point.label_html}")) %>%
hc_colors(cols) %>%
hc_legend(align = "center",
verticalAlign = "top",
x = -30) %>%
hc_tooltip(useHTML = T,
shape = "callout",
pointFormat = tltip,
headerFormat = "") %>%
hc_yAxis(title = list(text = "Elevation",
rotation = 0,
align = "high",
offset = 10,
y = 10),
labels = list(format = "{value:f} m"),
min = 0, max = 4700,
tickInterval = 1000,
endOnTick = F) %>%
hc_xAxis(visible = F) %>%
hc_title(text = "Change in winter snow cover duration 1971-2019") %>%
hc_subtitle(text = "November to February") %>%
hc_caption(text = strwrap(width = 1e6,
"Snow cover duration is days with snow depth > 1cm. Changes are determined from linear regressions over the whole period,
and averaged over all stations in 500 m elevation bands.
Over 2000 m, only few stations were available, so estimates should be
treated with caution.
Over 3000 m, no stations with such long records exist."))
```
### SCD MAM
```{r}
highchart() %>%
hc_add_theme(hc_theme_hcrt()) %>%
hc_add_series(tbl_elev_sub,
"line",
hcaes(ii, elev_scaled),
name = "Mountain",
enableMouseTracking = F,
showInLegend = F,
states = list(inactive = list(opacity = 1))) %>%
hc_add_series(tbl_absrel %>% filter(variable == "SCD_MAM"),
"scatter",
hcaes(x, y, group = ns_fct, size = value_size),
dataLabels = list(enabled = T,
align = "left",
x = 20,
useHTML = T,
format = "{point.label_html}")) %>%
hc_colors(cols) %>%
hc_legend(align = "center",
verticalAlign = "top",
x = -30) %>%
hc_tooltip(useHTML = T,
shape = "callout",
pointFormat = tltip,
headerFormat = "") %>%
hc_yAxis(title = list(text = "Elevation",
rotation = 0,
align = "high",
offset = 10,
y = 10),
labels = list(format = "{value:f} m"),
min = 0, max = 4700,
tickInterval = 1000,
endOnTick = F) %>%
hc_xAxis(visible = F) %>%
hc_title(text = "Change in spring snow cover duration 1971-2019") %>%
hc_subtitle(text = "March to May") %>%
hc_caption(text = strwrap(width = 1e6,
"Snow cover duration is days with snow depth > 1cm. Changes are determined from linear regressions over the whole period,
and averaged over all stations in 500 m elevation bands.
Over 2000 m, only few stations were available, so estimates should be
treated with caution.
Over 3000 m, no stations with such long records exist."))
```
```{r aux-text, include=FALSE}
library(htmltools)
icon_plotly_box <- tags$svg(viewBox="0 0 1000 1000", class="icon", height="1em", width="1em",
tags$path(d = "m0 850l0-143 143 0 0 143-143 0z m286 0l0-143 143 0 0 143-143 0z m285 0l0-143 143 0 0 143-143 0z m286 0l0-143 143 0 0 143-143 0z m-857-286l0-143 143 0 0 143-143 0z m857 0l0-143 143 0 0 143-143 0z m-857-285l0-143 143 0 0 143-143 0z m857 0l0-143 143 0 0 143-143 0z m-857-286l0-143 143 0 0 143-143 0z m286 0l0-143 143 0 0 143-143 0z m285 0l0-143 143 0 0 143-143 0z m286 0l0-143 143 0 0 143-143 0z",
transform="matrix(1 0 0 -1 0 850)"))
icon_plotly_home <- tags$svg(viewBox="0 0 928.6 1000", class="icon", height="1em", width="1em",
tags$path(d = "m786 296v-267q0-15-11-26t-25-10h-214v214h-143v-214h-214q-15 0-25 10t-11 26v267q0 1 0 2t0 2l321 264 321-264q1-1 1-4z m124 39l-34-41q-5-5-12-6h-2q-7 0-12 3l-386 322-386-322q-7-4-13-4-7 2-12 7l-35 41q-4 5-3 13t6 12l401 334q18 15 42 15t43-15l136-114v109q0 8 5 13t13 5h107q8 0 13-5t5-13v-227l122-102q5-5 6-12t-4-13z",
transform="matrix(1 0 0 -1 0 850)"))
info_map1 <- p("Shows location of stations, colored by region. ")
info_map2 <- p("Use ",
tags$i(class="ion-qr-scanner"),
" to select an area",
tags$i(class="fa fa-arrow-alt-circle-right"),
"the stations will be highlighted in the trend scatter plot.")
info_trend1 <- p("Shows the trend per decade of each station (x-axis) versus the station's elevation (y-axis).")
info_trend2 <- p("Use box select ",
icon_plotly_box,
"to select stations ",
tags$i(class="fa fa-arrow-alt-circle-right"),
"these will be highlighted in the map.",
br(),
"Use the home button ",
icon_plotly_home, " to reset selection. ")
```
```{r data-funs, include=FALSE}
dat_meta_cluster <- readRDS(here::here("data/meta-with-cluster-01.rds"))
sf_meta <- st_as_sf(dat_meta_cluster,
coords = c("Longitude", "Latitude"),
crs = 4326)
sf_meta <- sf_meta %>% mutate(Region = cluster_fct)
cols_cluster <- setNames(scales::brewer_pal(palette = "Set1")(5),
c("NW", "NE", "North & high Alpine",
"South & high Alpine", "SE"))
leaf_col <- colorFactor("Set1", levels = levels(sf_meta$Region))
load(here::here("data/single-stn-trends.Rdata"))
ylim_common <- range(dat_plot_month$Elevation)
dat_plot_month2 <- dat_plot_month[, .(Name, Region,
Elevation, Latitude, Longitude,
month, Trend)]
dat_plot_season_hs2 <- dat_plot_season_hs[, .(Name, Region,
Elevation, Latitude, Longitude,
variable, Trend)]
dat_plot_season_scd2 <- dat_plot_season_scd[, .(Name, Region,
Elevation, Latitude, Longitude,
variable, Trend)]
dat_plot_month2[month == 11] %>%
left_join(sf_meta) %>%
SharedData$new() -> shared_nov
dat_plot_month2[month == 12] %>%
left_join(sf_meta) %>%
SharedData$new() -> shared_dec
dat_plot_month2[month == 1] %>%
left_join(sf_meta) %>%
SharedData$new() -> shared_jan
dat_plot_month2[month == 2] %>%
left_join(sf_meta) %>%
SharedData$new() -> shared_feb
dat_plot_month2[month == 3] %>%
left_join(sf_meta) %>%
SharedData$new() -> shared_mar
dat_plot_month2[month == 4] %>%
left_join(sf_meta) %>%
SharedData$new() -> shared_apr
dat_plot_month2[month == 5] %>%
left_join(sf_meta) %>%
SharedData$new() -> shared_may
dat_plot_season_hs2[variable == "meanHS_NDJFMAM"] %>%
left_join(sf_meta) %>%
SharedData$new() -> shared_meanHS_NDJFMAM
dat_plot_season_hs2[variable == "meanHS_DJF"] %>%
left_join(sf_meta) %>%
SharedData$new() -> shared_meanHS_DJF
dat_plot_season_hs2[variable == "meanHS_MAM"] %>%
left_join(sf_meta) %>%
SharedData$new() -> shared_meanHS_MAM
dat_plot_season_hs2[variable == "maxHS_NDJFMAM"] %>%
left_join(sf_meta) %>%
SharedData$new() -> shared_maxHS_NDJFMAM
dat_plot_season_scd2[variable == "SCD_NDJFMAM"] %>%
left_join(sf_meta) %>%
SharedData$new() -> shared_SCD_NDJFMAM
dat_plot_season_scd2[variable == "SCD_NDJF"] %>%
left_join(sf_meta) %>%
SharedData$new() -> shared_SCD_NDJF
dat_plot_season_scd2[variable == "SCD_MAM"] %>%
left_join(sf_meta) %>%
SharedData$new() -> shared_SCD_MAM
f_plot_month <- function(dat, mo){
gg <- dat %>%
ggplot(aes(Trend, Elevation, colour = Region, label = Name))+
geom_vline(xintercept = 0)+
geom_point()+
theme_bw()+
theme(panel.grid.minor = element_blank())+
scale_color_manual("", values = cols_cluster)+
ylim(ylim_common)+
xlab(paste0("Linear trend in ", month.name[mo], " mean snow depth [cm per decade]"))+
ylab("Elevation [m]")
gg %>%
ggplotly() %>%
highlight(on = "plotly_selected", off = "plotly_relayout")
}
f_plot_season <- function(dat, seas_lab){
gg <- dat %>%
ggplot(aes(Trend, Elevation, colour = Region, label = Name))+
geom_vline(xintercept = 0)+
geom_point()+
theme_bw()+
theme(panel.grid.minor = element_blank())+
scale_color_manual("", values = cols_cluster)+
ylim(ylim_common)+
xlab(paste0("Linear trend in ", seas_lab, " per decade]"))+
ylab("Elevation [m]")
gg %>%
ggplotly() %>%
highlight(on = "plotly_selected", off = "plotly_relayout")
}
f_leaf <- function(dat){
dat %>%
leaflet %>%
addProviderTiles("CartoDB.Positron", group = "CartoDB") %>%
addProviderTiles("Esri.WorldTopoMap", group = "Topomap") %>%
addProviderTiles("Esri.WorldImagery", group = "WorldImagery") %>%
addLayersControl(baseGroups = c("CartoDB", "Topomap", "WorldImagery"),
position = "topright",
options = layersControlOptions(collapsed = FALSE)) %>%
addCircleMarkers(stroke = F,
fillOpacity = 0.8,
radius = 5,
color = ~ leaf_col(Region))
}
```
### Map info
`r info_map1`
`r info_map2`
### Scatter plot info
`r info_trend1`
`r info_trend2`
### Map
```{r}
shared_meanHS_NDJFMAM %>% f_leaf()
```
### Trend plot
```{r}
f_plot_season(shared_meanHS_NDJFMAM,
"November-May mean HS [cm")
```
### Map info
`r info_map1`
`r info_map2`
### Scatter plot info
`r info_trend1`
`r info_trend2`
### Map
```{r}
shared_meanHS_DJF %>% f_leaf()
```
### Trend plot
```{r}
f_plot_season(shared_meanHS_DJF,
"December-February mean HS [cm")
```
### Map info
`r info_map1`
`r info_map2`
### Scatter plot info
`r info_trend1`
`r info_trend2`
### Map
```{r}
shared_meanHS_MAM %>% f_leaf()
```
### Trend plot
```{r}
f_plot_season(shared_meanHS_MAM,
"March-May mean HS [cm")
```
### Map info
`r info_map1`
`r info_map2`
### Scatter plot info
`r info_trend1`
`r info_trend2`
### Map
```{r}
shared_maxHS_NDJFMAM %>% f_leaf()
```
### Trend plot
```{r}
f_plot_season(shared_maxHS_NDJFMAM,
"November-May maximum HS [cm")
```
### Map info
`r info_map1`
`r info_map2`
### Scatter plot info
`r info_trend1`
`r info_trend2`
### Map
```{r}
shared_SCD_NDJFMAM %>% f_leaf()
```
### Trend plot
```{r}
f_plot_season(shared_SCD_NDJFMAM,
"November-May SCD [days")
```
### Map info
`r info_map1`
`r info_map2`
### Scatter plot info
`r info_trend1`
`r info_trend2`
### Map
```{r}
shared_SCD_NDJF %>% f_leaf()
```
### Trend plot
```{r}
f_plot_season(shared_SCD_NDJF,
"November-February SCD [days")
```
### Map info
`r info_map1`
`r info_map2`
### Scatter plot info
`r info_trend1`
`r info_trend2`
### Map
```{r}
shared_SCD_MAM %>% f_leaf()
```
### Trend plot
```{r}
f_plot_season(shared_SCD_MAM,
"March-May SCD [days")
```
### Map info
`r info_map1`
`r info_map2`
### Scatter plot info
`r info_trend1`
`r info_trend2`
### Map
```{r}
shared_nov %>% f_leaf()
```
### Trend plot
```{r}
f_plot_month(shared_nov, 11)
```
### Map info
`r info_map1`
`r info_map2`
### Scatter plot info
`r info_trend1`
`r info_trend2`
### Map
```{r}
shared_dec %>% f_leaf()
```
### Trend plot
```{r}
f_plot_month(shared_dec, 12)
```
### Map info
`r info_map1`
`r info_map2`
### Scatter plot info
`r info_trend1`
`r info_trend2`
### Map
```{r}
shared_jan %>% f_leaf()
```
### Trend plot
```{r}
f_plot_month(shared_jan, 1)
```
### Map info
`r info_map1`
`r info_map2`
### Scatter plot info
`r info_trend1`
`r info_trend2`
### Map
```{r}
shared_feb %>% f_leaf()
```
### Trend plot
```{r}
f_plot_month(shared_feb, 2)
```
### Map info
`r info_map1`
`r info_map2`
### Scatter plot info
`r info_trend1`
`r info_trend2`
### Map
```{r}
shared_mar %>% f_leaf()
```
### Trend plot
```{r}
f_plot_month(shared_mar, 3)
```
### Map info
`r info_map1`
`r info_map2`
### Scatter plot info
`r info_trend1`
`r info_trend2`
### Map
```{r}
shared_apr %>% f_leaf()
```
### Trend plot
```{r}
f_plot_month(shared_apr, 4)
```
### Map info
`r info_map1`
`r info_map2`
### Scatter plot info
`r info_trend1`
`r info_trend2`
### Map
```{r}
shared_may %>% f_leaf()
```
### Trend plot
```{r}
f_plot_month(shared_may, 5)
```
### Map info
Clicking on a station will show its name, elevation, coordinates, and links to pre-made time series plots.
Stations whose circles have an outline have full data for the whole period 1971-2019, while the stations without outline contain gaps.
### Map
```{r}
addLegendCustom <- function(map, colors, labels, sizes, shapes, borders, opacity = 0.5){
make_shapes <- function(colors, sizes, borders, shapes) {
shapes <- gsub("circle", "50%", shapes)
shapes <- gsub("square", "0%", shapes)
paste0(colors, "; width:", sizes, "px; height:", sizes, "px; border:3px solid ", borders, "; border-radius:", shapes)
}
make_labels <- function(sizes, labels) {
paste0("", labels, "")
}
legend_colors <- make_shapes(colors, sizes, borders, shapes)
legend_labels <- make_labels(sizes, labels)
return(addLegend(map, colors = legend_colors, labels = legend_labels, opacity = opacity))
}
stn_trend <- sort(unique(c(dat_plot_month$Name,
dat_plot_season_hs$Name,
dat_plot_season_scd$Name)))
dat_meta_ts <- readRDS(here::here("data/meta-with-cluster-01.rds"))
dat_meta_ts[, stn_long := ifelse(Name %in% stn_trend, "trend", "region")]
dat_meta_ts[, leaf_opac := ifelse(Name %in% stn_trend, 0.8, 0.4)]
dat_meta_ts[, leaf_rad := ifelse(Name %in% stn_trend, 6, 4)]
dat_meta_ts[, popup_html := paste0(
Name, "",
Elevation, "m ",
round(Longitude, 3), "°E ", round(Latitude, 3), "°N ",
'Seasonal snow indices ',
'Monthly mean snow depth '
)]
sf_meta_ts <- st_as_sf(dat_meta_ts,
coords = c("Longitude", "Latitude"),
crs = 4326)
leaflet() %>%
addProviderTiles("CartoDB.Positron", group = "CartoDB") %>%
addProviderTiles("Esri.WorldTopoMap", group = "Topomap") %>%
addProviderTiles("Esri.WorldImagery", group = "WorldImagery") %>%
addLayersControl(baseGroups = c("CartoDB", "Topomap", "WorldImagery")) %>%
addCircleMarkers(data = sf_meta_ts %>% filter(stn_long == "region"),
color = ~leaf_col(cluster_fct),
stroke = F,
radius = 5,
fillOpacity = 0.4,
popup = ~popup_html) %>%
addCircleMarkers(data = sf_meta_ts %>% filter(stn_long == "trend"),
color = ~leaf_col(cluster_fct),
stroke = T,
weight = 2,
radius = 5,
opacity = 0.8,
fillOpacity = 0.4,
popup = ~popup_html) %>%
addLegendCustom(colors = "gray",
labels = c("Full period 1971-2019 available", "With gaps"),
sizes = 20,
shapes = "circle",
borders = c("black", "white"))
```
Past trends | CliRSnow
