Commit cc06a273 authored by Tao Sun's avatar Tao Sun
Browse files

Experiment on map features

parent 4e1e3575
Pipeline #84171 passed with stage
in 28 seconds
......@@ -18,7 +18,7 @@ b <- list(
x = 0,
y = 0,
showarrow = FALSE,
bgcolor = 'white'
bgcolor = 'rgba(255,255,255,0.6)'
)
plot_world_map <- function(){
......
......@@ -18,15 +18,30 @@ metadata <- yaml.load_file("metadata.yml")
mapUI <- function(id) {
ns <- NS(id)
tagList(
includeMarkdown("md/map_credits.Rmd"),
paste('Last updated :', metadata$map[[id]]$last_updated),
plotlyOutput(ns("map"),
width = "100%", height = "600"),
if (id == 'World') {
includeMarkdown('md/world_map_methodology.Rmd')
} else if (id == 'US') {
includeMarkdown('md/us_map_methodology.Rmd')
}
box(
width = 12,
status = 'primary',
solidHeader = TRUE,
includeMarkdown("md/map_credits.Rmd"),
helpText(
strong(paste(
"Last updated:",
format(metadata$map$US$last_updated %>% as.Date(), "%b %d, %Y"))
)),
hr(),
plotlyOutput(ns("map"),
width = "100%", height = "600"),
footer = if (id == 'World') {
includeMarkdown('md/world_map_methodology.Rmd')
} else if (id == 'US') {
includeMarkdown('md/us_map_methodology.Rmd')
}
)
)
}
......
COVID-19 Monthly Risk Map
=======================
# COVID-19 Monthly Risk Map
### Powered by the [Institute of Global Health](https://www.unige.ch/medecine/isg/en/), Faculty of Medicine, University of Geneva and the [Swiss Data Science Center](https://datascience.ch/), ETH Zürich-EPFL
#### Powered by the [Institute of Global Health](https://www.unige.ch/medecine/isg/en/), Faculty of Medicine, University of Geneva and the [Swiss Data Science Center](https://datascience.ch/), ETH Zürich-EPFL
## Risk Map Methodology
### Risk Map Methodology
- <span style="color: grey;">**GREY**</span>: if there were no test data available (from Our World in Data), or they were below 5,000 per 1M population
......
## Risk Map Methodology
### Risk Map Methodology
- <span style="color: grey;">**GREY**</span>: if there were no test data available (from Our World in Data), or they were below 5,000 per 1M population
......
library(shiny)
library(plotly)
# source('functionsAndModules/functionMap.R')
source('functionsAndModules/functionPrediction.R')
# get all the available mapbox styles
# mapStyles <- schema()$layout$layoutAttributes$mapbox$style$values
Z_Breaks <- function(n) {
# https://stackoverflow.com/questions/59516054/how-to-create-a-chloropleth-map-in-r-plotly-based-on-a-categorical-variable
CUTS <- seq(0, 1, length.out = n + 1)
rep(CUTS, ifelse(CUTS %in% 0:1, 1, 2))
}
b <- list(
text = "Powered by ISG and SDSC",
xref = "paper",
yref = "paper",
yanchor = "bottom",
xanchor = "left",
align = "center",
x = 0,
y = 0,
showarrow = FALSE,
bgcolor = 'rgba(255,255,255,0.5)'
)
plot_world_map <- function(){
# Get the colours from today
colours <- read.csv(paste0("data/Map/countries_colours.csv"), sep = ",", fileEncoding="UTF-8-BOM")
colours <- colours[!(colours$COLOUR == "," | colours$COLOUR == ""), ]
colours$LEVEL <- 0
colours$LEVEL[colours$COLOUR == "green"] <- 1
colours$LEVEL[colours$COLOUR == "orange"] <- 2
colours$LEVEL[colours$COLOUR == "red"] <- 3
# Codes - red, orange, green, grey
colour_codes <- c("#83838C7F", "#88E55C7F", "#FF80007F", "#FF00007F")
names(colour_codes) <- c("grey", "green", "orange", "red")
nfactor <- length(factor(colour_codes))
# Map the colour scale to make it discrete
colorScale <- data.frame(z = Z_Breaks(nfactor),
col = rep(colour_codes, each = 2),
stringsAsFactors = FALSE)
colours$Text <- with(colours,
paste('<b>', COUNTRY, ':</b><br>',
'Predicted daily cases/100K:', `new.cases.100.000`, '<br>',
'Predicted daily deaths/100K:', `new.death.100.000`, '<br>',
'Cumulative reported tests/1M:', `Test.1M.pop`
))
url <- 'https://raw.githubusercontent.com/johan/world.geo.json/master/countries.geo.json'
# url <- 'https://gisco-services.ec.europa.eu/distribution/v2/countries/geojson/CNTR_RG_60M_2020_4326.geojson'
countries <- rjson::fromJSON(file=url)
world_map <- plot_ly(
data = colours,
type = "choroplethmapbox",
geojson = countries,
locations = ~CODE,
# featureidkey = 'properties.ISO3_CODE',
z = ~LEVEL,
colorscale = colorScale,
showscale = FALSE,
hoverinfo = "text",
text = ~Text,
source = 'map'
) %>%
layout(
mapbox = list(
center = list(
lon = 0,
lat = 40
),
zoom = 1.5,
style = "open-street-map"
),
margin = list(l=0, r=0, t=50, b=50),
paper_bgcolor='rgba(0,0,0,0)',
plot_bgcolor='rgba(0,0,0,0)'
# annotations = b
)
world_map
}
mapStyles <- c('open-street-map', "carto-positron", "carto-darkmatter",
"stamen-terrain", "stamen-toner", "stamen-watercolor")
ui <- fluidPage(
hr(),
hr(),
column(
width = 8,
plotlyOutput("map", height = 800)
),
column(
width = 4,
plotlyOutput("somePlot", height = 800)
)
# verbatimTextOutput("click")
)
server <- function(input, output, session) {
output$map <- renderPlotly(plot_world_map())
output$somePlot <- renderPlotly({
countries <- read.csv(paste0("data/Map/countries_colours.csv"), sep = ",", fileEncoding="UTF-8-BOM") %>%
pull(COUNTRY) %>% as.character()
cases <- read_csv('data/ECDC/prediction/ECDC_cases_2020-09-30.csv')
d <- event_data("plotly_hover", source = 'map')
if (is.null(d)) {
text <- 'NOTHING'
plotly_empty()
} else {
text <- countries[d$pointNumber + 1]
cases_c <- cases %>% filter(countrycode::countryname(country) == countrycode::countryname(text))
plot_daily(cases_c, xrange = NULL, title = text, yaxis_title = 'cases', is_mobile = FALSE)
}
# plotlyProxy("map", session) %>%
# plotlyProxyInvoke(
# "relayout",
# list(title = text,
# annotations = list(list(text = text,
# xref = "paper",
# yref = "paper",
# yanchor = "bottom",
# xanchor = "left",
# align = "center",
# x = 0,
# y = 0,
# showarrow = FALSE,
# bgcolor = 'rgba(255,255,255,0.5)')))
# )
})
}
shinyApp(ui, server)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment