diff --git a/NAMESPACE b/NAMESPACE index 1b2c408..912a41d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -12,6 +12,7 @@ export(getMethodsITHIM) export(getNonTravelMETs) export(getParameterNames) export(getParameterSet) +export(getPopulation) export(getRoadInjuries) export(getSiN) export(getWalkTime) @@ -29,6 +30,7 @@ exportMethods(getMeans) exportMethods(getNonTravelMETs) exportMethods(getParameterNames) exportMethods(getParameterSet) +exportMethods(getPopulation) exportMethods(getRoadInjuries) exportMethods(getSiN) exportMethods(getWalkTime) diff --git a/R/AllGenerics.R b/R/AllGenerics.R index 805ad6e..d2c14a0 100644 --- a/R/AllGenerics.R +++ b/R/AllGenerics.R @@ -64,7 +64,7 @@ setGeneric("update", function(x, parList) standardGeneric("update")) #' @note If bur is set wrong 0 will be returned, not an error message. #' This is a bug. It should not return zero in this case. That #' is misleading. -#' +#' #' @export #' @docType methods #' @rdname getBurden-methods @@ -78,7 +78,7 @@ setGeneric("getBurden", function(x, bur, dis) standardGeneric("getBurden")) #' #' @param baseline ITHIM object #' @param scenario ITHIM object -#' +#' #' @param bur A character string indicating the type of disease burden #' measure. Available values are "deaths", "yll", "yld" and #' "daly". The default value is "daly". @@ -94,7 +94,7 @@ setGeneric("getBurden", function(x, bur, dis) standardGeneric("getBurden")) #' #' @note The parameters dis and bur should be harmonized across #' \code{getBurden} and \code{deltaBurden}. -#' +#' #' @export #' @docType methods #' @rdname deltaBurden-methods @@ -112,7 +112,7 @@ setGeneric("deltaBurden", function(baseline, scenario, bur, dis) standardGeneric #' #' @note The matrices have striking modes as rows and victim modes as #' columns. NOV is considered a striking mode. -#' +#' #' @export #' @docType methods #' @rdname getRoadInjuries-methods @@ -156,7 +156,7 @@ setGeneric("getParameterNames", function(x) standardGeneric("getParameterNames") #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #' Create an ITHIM object #' -#' Returns an ITHIM object. +#' Returns an ITHIM object. #' #' @param activeTransportFile A character string indicating the name #' of the file containing mean walk and cycle times. Default @@ -188,7 +188,7 @@ setGeneric("getParameterNames", function(x) standardGeneric("getParameterNames") #' explained in greater detail soon. See #' \url{https://github.com/syounkin/ITHIM/blob/devel/inst/gbd.csv} #' for an example. -#' +#' #' @return An object of class ITHIM #' #' @note If run with no arguments this function will return the @@ -203,7 +203,7 @@ setGeneric("getParameterNames", function(x) standardGeneric("getParameterNames") #' GBDFile <- system.file("gbd.csv", package = "ITHIM") #' #' ITHIM <- createITHIM(activeTransportFile = activeTransportFile, GBDFile = GBDFile) -#' +#' setGeneric("createITHIM", function(activeTransportFile, GBDFile, roadInjuriesFile, distRoadTypeFile, safetyInNumbersFile) standardGeneric("createITHIM")) #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -314,3 +314,22 @@ setGeneric("getCycleTime", function(x, form) standardGeneric("getCycleTime")) #' @docType methods #' @rdname getNonTravelMETs-methods setGeneric("getNonTravelMETs", function(x, form) standardGeneric("getNonTravelMETs")) +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +#' Retrieves population matrix from U.S. Census +#' +#' Retrieves population matrix from U.S. Census +#' +#' @param state An integer representing the state ID +#' @param county An integer representing the county ID +#' +#' @return A data frame of population counts +#' @export +#' @docType methods +#' @rdname getPopulation-methods +#' @note The underlying function, \code{getTractAgeSex}, was written +#' primarily by Vargo +#' +#' +setGeneric("getPopulation", function(state, county) standardGeneric("getPopulation")) diff --git a/R/functions-auxillary.R b/R/functions-auxillary.R index f291332..f4abb3e 100644 --- a/R/functions-auxillary.R +++ b/R/functions-auxillary.R @@ -11,7 +11,7 @@ ### file. ### @return A numeric vector of age in years - this is a test ### -### +### convertAge <- function(value, unit){ value <- ifelse(value == "999", NA, value) @@ -37,7 +37,7 @@ convertAge <- function(value, unit){ ### ### @return A character vector of ITHIM age categories ### -### +### convertToAgeClass <- function(age){ age <- as.numeric(age) agecat <- ifelse( age <= 4, "00-04", ifelse( age <= 14, "05-14", ifelse( age <= 29, "15-29", ifelse( age <= 44, "30-44", ifelse( age <= 59, "45-59", ifelse( age <= 69, "60-69", ifelse( age <= 79, "70-79", ifelse( age > 80, "80+", NA)))))))) @@ -51,6 +51,127 @@ s4Methods <- function(class) sapply(strsplit(methods, " "), "[", 2) } setEquality <- function(a,b) identical(sort(a),sort(b)) + +getTractAgeSex <- function(state, county) { + varString <- + "B01001_003E,B01001_004E,B01001_005E,B01001_006E,B01001_007E,B01001_008E,B01001_009E,B01001_010E,B01001_011E,B01001_012E,B01001_013E,B01001_014E,B01001_015E,B01001_016E,B01001_017E,B01001_018E,B01001_019E,B01001_020E,B01001_021E,B01001_022E,B01001_023E,B01001_024E,B01001_025E,B01001_027E,B01001_028E,B01001_029E,B01001_030E,B01001_031E,B01001_032E,B01001_033E,B01001_034E,B01001_035E,B01001_036E,B01001_037E,B01001_038E,B01001_039E,B01001_040E,B01001_041E,B01001_042E,B01001_043E,B01001_044E,B01001_045E,B01001_046E,B01001_047E,B01001_048E,B01001_049E" + + ACSpop <- + as.data.frame(fromJSON( + paste( + "https://api.census.gov/data/2015/acs5?get=NAME,", + varString, + "&for=tract:*&in=state:", + state, + "+county:", + county, + "&key=f78d6b6c18608edc379b5a06c55407ceb45e7038", + sep = "" + ) + ), stringsAsFactors = FALSE) + ACSpop <- ACSpop[-1,] + + colnames(ACSpop) <- + c( + "name", + "M_Under 5 years", + "M_5 to 9 years", + "M_10 to 14 years", + "M_15 to 17 years", + "M_18 and 19 years", + "M_20 years", + "M_21 years", + "M_22 to 24 years", + "M_25 to 29 years", + "M_30 to 34 years", + "M_35 to 39 years", + "M_40 to 44 years", + "M_45 to 49 years", + "M_50 to 54 years", + "M_55 to 59 years", + "M_60 and 61 years", + "M_62 to 64 years", + "M_65 and 66 years", + "M_67 to 69 years", + "M_70 to 74 years", + "M_75 to 79 years", + "M_80 to 84 years", + "M_85 years and over", + "F_Under 5 years", + "F_5 to 9 years", + "F_10 to 14 years", + "F_15 to 17 years", + "F_18 and 19 years", + "F_20 years", + "F_21 years", + "F_22 to 24 years", + "F_25 to 29 years", + "F_30 to 34 years", + "F_35 to 39 years", + "F_40 to 44 years", + "F_45 to 49 years", + "F_50 to 54 years", + "F_55 to 59 years", + "F_60 and 61 years", + "F_62 to 64 years", + "F_65 and 66 years", + "F_67 to 69 years", + "F_70 to 74 years", + "F_75 to 79 years", + "F_80 to 84 years", + "F_85 years and over", + "state", + "county", + "tract" + ) + + ACSpop <- ACSpop %>% gather(2:47,key = variable, value = value) + + ACSpop$sex <- matrix(unlist(strsplit(as.character(ACSpop$variable), "_")), ncol = 2, byrow =T)[, 1] + ACSpop$acsAge <- matrix(unlist(strsplit(as.character(ACSpop$variable), "_")), ncol = 2, byrow =T)[, 2] + + ITHIMageKey <- + c( + "ageClass1", + "ageClass2", + "ageClass2", + "ageClass3", + "ageClass3", + "ageClass3", + "ageClass3", + "ageClass3", + "ageClass3", + "ageClass4", + "ageClass4", + "ageClass4", + "ageClass5", + "ageClass5", + "ageClass5", + "ageClass6", + "ageClass6", + "ageClass6", + "ageClass6", + "ageClass7", + "ageClass7", + "ageClass8", + "ageClass8" + ) + + names(ITHIMageKey) <- unique(ACSpop$acsAge) # This vector must have the correct order. How do we ensure that? + ACSpop$age <- ITHIMageKey[as.character(ACSpop$acsAge)] + + ACSpop <- ACSpop %>% select(state,county,tract,sex,age,value) %>% group_by(state,county,sex,age) %>% summarise(n = sum(as.integer(value))) %>% ungroup() %>% spread(sex,n) %>% arrange(age) %>% select(M,F) %>% as.data.frame() + + row.names(ACSpop) <- paste0("ageClass",1:8) + + return(ACSpop) + +} + + + + + ## plotRR <- function(RR.baseline,RR.scenario){ ## D <- melt(list(baseline = RR.baseline, scenario = RR.scenario), c("age","quint"), value.name = "RR") ## D <- subset(D, !(age %in% paste0("ageClass",1:2))) diff --git a/R/methods-auxilliary.R b/R/methods-auxilliary.R new file mode 100644 index 0000000..6c3e7ec --- /dev/null +++ b/R/methods-auxilliary.R @@ -0,0 +1,6 @@ +#' @rdname getPopulation-methods +#' @aliases getPopulation +#' @export +setMethod("getPopulation", signature(state = "vector", county = "vector"), function(state, county){ + return(Reduce("+",mapply(getTractAgeSex, state = state, county = county, SIMPLIFY = FALSE))) +}) diff --git a/man/getPopulation-methods.Rd b/man/getPopulation-methods.Rd new file mode 100644 index 0000000..9f6e0fb --- /dev/null +++ b/man/getPopulation-methods.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllGenerics.R, R/methods-auxilliary.R +\docType{methods} +\name{getPopulation} +\alias{getPopulation} +\alias{getPopulation,vector,vector-method} +\title{Retrieves population matrix from U.S. Census} +\usage{ +getPopulation(state, county) + +\S4method{getPopulation}{vector,vector}(state, county) +} +\arguments{ +\item{state}{An integer representing the state ID} + +\item{county}{An integer representing the county ID} +} +\value{ +A data frame of population counts +} +\description{ +Retrieves population matrix from U.S. Census +} +\note{ +The underlying function, \code{getTractAgeSex}, was written + primarily by Vargo +} +