# Hello, world!
#
# This is an example function named 'hello'
# which prints 'Hello, world!'.
#
# You can learn more about package authoring with RStudio at:
#
# http://r-pkgs.had.co.nz/
#
# Some useful keyboard shortcuts for package authoring:
#
# Build and Reload Package: 'Ctrl + Shift + B'
# Check Package: 'Ctrl + Shift + E'
# Test Package: 'Ctrl + Shift + T'
hello <- function() {
print("Hello, world!")
}
doubleIt <- function(x) {
y <- x * 2
print(y)
}
# get deaths and population data and store in objects
oatData <- function() {
library(RODBC)
con <- odbcConnect("ODBC_R")
deaths <<- data.frame(
sqlQuery(con,
"select
DeathRegistrationCalendarYear
, DeceasedStatsCurrentCensusLocalAuthorityPreviousCode
, DeceasedStatsCurrentCensusLowerSuperOutputAreaCode
, DeceasedSexCode
, DeceasedAge
, DeceasedAgeUnitCode
, DeathCauseDiagnosisUnderlyingCode
from Dw.acc.ONS_DeathsAnnual
where DeceasedStatsCurrentCensusLocalAuthorityPreviousCode between '00NA' and '00PT'
and
DeathRegistrationCalendarYear > 2001"
)
)
pop_la <<- data.frame(
sqlQuery(con,
"select * from
phwdb.dbo.[LA_populations_singleyear_2002onwards_90+]"
)
)
}
########################################
geocode <- function(x, y) {
library(RODBC)
library(dplyr)
library(leaflet)
library(rgdal)
con <- odbcConnect("ODBC_R")
nspl <- data.frame(
sqlQuery(con,
"select * from refdata.refdata.nsplc11 where left(CTRY,1) = 'W'"
)
)
# turn postcodes from factors into characters
nspl$PCD <- as.character(nspl$PCD)
nspl$PCD2 <- as.character(nspl$PCD2)
nspl$PCDS <- as.character(nspl$PCDS)
# lsoa_shp <- readOGR("LSOA_Dec_2011_SupGen_Clip_Wales.shp")
# lsoa_polygon <- spTransform(lsoa_shp, CRS("+proj=longlat +init=epsg:27700"))
postcodes <<- list(
x %>%
left_join(nspl, by = c("postcode" = "PCD"), select = c(OSEAST1M, OSNRTH1M))
, x %>%
left_join(nspl, by = c("postcode" = "PCD2"), select = c(OSEAST1M, OSNRTH1M))
, x %>%
left_join(nspl, by = c("postcode" = "PCDS"), select = c(OSEAST1M, OSNRTH1M))
)
geocoded_postcodes <<- coalesce(!!!postcodes)
# https://stephendavidgregory.github.io/useful/UKgrid_to_LatLon
# shortcuts
ukgrid <- "+init=epsg:27700"
latlong <- "+init=epsg:4326"
# Create coordinates variable
coords <- cbind(Easting = as.numeric(as.character(geocoded_postcodes$OSEAST1M))
, Northing = as.numeric(as.character(geocoded_postcodes$OSNRTH1M)))
### Create the SpatialPointsDataFrame
dat_SP <- SpatialPointsDataFrame(coords,
data = geocoded_postcodes,
proj4string = CRS("+init=epsg:27700"))
### Convert
dat_SP_LL <- spTransform(dat_SP, CRS(latlong))
dat_SP_LL@data$Long <- coordinates(dat_SP_LL)[, 1]
dat_SP_LL@data$Lat <- coordinates(dat_SP_LL)[, 2]
leaflet() %>%
addTiles() %>%
# addPolygons(data = lsoa_polygon) %>%
addMarkers(data = dat_SP_LL, ~Long, ~Lat, label = ~paste0(postcode, ", LSOA = ", LSOA11, ", MSOA = ", MSOA11)) %>%
setView(lng = dat_SP_LL@data$Long[1], lat = dat_SP_LL@data$Lat[1], zoom = y)
}
################################
# function to put legend in right order in leaflet maps
# https://github.com/rstudio/leaflet/issues/256
legendOrder <- function (map, position = c("topright", "bottomright", "bottomleft",
"topleft"), pal, values, na.label = "NA", bins = 7, colors,
opacity = 0.5, labels = NULL, labFormat = labelFormat(),
title = NULL, className = "info legend", layerId = NULL,
group = NULL, data = getMapData(map), decreasing = FALSE) {
position <- match.arg(position)
type <- "unknown"
na.color <- NULL
extra <- NULL
if (!missing(pal)) {
if (!missing(colors))
stop("You must provide either 'pal' or 'colors' (not both)")
if (missing(title) && inherits(values, "formula"))
title <- deparse(values[[2]])
values <- evalFormula(values, data)
type <- attr(pal, "colorType", exact = TRUE)
args <- attr(pal, "colorArgs", exact = TRUE)
na.color <- args$na.color
if (!is.null(na.color) && col2rgb(na.color, alpha = TRUE)[[4]] ==
0) {
na.color <- NULL
}
if (type != "numeric" && !missing(bins))
warning("'bins' is ignored because the palette type is not numeric")
if (type == "numeric") {
cuts <- if (length(bins) == 1)
pretty(values, bins)
else bins
if (length(bins) > 2)
if (!all(abs(diff(bins, differences = 2)) <=
sqrt(.Machine$double.eps)))
stop("The vector of breaks 'bins' must be equally spaced")
n <- length(cuts)
r <- range(values, na.rm = TRUE)
cuts <- cuts[cuts >= r[1] & cuts <= r[2]]
n <- length(cuts)
p <- (cuts - r[1])/(r[2] - r[1])
extra <- list(p_1 = p[1], p_n = p[n])
p <- c("", paste0(100 * p, "%"), "")
if (decreasing == TRUE){
colors <- pal(rev(c(r[1], cuts, r[2])))
labels <- rev(labFormat(type = "numeric", cuts))
}else{
colors <- pal(c(r[1], cuts, r[2]))
labels <- rev(labFormat(type = "numeric", cuts))
}
colors <- paste(colors, p, sep = " ", collapse = ", ")
}
else if (type == "bin") {
cuts <- args$bins
n <- length(cuts)
mids <- (cuts[-1] + cuts[-n])/2
if (decreasing == TRUE){
colors <- pal(rev(mids))
labels <- rev(labFormat(type = "bin", cuts))
}else{
colors <- pal(mids)
labels <- labFormat(type = "bin", cuts)
}
}
else if (type == "quantile") {
p <- args$probs
n <- length(p)
cuts <- quantile(values, probs = p, na.rm = TRUE)
mids <- quantile(values, probs = (p[-1] + p[-n])/2,
na.rm = TRUE)
if (decreasing == TRUE){
colors <- pal(rev(mids))
labels <- rev(labFormat(type = "quantile", cuts, p))
}else{
colors <- pal(mids)
labels <- labFormat(type = "quantile", cuts, p)
}
}
else if (type == "factor") {
v <- sort(unique(na.omit(values)))
colors <- pal(v)
labels <- labFormat(type = "factor", v)
if (decreasing == TRUE){
colors <- pal(rev(v))
labels <- rev(labFormat(type = "factor", v))
}else{
colors <- pal(v)
labels <- labFormat(type = "factor", v)
}
}
else stop("Palette function not supported")
if (!any(is.na(values)))
na.color <- NULL
}
else {
if (length(colors) != length(labels))
stop("'colors' and 'labels' must be of the same length")
}
legend <- list(colors = I(unname(colors)), labels = I(unname(labels)),
na_color = na.color, na_label = na.label, opacity = opacity,
position = position, type = type, title = title, extra = extra,
layerId = layerId, className = className, group = group)
invokeMethod(map, data, "addLegend", legend)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.