areal-weighted-interpolation.R
In areal: Areal Weighted Interpolation

## ----setup, include = FALSE---------------------------------------------------
knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>"
)

library(areal)
library(dplyr)
library(sf)

data(ar_stl_asthma, package = "areal")
data(ar_stl_race, package = "areal")
data(ar_stl_wards, package = "areal")
data(ar_stl_wardsClipped, package = "areal")

## ----load-data----------------------------------------------------------------
library(areal)

# load data into enviornment
race <- ar_stl_race                 # census tract population estimates
asthma <- ar_stl_asthma             # census tract asthma rate estimates
wards <- ar_stl_wards               # political boundaries
wardsClipped <- ar_stl_wardsClipped # political boundaries clipped to river

## ----featureMap, echo=FALSE, out.width = '100%'-------------------------------
knitr::include_graphics("../man/figures/featureMap.png")

## ----feature-count------------------------------------------------------------
# print number of features in source
nrow(race)

# print number of features in target
nrow(wards)

# create intersect for example purposes
nrow(suppressWarnings(sf::st_intersection(race, wards)))

## ----intersectMap, echo=FALSE, out.width = '100%'-----------------------------
knitr::include_graphics("../man/figures/intersectMap.png")

## ----data-by-hand, echo=FALSE-------------------------------------------------
as_tibble(
  data.frame(
    GEOID = c(29510101100, 29510101100, 29510101200, 29510101200),
    TOTAL_E = c(2510, 2510, 3545, 3545),
    WARD = c(11, 12, 12, 13)
  )
) %>% 
  knitr::kable(caption = "First Four Rows of Intersected Data")

## ----weight-by-hand, echo=FALSE-----------------------------------------------
as_tibble(
  data.frame(
    GEOID = c(29510101100, 29510101100, 29510101200, 29510101200),
    TOTAL_E = c(2510, 2510, 3545, 3545),
    WARD = c(11, 12, 12, 13),
    Ai = c(355702.9, 901331.1, 875554.7, 208612.1),
    Aj = c(1257034.0, 1257034.0, 1084166.8, 1084166.8),
    Wi = c(0.28297, 0.71703, 0.807583, 0.192417)
  )
) %>% 
  knitr::kable(caption = "First Four Rows of Intersected Data")

## ----calculate-by-hand, echo=FALSE--------------------------------------------
as_tibble(
  data.frame(
    GEOID = c(29510101100, 29510101100, 29510101200, 29510101200),
    TOTAL_E = c(2510, 2510, 3545, 3545),
    WARD = c(11, 12, 12, 13),
    Ai = c(355702.9, 901331.1, 875554.7, 208612.1),
    Aj = c(1257034.0, 1257034.0, 1084166.8, 1084166.8),
    Wi = c(0.28297, 0.71703, 0.807583, 0.192417),
    EST = c(710.2547, 1799.745, 2862.882, 682.1182)
  )
) %>% 
  knitr::kable(caption = "First Four Rows of Intersected Data")

## ----aggregate-by-hand, echo=FALSE--------------------------------------------
as_tibble(
  data.frame(
    WARD = c(11, 12, 13),
    EST = c(710.2547, 4662.627, 682.1182)
  )
) %>% 
  knitr::kable(caption = "Resulting Target Data")

## ----extensive----------------------------------------------------------------
aw_interpolate(wards, tid = WARD, source = race, sid = GEOID, 
               weight = "sum", output = "tibble", extensive = "TOTAL_E")

## ----extensive-vector---------------------------------------------------------
aw_interpolate(wards, tid = WARD, source = race, sid = GEOID, 
               weight = "sum", output = "tibble", 
               extensive = c("TOTAL_E", "WHITE_E", "BLACK_E"))

## ----extensive-weights--------------------------------------------------------
aw_preview_weights(wards, tid = WARD, source = race, sid = GEOID, 
                   type = "extensive")

## ----verify-true--------------------------------------------------------------
result <- aw_interpolate(wards, tid = WARD, source = race, sid = GEOID, 
               weight = "sum", output = "tibble", extensive = "TOTAL_E")

aw_verify(source = race, sourceValue = TOTAL_E, 
          result = result, resultValue = TOTAL_E)

## ----verify-fail--------------------------------------------------------------
result <- aw_interpolate(wards, tid = WARD, source = race, sid = GEOID, 
               weight = "total", output = "tibble", extensive = "TOTAL_E")

aw_verify(source = race, sourceValue = TOTAL_E, 
          result = result, resultValue = TOTAL_E)

## ----overlapMap, echo=FALSE, out.width = '100%'-------------------------------
knitr::include_graphics("../man/figures/overlapMap.png")

## ----extensive-weights-overlap------------------------------------------------
aw_preview_weights(wardsClipped, tid = WARD, source = race, sid = GEOID, 
                   type = "extensive")

## ----invenstive-weights-------------------------------------------------------
aw_preview_weights(wards, tid = WARD, source = asthma, sid = GEOID, 
                   type = "intensive")

## ----intensive----------------------------------------------------------------
aw_interpolate(wards, tid = WARD, source = asthma, sid = GEOID, 
               weight = "sum", output = "tibble", intensive = "ASTHMA")

## ----mixed--------------------------------------------------------------------
# remove sf geometry
st_geometry(race) <- NULL

# create combined data
race %>%
  select(GEOID, TOTAL_E, WHITE_E, BLACK_E) %>%
  left_join(asthma, ., by = "GEOID") -> combinedData

# interpolate
aw_interpolate(wards, tid = WARD, source = combinedData, sid = GEOID, 
               weight = "sum", output = "tibble", intensive = "ASTHMA",
               extensive = c("TOTAL_E", "WHITE_E", "BLACK_E"))

## ----constraints--------------------------------------------------------------
# re-load data
race <- ar_stl_race

# create combined data
race %>%
  select(GEOID, WHITE_E, BLACK_E) %>%
  mutate(
    TOTAL = WHITE_E+BLACK_E,
    WHITE_PCT = WHITE_E/TOTAL,
    BLACK_PCT = BLACK_E/TOTAL,
    TOTAL_PCT = WHITE_PCT+BLACK_PCT
  ) -> constrainedData

# interpolate
result2 <- aw_interpolate(ar_stl_wards, tid = WARD, 
               source = constrainedData, sid = GEOID, 
               weight = "sum", output = "tibble", 
               intensive = c("WHITE_PCT", "BLACK_PCT", "TOTAL_PCT"),
               extensive = c("TOTAL", "WHITE_E", "BLACK_E"))

# calculate new percentages
result2 %>%
  mutate(
    WHITE_PCT_2 = WHITE_E/TOTAL,
    BLACK_PCT_2 = BLACK_E/TOTAL,
    TOTAL_PCT_2 = WHITE_PCT_2+BLACK_PCT_2
  ) -> result2

# display
result2 %>%
  select(WHITE_PCT, WHITE_PCT_2, BLACK_PCT, BLACK_PCT_2, TOTAL_PCT, TOTAL_PCT_2)

## ----ouput--------------------------------------------------------------------
aw_interpolate(wards, tid = WARD, source = asthma, sid = GEOID, 
               weight = "sum", output = "sf", intensive = "ASTHMA")

## ----piped-input--------------------------------------------------------------
wards %>%
  select(-OBJECTID, -AREA) %>%
  aw_interpolate(tid = WARD, source = asthma, sid = GEOID, 
                 weight = "sum", output = "tibble", intensive = "ASTHMA")

## ----quoted-input-------------------------------------------------------------
wards %>%
  select(-OBJECTID, -AREA) %>%
  aw_interpolate(tid = "WARD", source = asthma, sid = "GEOID", 
                 weight = "sum", output = "tibble", intensive = "ASTHMA")

## ----manual-subset------------------------------------------------------------
race <- select(ar_stl_race, GEOID, TOTAL_E)
wards <- select(wards, -OBJECTID, -AREA)

## ----aw-intersect-------------------------------------------------------------
wards %>%
  aw_intersect(source = race, areaVar = "area") -> intersect

intersect

## ----aw-total-----------------------------------------------------------------
intersect %>%
  aw_total(source = race, id = GEOID, areaVar = "area", totalVar = "totalArea",
             type = "extensive", weight = "sum") -> intersect

intersect

## ----aw-weight----------------------------------------------------------------
intersect %>%
  aw_weight(areaVar = "area", totalVar = "totalArea", 
            areaWeight = "areaWeight") -> intersect

intersect

## ----aw-calculate-------------------------------------------------------------
intersect %>%
  aw_calculate(value = TOTAL_E, areaWeight = "areaWeight") -> intersect

intersect

## ----aw-aggregate-------------------------------------------------------------
intersect %>%
  aw_aggregate(target = wards, tid = WARD, interVar = TOTAL_E) -> result

result