Created getPopulation method

Ths method retrieves the population count for a give U.S. county.

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)

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"))

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

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