R/hello.R

In public-health-wales-health-intelligence/mapOAT: our first package

# 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)
  }