Historical FTP Special Request BLS Access

ftp_BLS.R

################################################################################
# Author: Bryan Goodrich
# Created: Sometime 2012? Earlier?
#
# These functions allowed direct querying and mapping capabilities to the Bureau
# of Labor Statistics (BLS) Special Requests data through their FTP site. The 
# data were stored in fixed-width text files. 
#
# This code is non-functional in that the BLS no longer supports this FTP access.
# Additionally, the specific Local Area (LA) statistics utilized are also not
# available through the new download portal. See links for details.
#
# http://www.bls.gov/bls/discontinuation_ftp.htm
# http://www.bls.gov/lau/#cntyaa
#
# This code is intended for conceptual review and potential use cases where 
# one might want to map data in R using the maps package with publically 
# available data. 
#
# These data can be directly downloaded in txt or compressed XML (xlsx) formats.
#################################################################################

classification <- 
# Prepares classifications for a vector; can be extended to provide other classifications
function(x, n, sig = 4, method = "quantile") {
    prettify   <- function(x, s = sig) format(signif(x, s), trim = TRUE, nsmall = 0, big.mark = ",")
    makeLabels <- function(n) {paste("(", prettify(cutoffs[n-1]), ", ", prettify(cutoffs[n]), "]", sep = "")}
    cutoffs    <- quantile(x, seq(0, 1, length = n+1), na.rm = TRUE)
    labels     <- sapply(seq(cutoffs)[-1], makeLabels)
    labels[1]  <- sub("\\(", "[", labels[1])
    cut(x, cutoffs, labels = labels, include.lowest = TRUE)
}  # end function



normalization <-
# Normalizes a variable by the area of its enumeration unit
function() {

} 


importBLS <- 
# Import county unemployment data from the BLS FTP site
#
# Arguments:
#     year - Integer or character. Long-format (yyyy) year value. Valid for years 1990 to 2010.
#     ...  - additional arguments passed to read.fwf/read.table
#
# Returns:
#     A data.frame containing cleaned up BLS data
function(year, ...) {
    # Validation on year input
    isValid <- year %in% paste(1990:2010) 
    if (!isValid)
        stop("Year not supported.")
    
    # Initalize variables to be used on import
    year    <- substr(year, 3, 4)  # Files identified by last 2 digits
    infile  <- paste("ftp://ftp.bls.gov/pub/special.requests/la/laucnty", year, ".txt", sep = "")
    WIDTHS  <- c(8, 5, 8, 53, 4, 14, 13, 11, 9)
    CLASSES <- c("factor", rep("character", 3), "factor", rep("character", 4))
    FIELDS  <- c("series_id", "sFIPS", "cFIPS", "name", "year", "labor", "emp", "unemp", "unrate")
    
    # Import data from FTP into data frame
    x <- read.fwf(url(infile), skip = 6, strip.white = TRUE, ..., 
                  col.names = FIELDS, colClasses = CLASSES , widths = WIDTHS)
    
    # Clean up imported data
    x <- transform(x,
        fips   = as.numeric(paste(sFIPS, cFIPS, sep = "")),
        labor  = as.numeric(gsub(",", "", labor)),     # Remove formatted strings that include ","
        emp    = as.numeric(gsub(",", "", emp)),
        unemp  = as.numeric(gsub(",", "", unemp)),
        unrate = as.numeric(unrate)
    );  # end transform

    return(x)
}  # end function



mapBLS <- 
# Plots a choropleth map of the U.S. for a given BLS variable.
#
# Arguments:
#     x         -  Data frame of BLS data. Expected to be an importBLS return object.
#     var       -  Character string. Names a BLS variable. One of labor, emp, unemp, or unrate. Defaults unrate.
#     link      -  Character string. Names the BLS variable that links to county objects. Defaults FIPS.
#     classes   -  Integer. The number of classes to be used in the choropleth classification.
#     palette   -  Character string. Color Brewer name for classification palette. Defaults Blue-to-Green (BuGn)
#     sig       -  Integer. The numeric significance to use for classification values. Defaults 4. 
#     title     -  Character string. The title for the map. Defaults NULL. Can be added post-mapping with mtext. 
#     subtitle  -  Character string. The subtitle for the map. Defaults NULL. Can be added post-mapping with mtext.
#     proj      -  Character string. A projection value from the mapproj package. Defaults polyconic. Other projections
#                  may require additional parameters (param) to be specified. Good choice for U.S. is 'bonne' projection
#                  with a value for the 39th Parallel (param = 39). 
#     normalize -  Logical. Specifies if the variable values in each enumeration unit should be divided by the unit area. 
#     ...       -  Additional parameters passed to map function in maps package. This can include parameter values for projections. 
#
# Returns:
#     A map plot.
function(x, var = 'unrate', link = "fips", classes = 4, palette = "BuGn", sig = 4, title = NULL, subtitle = NULL, proj = "polyconic", normalize = FALSE, ...) {
    require(maps)
    require(RColorBrewer)
    require(mapproj)
    
    # Validate input
    isMissing <- is.null(x) | is.null(var) | is.null(link)
    if (isMissing)
        stop("Required parameter missing")

    # ========== Prepare Map Data ==========
    data(county.fips)
    cnty <- na.omit(county.fips)  # record 2395 is NA in FIPS "south dakota,x"
    
    if (normalize) {
        m <- map("county", fill = TRUE, plot = FALSE, projection = proj, ...)
        x <- normalization(x, m)
        x[var] <- x['norm']
    }

    x$bins  <- classification(x[, var], classes, sig = sig)  # Classification
    pal     <- brewer.pal(classes, palette)                  # Color palette
    matches <- x$bins[match(cnty$fips, x[, link])]    # Matched Classes

    # ========== Make Map ==========
    map("county", col = pal[as.numeric(matches)], fill = TRUE, 
        bg = "grey95", projection = proj, ...)
    if (!is.null(title))    mtext(title, cex = 1.2)
    if (!is.null(subtitle)) mtext(subtitle, line = -1.5)
    legend("bottom", levels(matches), fill = pal, bty = 'n', cex = 0.8, inset = 0, horiz = F, ncol=2)
}  # end function