Figures for the MBR Manuscript

This vignette produces the graphs included in the initial MBR manuscript.

Figure 1: Cartesian Rolling - 2005 Version

Figure 1: Raw monthly birth rates (General Fertility Rates; GFR's) for Oklahoma County, 1990-1999, plotted in a linear plot; the “bombing effect” is located ten months after the Oklahoma City bombing.

Figure 2: Cartesian Rolling - 2014 Version

Smoothed monthly birth rates (General Fertility Rates; GFRs) for Oklahoma County, 1990-1999, plotted in a linear plot. The top plot shows the connected raw data with a February smoother; the middle plot shows smoothing with a 12-month moving average, blue/green line, superimposed on a February smoother, red line); the bottom plot shows the smoothers and confidence bands, which are H-spreads defined using the distribution of GFR's for the given month and 11 previous months.

First, some R packages are loaded, and some variables and functions are defined.

changeMonth <- base::as.Date("1996-02-15") #as.Date("1995-04-19") + lubridate::weeks(39) = "1996-01-17"

vpLayout <- function(x, y) { grid::viewport(layout.pos.row=x, layout.pos.col=y) }

fullSpread <- function( scores ) { 
  return( base::range(scores) ) #A new function isn't necessary.  It's defined in order to be consistent.
}
hSpread <- function( scores ) { 
  return( stats::quantile(x=scores, probs=c(.25, .75)) ) 
}
seSpread <- function( scores ) { 
  return( base::mean(scores) + base::c(-1, 1) * stats::sd(scores) / base::sqrt(base::sum(!base::is.na(scores))) ) 
}
bootSpread <- function( scores, conf=.68 ) {
  plugin <- function( d, i ) { base::mean(d[i]) }

  distribution <- boot::boot(data=scores, plugin, R=99) #999 for the publication
  ci <- boot::boot.ci(distribution, type = c("bca"), conf=conf)
  return( ci$bca[4:5] ) #The fourth & fifth elements correspond to the lower & upper bound.
}

darkTheme <- ggplot2::theme(
  axis.title          = ggplot2::element_text(color="gray30", size=9),
  axis.text.x         = ggplot2::element_text(color="gray30", hjust=0),
  axis.text.y         = ggplot2::element_text(color="gray30"),
  axis.ticks.length   = grid::unit(0, "cm"),
  axis.ticks.margin   = grid::unit(.00001, "cm"),
#   panel.grid.minor.y  = element_line(color="gray95", size=.1),
#   panel.grid.major    = element_line(color="gray90", size=.1),
  panel.margin        = grid::unit(c(0, 0, 0, 0), "cm"),
  plot.margin         = grid::unit(c(0, 0, 0, 0), "cm")
)

Warning: `axis.ticks.margin` is deprecated. Please set `margin` property of `axis.text` instead

Warning: `panel.margin` is deprecated. Please use `panel.spacing` property instead

lightTheme <- darkTheme + ggplot2::theme(
  axis.title          = ggplot2::element_text(color="gray80", size=9),
  axis.text.x         = ggplot2::element_text(color="gray80", hjust=0),
  axis.text.y         = ggplot2::element_text(color="gray80"),
  panel.grid.minor.y  = ggplot2::element_line(color="gray99", size=.1),
  panel.grid.major    = ggplot2::element_line(color="gray95", size=.1)
)
dateSequence <- base::seq.Date(from=base::as.Date("1990-01-01"), to=base::as.Date("1999-01-01"), by="years")
xScale       <- ggplot2::scale_x_date(breaks=dateSequence, labels=scales::date_format("%Y"))
xScaleBlank  <- ggplot2::scale_x_date(breaks=dateSequence, labels=NULL) #This keeps things proportional down the three frames.

Individual Components

Here is the basic linear rolling graph. It doesn't require much specification, and will work with a wide range of approriate datasets. This first (unpublished) graph displays all components.

# dsLinearAll <- utils::read.csv("./Datasets/CountyMonthBirthRate2005Version.csv", stringsAsFactors=FALSE)
# dsLinearAll$Date <- base::as.Date(dsLinearAll$Date)
# dsLinearOkc <- dsLinearAll[dsLinearAll$CountyName=="oklahoma", ] 

# Uncomment the next two lines to use the version built into the package.  By default, it uses the
# CSV to promote reproducible research, since the CSV format is more open and accessible to more software.
dsLinearAll <- CountyMonthBirthRate2005Version
dsLinearOkc <- dsLinearAll[dsLinearAll$CountyName=="oklahoma", ]

dsLinearOkc <- Wats::AugmentYearDataWithMonthResolution(dsLinear=dsLinearOkc, dateName="Date")

portfolioCartesian <- Wats::AnnotateData(dsLinearOkc, dvName="BirthRate", centerFunction=stats::median, spreadFunction=hSpread)

Wats::CartesianRolling(
  dsLinear = portfolioCartesian$dsLinear, 
  xName = "Date", 
  yName = "BirthRate", 
  stageIDName = "StageID", 
  changePoints = changeMonth, 
  changePointLabels = "Bombing Effect"
)

The version for the manuscript was tweaked to take advantage of certain features of the dataset. This is what it looks like when all three stylized panels are combined.

topPanel <- Wats::CartesianRolling(
  dsLinear = portfolioCartesian$dsLinear, 
  xName = "Date", 
  yName = "BirthRate", 
  stageIDName = "StageID", 
  changePoints = changeMonth, 
  yTitle = "General Fertility Rate",
  changePointLabels = "Bombing Effect", 
  drawRollingBand = FALSE, 
  drawRollingLine = FALSE
)

middlePanel <- Wats::CartesianRolling(
  dsLinear = portfolioCartesian$dsLinear, 
  xName = "Date", 
  yName = "BirthRate", 
  stageIDName = "StageID", 
  changePoints = changeMonth, 
  yTitle = "General Fertility Rate",
  changePointLabels = "", 
  drawRollingBand = FALSE, 
  drawJaggedLine = FALSE
)

bottomPanel <- Wats::CartesianRolling(
  dsLinear = portfolioCartesian$dsLinear, 
  xName = "Date", 
  yName = "BirthRate", 
  stageIDName = "StageID", 
  changePoints = changeMonth, 
  yTitle = "General Fertility Rate", 
  changePointLabels = "", 
#   drawRollingBand = FALSE, 
  drawJaggedLine = FALSE
)

topPanel <- topPanel + xScale + darkTheme
middlePanel <- middlePanel + xScale + darkTheme
bottomPanel <- bottomPanel + xScaleBlank + darkTheme

grid::grid.newpage()
grid::pushViewport(grid::viewport(layout=grid::grid.layout(3,1)))
print(topPanel, vp=vpLayout(1, 1))
print(middlePanel, vp=vpLayout(2, 1))
print(bottomPanel, vp=vpLayout(3, 1))
grid::popViewport()

Figure 4: Carteisan Periodic

Carteisan plot of the GFR time series data in Oklahoma County, with H-spread Bands superimposed.

cartesianPeriodic <- Wats::CartesianPeriodic(
  portfolioCartesian$dsLinear, 
  portfolioCartesian$dsPeriodic, 
  xName = "Date", 
  yName = "BirthRate",
  stageIDName = "StageID", 
  changePoints = changeMonth, 
  changePointLabels = "Bombing Effect",
  yTitle = "General Fertility Rate",
  drawPeriodicBand = TRUE #The only difference from the simple linear graph above
)

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

print(cartesianPeriodic)

cartesianPeriodic <- cartesianPeriodic + xScale + darkTheme 
print(cartesianPeriodic)

Figure 5: Polar Periodic

Wrap Around Time Series (WATS Plot) of the Oklahoma City GFR data, 1990-1999

portfolioPolar <- Wats::PolarizeCartesian( 
  dsLinear = portfolioCartesian$dsLinear, 
  dsStageCycle = portfolioCartesian$dsStageCycle, 
  yName = "BirthRate", 
  stageIDName = "StageID", 
  plottedPointCountPerCycle = 7200
)

grid::grid.newpage()
Wats::PolarPeriodic(
  dsLinear = portfolioPolar$dsObservedPolar, 
  dsStageCycle = portfolioPolar$dsStageCyclePolar, 
  yName = "Radius",
  stageIDName = "StageID", 
  drawPeriodicBand = FALSE,
  drawStageLabels = TRUE, 
  drawRadiusLabels = TRUE, 
  cardinalLabels = c("Jan1", "Apr1", "July1", "Oct1")
)

Figure 6: WATS and Cartesian

Wrap Around Time Series (WATS Plot) of the Oklahoma City GFR data, 1990-1999

portfolioPolar <- Wats::PolarizeCartesian(
  dsLinear = portfolioCartesian$dsLinear, 
  dsStageCycle = portfolioCartesian$dsStageCycle, 
  yName = "BirthRate", 
  stageIDName = "StageID", 
  plottedPointCountPerCycle = 7200
)

grid::grid.newpage()
grid::pushViewport(grid::viewport(
  layout=grid::grid.layout(
    nrow = 2, ncol = 2, respect = TRUE, 
    widths = unit(c(1, 1), c("null", "null")), 
    heights = unit(c(1, .5), c("null", "null"))
  ), 
  gp = grid::gpar(cex=1, fill=NA)
))

## Create top left panel
grid::pushViewport(grid::viewport(layout.pos.col=1, layout.pos.row=1))
topLeftPanel <- Wats::PolarPeriodic(  
  dsLinear = portfolioPolar$dsObservedPolar, 
  dsStageCyclePolar = portfolioPolar$dsStageCyclePolar, 
  yName = "Radius", 
  stageIDName = "StageID", #graphCeiling=7, 
  cardinalLabels = c("Jan1", "Apr1", "July1", "Oct1")
)
grid::upViewport()

## Create top right panel
grid::pushViewport(grid::viewport(layout.pos.col=2, layout.pos.row=1))
topRighttPanel <- Wats::PolarPeriodic(
  dsLinear = portfolioPolar$dsObservedPolar, 
  dsStageCyclePolar = portfolioPolar$dsStageCyclePolar, 
  yName = "Radius", 
  stageIDName = "StageID", #graphCeiling=7, 
  drawObservedLine = FALSE,
  cardinalLabels = c("Jan1", "Apr1", "July1", "Oct1"), 
  originLabel = NULL
)
grid::upViewport()

## Create bottom panel
grid::pushViewport(grid::viewport(layout.pos.col=1:2, layout.pos.row=2, gp=grid::gpar(cex=1)))
print(cartesianPeriodic, vp=vpLayout(x=1:2, y=2)) #Print across both columns of the bottom row.
grid::upViewport()

Figure 7: County Comparison

This figure compares Oklahoma County against the (other) largest urban counties.

# dsLinearAll <- Wats::AugmentYearDataWithMonthResolution(dsLinear=CountyMonthBirthRate2005Version, dateName="Date")

#Identify the average size of the fecund population
plyr::ddply(dsLinearAll, "CountyName", plyr::summarize, Mean=base::mean(FecundPopulation))

     CountyName       Mean
1      canadian  18332.596
2     cleveland  48865.271
3      comanche  26268.104
4         creek  13402.358
5         logan   7065.562
6       mcclain   5434.525
7      oklahoma 146882.529
8         osage   8529.625
9  pottawatomie  13604.321
10       rogers  13383.292
11        tulsa 123783.479
12      wagoner  11579.967

GraphRowComparison <- function( rowLabel="", countyName="oklahoma", spreadFunction=hSpread, changeMonth=as.Date("1996-02-15") ) {
  dsLinear <- dsLinearAll[dsLinearAll$CountyName==countyName, ]
  dsLinear <- Wats::AugmentYearDataWithMonthResolution(dsLinear=dsLinear, dateName="Date")
  portfolioCartesian <- Wats::AnnotateData(dsLinear, dvName="BirthRate", centerFunction=stats::median, spreadFunction=spreadFunction)
  portfolioPolar <- Wats::PolarizeCartesian(dsLinear=portfolioCartesian$dsLinear, dsStageCycle=portfolioCartesian$dsStageCycle, yName="BirthRate", stageIDName="StageID", plottedPointCountPerCycle=7200)
  cartesianPeriodic <- Wats::CartesianPeriodic(portfolioCartesian$dsLinear, portfolioCartesian$dsPeriodic, xName="Date", yName="BirthRate", stageIDName="StageID", changePoints=changeMonth, changePointLabels=""  )

  grid::pushViewport(grid::viewport(
    layout=grid::grid.layout(nrow=1, ncol=3, respect=F, widths=grid::unit(c(1.5,1,3), c("line", "null", "null"))), 
    gp=grid::gpar(cex=1, fill=NA)
  ))
  grid::pushViewport(grid::viewport(layout.pos.col=1))
  grid.rect(gp=gpar(fill="gray90", col=NA))
  grid.text(rowLabel, rot=90)
  grid::popViewport()

  grid::pushViewport(grid::viewport(layout.pos.col=2))
  polarPeriodic <- Wats::PolarPeriodic(dsLinear=portfolioPolar$dsObservedPolar, dsStageCyclePolar=portfolioPolar$dsStageCyclePolar, drawObservedLine=FALSE, yName="Radius", stageIDName="StageID", originLabel=NULL, plotMargins=c(0,0,0,0))
  grid::popViewport()

  grid::pushViewport(grid::viewport(layout.pos.col=3))
  print(cartesianPeriodic + xScale + lightTheme, vp=vpLayout(x=1, y=1))
  grid::popViewport()
  grid::popViewport() #Finish the row
}

counties <- c("comanche", "cleveland", "oklahoma", "tulsa", "rogers")
countyNames <- c("Comanche", "Cleveland", "Oklahoma", "Tulsa", "Rogers")

grid.newpage()
grid::pushViewport(grid::viewport(layout=grid.layout(nrow=length(counties), ncol=1), gp=grid::gpar(cex=1, fill=NA)))
for( i in base::seq_along(counties) ) {
  grid::pushViewport(grid::viewport(layout.pos.row=i))
  GraphRowComparison(countyName=counties[i], rowLabel=countyNames[i])
  grid::popViewport()
}

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

grid::popViewport()

Here are all 12 counties that Ronnie colelcted birth records for. This extended graph is not in the mauscript.

counties <- base::sort(base::unique(dsLinearAll$CountyName))
countyNames <- c("Canadian", "Cleveland", "Comanche", "Creek", "Logan", "McClain", "Oklahoma", "Osage", "Pottawatomie", "Rogers", "Tulsa", "Wagoner")

grid::grid.newpage()
grid::pushViewport(grid::viewport(layout=grid.layout(nrow=base::length(counties), ncol=1), gp=grid::gpar(cex=1, fill=NA)))
for( i in base::seq_along(counties) ) {
  grid::pushViewport(grid::viewport(layout.pos.row=i))
  GraphRowComparison(countyName=counties[i], rowLabel=countyNames[i])
  grid::popViewport()
}

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

grid::popViewport()

Figure 8: Error Band Comparison

This figure demonstrates that WATS accommodates many types of error bands.

spreads <- c("hSpread", "fullSpread", "seSpread", "bootSpread")
spreadNames <- c("H-Spread", "Range", "+/-1 SE", "Bootstrap")
grid::grid.newpage()
grid::pushViewport(grid::viewport(layout=grid::grid.layout(nrow=base::length(spreads), ncol=1), gp=grid::gpar(cex=1, fill=NA)))
for( i in base::seq_along(spreads) ) {
  grid::pushViewport(grid::viewport(layout.pos.row=i))
  GraphRowComparison(spreadFunction=base::get(spreads[i]), rowLabel=spreadNames[i])
  grid::upViewport()
}

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

Warning: Ignoring unknown aesthetics: y

grid::upViewport()

Session Info

The current vignette was build on a system using the following software.

Report created by hornik at Mon 05 Dec 2016 03:49:39 PM CET, +0100

R Under development (unstable) (2016-12-05 r71733)
Platform: x86_64-pc-linux-gnu (64-bit)
Running under: Debian GNU/Linux stretch/sid

locale:
 [1] LC_CTYPE=en_US.UTF-8       LC_NUMERIC=C               LC_TIME=en_US.UTF-8        LC_COLLATE=C              
 [5] LC_MONETARY=en_US.UTF-8    LC_MESSAGES=en_US.UTF-8    LC_PAPER=en_US.UTF-8       LC_NAME=C                 
 [9] LC_ADDRESS=C               LC_TELEPHONE=C             LC_MEASUREMENT=en_US.UTF-8 LC_IDENTIFICATION=C       

attached base packages:
[1] grid      stats     graphics  grDevices utils     datasets  methods   base     

other attached packages:
[1] Wats_0.10.3   boot_1.3-18   ggplot2_2.2.0 scales_0.4.1  plyr_1.8.4   

loaded via a namespace (and not attached):
 [1] Rcpp_0.12.8        lattice_0.20-34    lubridate_1.6.0    zoo_1.7-13         assertthat_0.1     gtable_0.2.0      
 [7] magrittr_1.5       evaluate_0.10      highr_0.6          stringi_1.1.2      lazyeval_0.2.0     testit_0.6        
[13] labeling_0.3       RColorBrewer_1.1-2 tools_3.4.0        stringr_1.1.0      munsell_0.4.3      compiler_3.4.0    
[19] colorspace_1.3-1   knitr_1.15.1       tibble_1.2