-
Notifications
You must be signed in to change notification settings - Fork 1
/
app.R
300 lines (259 loc) · 15 KB
/
app.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
library(shiny)
library(shinydashboard)
library(shinycssloaders)
library(sf)
library(pals)
library(ggplot2)
library(biscale)
library(cowplot)
ui <- dashboardPage(
dashboardHeader(title="UK Heat Stress Vulnerability", titleWidth = 300),
dashboardSidebar(
sidebarMenu(
menuItem("Instructions", tabName="first", icon = icon("book-reader")),
menuItem("Mapping", tabName="second", icon = icon("calculator")),
menuItem("Motivation", tabName="third", icon = icon("chalkboard-teacher")),
menuItem("Methods and Metrics", tabName="fourth", icon = icon("cog", lib = "glyphicon"))
)
),
dashboardBody(
tabItems(
tabItem(
tabName="first",
fluidRow(column(10,
box(width=12, h4("Instructions"),
"1. Select the climate and population scenario you want to visualise", br(),
"2. Select the UK region you want to visualise", br(),
"3. Apply your preferred factor weightings with the sliders", br(),
"4. Press the ",em("Create map")," button", br(),br(),
"Map can then be downloaded in .pdf format using the ",em("Download")," button. To return to the default factor weightings for the Recent Past, press ",em("Reset default values"),".",br(),br(),
"See the video below for a demonstration of how to use the app.",
h4("Source code"),
"The source code for this app can be found at ",tags$a(href="https://github.com/Zimbabwelsh/HeatStressVulnerability","https://github.com/Zimbabwelsh/HeatStressVulnerability")
)),
HTML('<iframe width="560" height="315" src="https://www.youtube.com/embed/fcHFl9GgHRk" frameborder="10" allow="accelerometer; autoplay; encrypted-media; gyroscope; picture-in-picture" allowfullscreen></iframe>'),
)
),
tabItem(
tabName="second",
fluidRow(column(4, h4("Dataset selection"),
selectInput("scenario1", "Climate scenario",
c("Recent past", "+1.5°C", "+2.0°C", "+3.0°C", "Change (+3.0°C - past)")),
selectInput("scenario2", "Population baseline",
c("Historic", "Future: SSP5 2050")),
selectInput("region", "Region",
c("UK", "England", "Scotland", "Wales", "Northern Ireland")),
# selectInput("gran", "Polygon Resolution",
# c("Low", " High (unavailable online)")),
actionButton("simulate", "Create map", class = "btn-block btn-success"),br(),
downloadButton("download1")
),
column(4,
h4("Weighting of climate metrics"),
sliderInput(inputId = "num1",
label = "Extreme max. temperature",
min = 0.0, max = 1,value = 0.32, step = 0.01),
sliderInput(inputId = "num2",
label = "Extreme vapour pressure",
min = 0.0, max = 1, value= 0.27, step = 0.01),
sliderInput(inputId= "num3",
label = "Extreme min. temperature",
min=0.0, max=1, value=0.19, step=0.01),
sliderInput(inputId="num4",
label="Degree Days",
min=0.0, max=1, value=0.21, step=0.01)
),
column(4,
h4("Weighting of socio-economic metrics"),
sliderInput(inputId = "num5",
label = "Equivalised UK Index of Multiple Deprivation",
min = 0.0, max = 1, value = 0.5, step = 0.01),
sliderInput(inputId = "num6",
label = "Proportion of population over the age of 65",
min = 0.0, max = 1, value = 0.5, step = 0.01),
sliderInput(inputId = "num7",
label = "Population density",
min = 0.0, max = 1, value = 0.5, step = 0.01),
actionButton("reset", "Reset default values")
),
# Main panel for displaying outputs ----
mainPanel(
column(12, (
withSpinner(plotOutput(outputId = "biplot"))
)))
)
),
tabItem(
tabName="third",
fluidRow(column(10,
box(width=12, h4("Motivation"),
"This app is an interactive supplement to ", em("Projected risks associated with heat stress in the UK Climate Projections (UKCP18)")," by Kennedy-Asser et al., published in Environmental Research Letters (2022).", br(), br(),
"The UK experiences significant regional increases in mortality in response to summer heatwaves. Projected future warming is expected to increase exposure to heat stress risks. Within the UK, there will be individuals in society that are particularly vulnerable to climate hazards due to socio-economic factors.", br(), br(),
"The latest UK Climate Projections (UKCP18) from the UK Met. Office are used here to project changing heat extremes at 12 km spatial resolution for all regions of the UK. Four metrics of heat stress are used to define heat hazards for different warming scenarios. These are combined with three socio-economic metrics which are used to define some key aspects of vulnerability to heat extremes.", br(), br(),
"Heat hazard and socio-economic vulnerability factors have been transformed to z-scores and linearly combined. The interaction of these factors is used to highlight spatial hotspots of risk associated with extreme heat, for present and future climate scenarios. This app allows the weighting applied to each of these factors in generating risk maps to be modified and the uncertainty explored. For a full description of the metrics and methods, see the associated paper.", br(), br(),
)))
),
tabItem(tabName = "fourth",
fluidRow(column(6,box(width=12,h4("Methods"),
"All climate metrics show the multi-simulation mean from the UKCP18 RCM ensemble (Murphy et al. 2019), bias corrected following the ISIMIP2b method (Lange 2018). The climate scenarios refer to the 30 year period when global temperature first exceeds the given level of warming above pre-industrial temperatures. The ",em("Recent past")," scenario refers to the period 1990-2019. Socio-economic metrics are the same for all climate scenarios.", br(), br(),
"All metrics have been transformed to z-scores and are linearly combined once the user selected weights are applied. The default values for the metric weights were derived from Common Factor Analysis using 1 factor. Other methods (such as Principal Component Analysis) could also be used which would produce different weights. This app allows sensitivity to weightings to be assessed.", br(), br(),
"Note: the z-scores for the scenarios ", em("Recent past"),", ",em("+1.5°C"),", ",em("+2.0°C")," and ",em("+3.0°C")," are calculated individually, therefore they do not show risk relative to other warming levels. To assess the spatial variation in change between warming scenarios, use the ",em("Change (+3.0°C - past)")," scenario."
)),
column(6,box(width=12,h4("Metrics"),
em("Extreme max. temperature"), " is the mean daily maximum temperature on extreme days.", br(),br(),
em("Extreme vapour pressure"), "is the mean vapour pressure on extreme days.",br(),br(),
em("Extreme min. temperature"), "is the mean daily minimum temperature on extreme days." ,br(),br(),
em("Degree Days"), "is the sum of °C exceeding a threshold of summer daily mean temperature on all days exceeding the threshold." ,br(),br(),
em("Equivalised UK Index of Multiple Deprivation"), " is parameterised from Abel et al. (2016)." ,br(),br(),
em("Proportion of population over the age of 65"), " and ", em("Population density"), " are derived from current population estimates from the ONS, NISRA and NRS.", br(),br(),
"Note: For climate metrics, 'extreme days' are those exceeding the 95th percentile of summer daily maximum temperature. All climate metrics are calculated for the summer period 1st June - 15th September."
))
),
fluidRow(column(12,box(width=12,h4("Further information"),
"Abel et al. 2016: http://dx.doi.org/10.1136/bmjopen-2016-012750",br(),
"Lange 2018: https://www.isimip.org/documents/284/ISIMIP2b_biascorrection_factsheet_24May2018.pdf",br(),
"Murphy et al. 2019: http://www.metoffice.gov.uk/pub/data/weather/uk/UKCP18/science-reports/UKCP18-land-report.pdf",br(),
))
))
))
)
# Define server logic required to draw a histogram ----
server <- function(input, output) {
# Allow sliders to be reset to default values from paper
observeEvent(input$reset, {
updateSliderInput(inputId = "num1", value = 0.32)
updateSliderInput(inputId = "num2", value = 0.27)
updateSliderInput(inputId = "num3", value = 0.19)
updateSliderInput(inputId = "num4", value = 0.21)
updateSliderInput(inputId = "num5", value = 0.5)
updateSliderInput(inputId = "num6", value = 0.5)
updateSliderInput(inputId = "num7", value = 0.5)
})
# Load the data as reactive variables to update only when 'Create Map' is pressed
df <- eventReactive(input$simulate, {
# if (input$gran=="Low"){
df <- na.omit(sf::st_read("shinydata/shiny_new_data.shp"))
# }
# else{
# df <- na.omit(sf::st_read("shinydata/polyshiny350.shp"))
# }
if (input$region=="UK"){
df <- df
}
else if (input$region=="England"){
id <- substr(df$cd,start = 1, stop = 1) == "E"
df <- df[id,]
}
else if (input$region=="Scotland"){
id <- substr(df$cd,start = 1, stop = 1) == "S"
df <- df[id,]
}
else if (input$region=="Wales"){
id <- substr(df$cd,start = 1, stop = 1) == "W"
df <- df[id,]
}
else if (input$region=="Northern Ireland"){
id <- substr(df$cd,start = 1, stop = 1) == "9"
df <- df[id,]
}
})
# Likewise define climate and social risk as reactive expressions
climaterisk <- eventReactive(input$simulate, {
if (input$scenario1=="Recent past"){
climaterisk <- df()$Tmx95_p*input$num1 + df()$VP95_ps*input$num2 + df()$Tmn95_p*input$num3 + df()$DD66_ps*input$num4
}
else if (input$scenario1=="+1.5°C"){
climaterisk <- df()$Tmx95_15*input$num1 + df()$VP95_15*input$num2 + df()$Tmn95_15*input$num3 + df()$DD66_15*input$num4
}
else if (input$scenario1=="+2.0°C"){
climaterisk <- df()$Tmx95_20*input$num1 + df()$VP95_20*input$num2 + df()$Tmn95_20*input$num3 + df()$DD66_20*input$num4
}
else if (input$scenario1=="+3.0°C"){
climaterisk <- df()$Tmx95_30*input$num1 + df()$VP95_30*input$num2 + df()$Tmn95_30*input$num3 + df()$DD66_30*input$num4
}
else if (input$scenario1=="Change (+3.0°C - past)"){
climaterisk <- df()$dl_Tmx95*input$num1 + df()$dl_VP95*input$num2 + df()$dl_Tmn95*input$num3 + df()$dl_DD66*input$num4
}
})
socialrisk <- eventReactive(input$simulate, {
if (input$scenario2=="Historic"){
socialrisk <- df()$imd*input$num5 + df()$age*input$num6 + df()$dens*input$num7
}
else if (input$scenario2=="Future: SSP5 2050"){
socialrisk <- df()$imd*input$num5 + df()$age_fut*input$num6 + df()$dens_ft*input$num7
}
})
# climaterisk <- eventReactive(input$simulate, {df()$Tmx95_p*input$num1 + df()$VP95_p*input$num2 + df()$Tmn95_p*input$num3 + df()$DD66_p*input$num4})
# socialrisk <- eventReactive(input$simulate, {df()$imd*input$num5 + df()$scl_age*input$num6 + df()$dens_ft*input$num7})
# Read in correct coastline
c <- eventReactive(input$simulate, {c <- na.omit(sf::st_read("shinydata/uk200.shp"))
if (input$region=="UK"){c <- c}
else if (input$region=="England"){
id2 <- substr(c$ctry19cd,start = 1, stop = 1) == "E"
c <- c[id2,]
}
else if (input$region=="Scotland"){
id2 <- substr(c$ctry19cd,start = 1, stop = 1) == "S"
c <- c[id2,]
}
else if (input$region=="Wales"){
id2 <- substr(c$ctry19cd,start = 1, stop = 1) == "W"
c <- c[id2,]
}
else if (input$region=="Northern Ireland"){
id2 <- substr(c$ctry19cd,start = 1, stop = 1) == "N"
c <- c[id2,]
}
})
# Change location of legend depending on what region is being plotted so not to overlap with map
leg_loc <- eventReactive(input$simulate, {
if (input$region=="UK" || input$region=="England"){leg_loc <- "TR"}
else{leg_loc = "TL"}
})
# Generate the plot
plotInput <- function(){
# Generate the plot
# output$biplot <- renderPlot({
df2 <- df()
c2 <- c()
df2$climaterisk <- climaterisk()
df2$socialrisk <- socialrisk()
data <- bi_class(df2, x = climaterisk, y = socialrisk, style = "quantile", dim = 3)
custom_pal <- bi_pal_manual(val_1_1="#e8e8e8", val_1_2 = "#e4d9ac", val_1_3 = "#c8b35a",
val_2_1="#cbb8d7", val_2_2 = "#c8ada0", val_2_3 = "#af8e53",
val_3_1="#9972af", val_3_2 = "#976b82", val_3_3 = "#804d36")
map <- ggplot2::ggplot() +
geom_sf(data = data, mapping = aes(fill = bi_class), colour = NA, show.legend = FALSE) +
bi_scale_fill(pal = custom_pal, dim = 3) +
bi_theme() +
geom_sf(data = c2, fill = NA, size = 0.5)
legend <- bi_legend(pal = custom_pal,
dim = 3,
xlab = "Climate Hazard",
ylab = "Social Vulnerability",
size = 8)
# Plot the map, updating the legend location if necessary
if (leg_loc() =="TR"){
finalPlot <- cowplot::ggdraw() +
cowplot::draw_plot(map, 0, 0, 1, 1) +
cowplot::draw_plot(legend, 0.7, 0.7, 0.3, 0.3)
}
else{
finalPlot <- cowplot::ggdraw() +
cowplot::draw_plot(map, 0, 0, 1, 1) +
cowplot::draw_plot(legend, 0, 0.7, 0.3, 0.3)
}
#plot(finalPlot)
}
output$biplot <- renderPlot({
req(climaterisk(), socialrisk())
print(plotInput())})
output$download1 <- downloadHandler(
filename = "UK Heat Stress Vulnerability map.pdf",
content = function(file) {
pdf(file)
print(plotInput())
dev.off()
})
}
shinyApp(ui, server)