# http://www.nytimes.com/projects/elections/2013/nyc-primary/mayor/map.html # http://www.washingtonpost.com/sf/local/2013/11/09/washington-a-world-apart/?utm_term=.cc3aa0c4e149 # https://leanpub.com/leaflet-tips-and-tricks/read library(rgdal) library(leaflet) library(mapview) library(htmltools) # colorBin, colorFactor, colorNumeric, colorQuantile map.palette <- 'YlOrRd' # tiles could be recalled either by including the URL of a particular service or by specifying the provider from the included list tile <- 'http://tile.mtbmap.cz/mtbmap_tiles/{z}/{x}/{y}.png' mp <- leaflet() %>% setView(lng = -2.421976, lat = 53.825564, zoom = 5) %>% fitBounds(lng1 = 1.8, lat1 = 49.9, lng2 = -8.3, lat2 = 59.0 ) %>% # addProviderTiles(providers$Stamen.TonerLite) addTiles(tile) mp # Tiles layers can also be combined, to multiple informations, using appropriately the opacity option # mp %>% # addProviderTiles(providers$MtbMap, options = providerTileOptions(opacity = 0.7) ) %>% # addProviderTiles(providers$Stamen.TonerLines, options = providerTileOptions(opacity = 0.35)) %>% # addProviderTiles(providers$Stamen.TonerLabels) db_conn <- dbConnect(MySQL(), group = 'shiny', dbname = 'geography') centres <- suppressWarnings(data.table(dbReadTable(db_conn, 'centres'), key = 'HSP_id') ) dbDisconnect(db_conn) # In general, # - the label argument can be used to display a textual or HTML content either on hover or statically (option noHide is respectively FALSE (def) / TRUE) # - the popup argument can be used to add a small box containing arbitrary HTML to be displayed on click # Both above have a labelOptions = labelOptions(list of options) to deeply customize mp %>% addCircles(data = centres, lng = ~X_lon, lat = ~Y_lat, weight = 10, radius = 20, color = ~type + 1, label = ~as.character(HSP_id), labelOptions = labelOptions( opacity = 0.8 ), popup = ~as.character(paste(HSP_id, '-', HSP)), popupOptions = labelOptions( opacity = 0.8 ) ) mp %>% addMarkers(data = centres, lng = ~X_lon, lat = ~Y_lat, # color = ~type, label = ~as.character(HSP_id), labelOptions = labelOptions( opacity = 0.8 ), popup = ~as.character(paste(HSP_id, '-', HSP)), popupOptions = labelOptions( opacity = 0.8 ) ) # It's possible to build own icons with the three built-in functions makeIcon, icons, and iconList # It's possibly easier to start from the following three libraries: # - fa: Font Awesome http://fontawesome.io/icons/, # - glyphicon: Bootstrap Glyphicons https://getbootstrap.com/components/, # - ion: Ion icons http://ionicons.com/, # and using similar functions: # - makeAwesomeIcon # - awesomeIcons # - awesomeIconList # hsp.icons <- awesomeIcons( icon = 'h-square', library = 'fa', squareMarker = TRUE, markerColor = sapply(centres$type, function(x) if(x == 1){ "lightgreen" } else { "lightred" }), iconColor = 'white' ) mp %>% addAwesomeMarkers(data = centres, lng = ~X_lon, lat = ~Y_lat, # color = ~type, label = ~as.character(HSP_id), labelOptions = labelOptions( opacity = 0.8 ), popup = ~as.character(paste(HSP_id, '-', HSP)), popupOptions = labelOptions( opacity = 0.8 ), icon = hsp.icons ) mp %>% addCircleMarkers(~long, ~lat, label = ...) mp %>% addRectangles() mp %>% addPolygons() mp %>% addLabelOnlyMarkers(~long, ~lat, label = ...) mp %>% addPopups(~long, ~lat, label = ...) mp %>% addLegend() mp %>% addLayersControl( baseGroups = c('grp1', 'grp2', ...), overlayGroups = c('grp1'), options = layersControlOptions(collapsed = FALSE) ) # ------------------------------------------------------------------------------------------------------------------------------- # # # LET's ADD POLYGONS # read boundaries shp.path <- 'C:/projects/boundaries/shp' boundaries <- lapply(c('CCG', 'LAT', 'NHSR', 'CCR', 'CTRY'), function(x) readOGR(shp.path, x)) names(boundaries) <- c('CCG', 'LAT', 'NHSR', 'CCR', 'CTRY') area <- 'CCG' metric <- 'No. pPCIs' metric <- 'No. Cases Age > 80' # y <- get.y.tms(dataset, 'Mean Euroscore', 'CCG_id', tt = c(NA, 'CCG')) # pct <- FALSE y <- get.y.tms(dataset, metric, paste0(area, '_id'), pct = TRUE) pct <- TRUE y <- merge(y, unique(hospitals[, .(X = get(paste0(area, '_id')), Xo = get(paste0(area, '_ons')), Xn = get(area))])) bndT <- merge(boundaries[[area]], y, by.x = 'id', by.y = 'Xo') bnd <- merge(boundaries[[area]], y, by.x = 'id', by.y = 'Xo', all.x = FALSE) bndT <- merge(bndT[is.na(bndT$Y), 'id'], areas[type == area, .(ons_id, nhs_id, name)], by.x = 'id', by.y = 'ons_id') # bins <- c(0, 10, 20, 50, 100, 200, 500, 1000, Inf) # pal <- colorBin("YlOrRd", domain = states$density, bins = bins) # mp <- leaflet() %>% # setView(-96, 37.8, 4) %>% # fitBounds(lng1 = 1.8, lat1 = 49.9, lng2 = -8.3, lat2 = 59.0 ) %>% # addTiles('http://{s}.tile.openstreetmap.fr/hot/{z}/{x}/{y}.png') mp <- mp %>% addPolygons(data = bndT, stroke = TRUE, color = "#444444", opacity = 1.0, weight = 0.6, fill = TRUE, fillColor = "#E0E0E0", fillOpacity = 0.4, smoothFactor = 0.5, group = 'UK', highlightOptions = highlightOptions( color = "red", weight = 1, bringToFront = TRUE ), label = lapply(paste0(bndT$name, ': NOT supported'), HTML), labelOptions = labelOptions( textsize = "12px", direction = "auto", style = list("font-weight" = "normal", padding = "3px 8px") ) ) mp <- mp %>% addPolygons(data = bnd, color = "#444444", weight = 1, smoothFactor = 0.5, opacity = 1.0, fillOpacity = 0.5, fillColor = ~colorQuantile("YlOrRd", Y)(Y), highlightOptions = highlightOptions( color = "white", weight = 3, bringToFront = TRUE ), label = lapply( paste0( area, ': ', bnd$Xn, '
', metric, ':', if(pct) { paste0(100*bnd$Y, '%') } else {bnd$Y}, '' ), HTML ), labelOptions = labelOptions( textsize = "15px", direction = "auto", style = list("font-weight" = "normal", padding = "3px 8px") ) ) mp <- mp %>% addLegend( pal = colorBin( "YlOrRd", domain = states$density, bins = bins ), values = ~density, opacity = 0.7, title = NULL, position = "bottomright" ) mp # save map as html saveWidget(mp, file = 'mapnmae.html') # save map as image: you need mapview and webshot packages, plus phantomJS mapshot(mp, file = 'mapname.png')