Merge branch 'odot_vestate' into metro_verspm

RSGInc · Sep 20, 2023 · 9410d2f · 9410d2f
2 parents 7e2bcfd + 8d50b40
commit 9410d2f
Show file tree

Hide file tree

Showing 3 changed files with 139 additions and 96 deletions.
diff --git a/sources/modules/VETravelDemandWFH/R/CalculateAltModeTrips.R b/sources/modules/VETravelDemandWFH/R/CalculateAltModeTrips.R
@@ -167,10 +167,10 @@ CalculateAltModeTripsSpecifications <- list(
     visioneval::item(
       NAME =
         list("HhSize",
-              "Workers",
-              "Drivers",
-              "Age0to14",
-              "Age65Plus"),
+             "Workers",
+             "Drivers",
+             "Age0to14",
+             "Age65Plus"),
       TABLE = "Household",
       GROUP = "Year",
       TYPE = "people",
@@ -296,7 +296,7 @@ CalculateAltModeTripsSpecifications <- list(
     #   PROHIBIT = "NA",
     #   ISELEMENTOF = ""
     # ),
-
+    
     visioneval::item(
       NAME = "D3bpo4",
       TABLE = "Bzone",
@@ -399,7 +399,7 @@ CalculateAltModeTripsSpecifications <- list(
       TABLE = "Marea",
       GROUP = "Year",
       TYPE = "compound",
-      UNITS = "MI/PRSN",
+      UNITS = "MI/PRSN/YR",
       NAVALUE = -1,
       PROHIBIT = c("NA", "< 0"),
       ISELEMENTOF = "",
@@ -408,13 +408,13 @@ CalculateAltModeTripsSpecifications <- list(
   ),
 
   #Specify data to saved in the data store
-
+  
   Set = visioneval::items(
     visioneval::item(
       NAME =
         list("WalkTrips",
-              "BikeTrips",
-              "TransitTrips"),
+             "BikeTrips",
+             "TransitTrips"),
       TABLE = "Household",
       GROUP = "Year",
       TYPE = "compound",
@@ -432,8 +432,8 @@ CalculateAltModeTripsSpecifications <- list(
     visioneval::item(
       NAME =
         list("WalkAvgTripDist",
-              "BikeAvgTripDist",
-              "TransitAvgTripDist"),
+             "BikeAvgTripDist",
+             "TransitAvgTripDist"),
       TABLE = "Household",
       GROUP = "Year",
       TYPE = "double",
@@ -449,9 +449,9 @@ CalculateAltModeTripsSpecifications <- list(
     ),
     visioneval::item(
       NAME =
-         list("WalkPMT",
-              "BikePMT",
-              "TransitPMT"),
+        list("WalkPMT",
+             "BikePMT",
+             "TransitPMT"),
       TABLE = "Household",
       GROUP = "Year",
       TYPE = "compound",
@@ -465,14 +465,14 @@ CalculateAltModeTripsSpecifications <- list(
         "Daily biking person miles traveled by all members of the household",
         "Daily transit person miles traveled by all members of the household"
       )   
-      )
+    )
 
-
 
 
 
 
-    ),
+
+  ),
   #Make module callable
   Call = TRUE
 
@@ -556,6 +556,9 @@ CalculateAltModeTrips <- function(L) {
   stopifnot("data.frame" %in% class(Bzone_df))
 
   Marea_df <- data.frame(L$Year[["Marea"]])
+  if ("TranRevMiPC" %in% colnames(Marea_df)) {
+    Marea_df$TranRevMiPC = Marea_df$TranRevMiPC / 1000
+  }
   stopifnot("data.frame" %in% class(Marea_df))
 
   D_df <- data.frame(L$Year[[dataset_name]])
@@ -602,7 +605,7 @@ CalculateAltModeTrips <- function(L) {
   Out_ls$Year$Household$WalkPMT <- Preds[["y"]]
 
 
-    # BikePMT
+  # BikePMT
 
   #load("data/WalkPMTModel_df.rda")
   Model_df <- loadPackageDataset("BikePMTModel_df")
@@ -655,8 +658,8 @@ CalculateAltModeTrips <- function(L) {
   Out_ls$Year$Household$TransitPMT <- Preds[["y"]]
 
   #change the dataframe to be compatible with TFL models
-
-    # WalkTFL
+  
+  # WalkTFL
 
   #load("data/WalkTFLModel_df.rda")
   Model_df <- loadPackageDataset("WalkTFLModel_df")

diff --git a/sources/modules/VETravelDemandWFH/R/Initialize.R b/sources/modules/VETravelDemandWFH/R/Initialize.R
@@ -103,7 +103,8 @@ InitializeSpecifications <- list(
         "Proportion of households residing in the metropolitan (i.e. urbanized) part of the Azone",
         "Proportion of households residing in towns (i.e. urban-like but not urbanized) in the Azone",
         "Proportion of households residing in rural (i.e. not urbanized or town) parts of the Azone"
-      )
+      ),
+      OPTIONAL = TRUE
     )
   )
 )
@@ -176,7 +177,11 @@ Initialize <- function(L) {
   AzoneVars_ <- names(L$Data$Year$Azone)
   NotSaveVars_ <-
     c("PropMetroHh", "PropTownHh", "PropRuralHh")
-  OutAzoneVars_ <- AzoneVars_[-which(AzoneVars_ %in% NotSaveVars_)]
+  if(all(NotSaveVars_ %in% AzoneVars_)){
+    OutAzoneVars_ <- AzoneVars_[-which(AzoneVars_ %in% NotSaveVars_)]
+  } else {
+    OutAzoneVars_ <- AzoneVars_
+  }
   Out_ls <- L
   Out_ls$Data$Year$Azone <- Out_ls$Data$Year$Azone[OutAzoneVars_]
 
@@ -250,37 +255,39 @@ Initialize <- function(L) {
   #Check consistency of location type area and activity
   #----------------------------------------------------
   #Only check if no other errors identified
-  if (length(Errors_) == 0) {
-    #Iterate through years and check values
-    Yr <- unique(L$Data$Year$Azone$Year)
-    Values_df <- data.frame(Out_ls$Data$Year$Azone)
-    Values_df$Geo <- as.character(Values_df$Geo)
-    Values_df$Year <- as.character(Values_df$Year)
-    for (yr in Yr) {
-      IsYear <- L$Data$Year$Azone$Year == yr
-      V_df <- Values_df[IsYear,]
-      #Check if there are valid proportions
-      for(loc_type in LocType_){
-        Names_ <- paste0("Prop", loc_type, TeleWork_)
-        HhNames_ <- paste0("Prop", loc_type, "Hh")
-        WrkProps_ <- rowSums(V_df[,Names_])
-        HhProps_ <- data.frame(L$Data$Year$Azone[HhNames_])[IsYear,]
-        # Check if there are positive proportions where households exists
-        ValidProps_ <- WrkProps_>=HhProps_
-        BothNAs_ <- is.na(WrkProps_) & is.na(HhProps_)
-        ValidProps_[is.na(ValidProps_) & !BothNAs_] <- FALSE
-        if (any(!ValidProps_)) {
-          ErrAzones_ <- V_df[!ValidProps_, "Geo"]
-          Msg <- paste0(
-            "Error in the input file 'azone_wkr_loc_type_occupation_prop.csv", "' for year ", yr,
-            " and the following Azones: ",
-            paste(ErrAzones_, collapse = ", "), ". ",
-            "The values are inconsistent for (", paste(Names_, collapse = ", "),
-            ") compared to values for (", HhNames_, ") in 'azone_hh_loc_type_prop.csv' file."
-          )
-          Errors_ <- c(Errors_, Msg)
+  if(all(NotSaveVars_ %in% names(Out_ls$Data$Year$Azone))){
+    if (length(Errors_) == 0) {
+      #Iterate through years and check values
+      Yr <- unique(L$Data$Year$Azone$Year)
+      Values_df <- data.frame(Out_ls$Data$Year$Azone)
+      Values_df$Geo <- as.character(Values_df$Geo)
+      Values_df$Year <- as.character(Values_df$Year)
+      for (yr in Yr) {
+        IsYear <- L$Data$Year$Azone$Year == yr
+        V_df <- Values_df[IsYear,]
+        #Check if there are valid proportions
+        for(loc_type in LocType_){
+          Names_ <- paste0("Prop", loc_type, TeleWork_)
+          HhNames_ <- paste0("Prop", loc_type, "Hh")
+          WrkProps_ <- rowSums(V_df[,Names_])
+          HhProps_ <- data.frame(L$Data$Year$Azone[HhNames_])[IsYear,]
+          # Check if there are positive proportions where households exists
+          ValidProps_ <- WrkProps_>=HhProps_
+          BothNAs_ <- is.na(WrkProps_) & is.na(HhProps_)
+          ValidProps_[is.na(ValidProps_) & !BothNAs_] <- FALSE
+          if (any(!ValidProps_)) {
+            ErrAzones_ <- V_df[!ValidProps_, "Geo"]
+            Msg <- paste0(
+              "Error in the input file 'azone_wkr_loc_type_occupation_prop.csv", "' for year ", yr,
+              " and the following Azones: ",
+              paste(ErrAzones_, collapse = ", "), ". ",
+              "The values are inconsistent for (", paste(Names_, collapse = ", "),
+              ") compared to values for (", HhNames_, ") in 'azone_hh_loc_type_prop.csv' file."
+            )
+            Errors_ <- c(Errors_, Msg)
+          }
+
         }
-
       }
     }
   }

diff --git a/sources/modules/VETravelDemandWFH/R/PredictWFH.R b/sources/modules/VETravelDemandWFH/R/PredictWFH.R
@@ -137,6 +137,17 @@ PredictWFHSpecifications <- list(
       PROHIBIT = "",
       ISELEMENTOF = ""
     ),
+    visioneval::item(
+      NAME = "DistanceToWork",
+      TABLE = "Worker",
+      GROUP = "Year",
+      TYPE = "distance",
+      UNITS = "MI",
+      NAVALUE = "-1",
+      PROHIBIT = c("NA", "<= 0"),
+      ISELEMENTOF = "",
+      OPTIONAL = TRUE
+    ),
     visioneval::item(
       NAME =
         items("Age0to14",
@@ -228,7 +239,18 @@ PredictWFHSpecifications <- list(
       TYPE = "character",
       UNITS = "category",
       PROHIBIT = "",
-      ISELEMENTOF = ""
+      ISELEMENTOF = "",
+      OPTIONAL = TRUE
+    ),
+    visioneval::item(
+      NAME = "LocType",
+      TABLE = "Household",
+      GROUP = "Year",
+      TYPE = "character",
+      UNITS = "category",
+      PROHIBIT = "",
+      ISELEMENTOF = "",
+      OPTIONAL = TRUE
     ),
     visioneval::item(
       NAME = "D1B",
@@ -504,7 +526,7 @@ PredictWFH <- function(L) {
                                  variable.factor = FALSE)
 
   # Normalize overall
-  # Seperate out the field names
+  # Separate out the field names
 
   targets_all[, Occupation := ifelse(grepl("Mixed", OccupationTeleWorkLevel), "Mixed",
                                      ifelse(grepl("OnSite", OccupationTeleWorkLevel), "OnSite", "Remote"))]
@@ -519,11 +541,13 @@ PredictWFH <- function(L) {
   targets_all[!TeleWorkLevel %in% telework_levels_workfromhome, 
               Target := Target/sum(Target), 
               by = Occupation]
+  targets_all[is.na(Target), Target:=0]
 
   # Then further adjust the days, they should sum to one
   targets_all[TeleWorkLevel %in% telework_levels_teleworkdays, 
               Target := Target/sum(Target), 
               by = Occupation]
+  targets_all[is.na(Target), Target:=0]
 
   # Get the labels consistent with those used in the models
   targets_all[, Occupation := c("mixed", "on-site","remote")[match(Occupation, occupations)]]
@@ -570,8 +594,13 @@ PredictWFH <- function(L) {
   worker[hh, c("Bzone", "Azone") := .(i.Bzone, i.Azone), on = "HhId"]
 
   # add the work and home location types (occupation shares are by location type within azones)
-  worker[bzone, LocType := i.LocType, on = "Bzone"]
-  worker[bzone[, .(BzoneWork = Bzone, LocType)], LocTypeWork := i.LocType, on = "BzoneWork"]
+  if("LocType" %in% colnames(bzone)){
+    worker[bzone, LocType := i.LocType, on = "Bzone"]
+    worker[bzone[, .(BzoneWork = Bzone, LocType)], LocTypeWork := i.LocType, on = "BzoneWork"]
+  }
+  if("LocType" %in% colnames(hh)){
+    worker[hh, LocType := i.LocType, on = "HhId"]
+  }
 
   # simulate the occupation for every worker by Azone and LocType
   worker[occ_shares, c("pOnSite", "pMixed") := .(i.OnSite, i.Mixed), on = c("Azone", "LocType")]
@@ -687,55 +716,59 @@ PredictWFH <- function(L) {
   # Do you Telework at all? 
   # ======================= 
 
-  #  Binary logit. If the person doesn’t work from home, do they telecommute at all during the week? (0 vs 1+)
+  #  Binary logit. If the person does not work from home, do they telecommute at all during the week? (0 vs 1+)
   model_telework <- loadPackageDataset("Telework_df")
   model_telework <- data.table(model_telework)
 
   # Additional variables not in the work from home model
   # Commute Distance
-  DistToWork_ls <- loadPackageDataset("DistToWork_ls")
-
-  # Names of the table in the list is the home location (county and loc type combination)
-  # Column name is the work location
-  # convert to data.table and changes all names to upper case
-  DistToWork_ls_names <- names(DistToWork_ls)
-  DistToWork_ls <- lapply(1:length(DistToWork_ls), function(x) data.table(DistToWork_ls[[x]]))
-  names(DistToWork_ls) <- toupper(DistToWork_ls_names)
-  lapply(DistToWork_ls, function(x) {setnames(x, toupper); invisible()})
-
-  # household locations and worker locations
-  worker[, AZ_LTH := toupper(paste(Azone, LocType, sep = "_"))]
-  worker[, AZ_LTW := toupper(paste(AzoneWork, LocTypeWork, sep = "_"))]
-
-  # Deal with some differences for out of state:
-  # Distance to work matrices names for out of state geographies do not include the loctype
-  # Distance to work matrices out of state geographies only out of state to in state direction
-  # No out of state to out of state distance (allow for missing combinations in code).
-  worker[grepl("OUTOFSTATE", AZ_LTH), AZ_LTH := toupper(Azone)]
-  worker[grepl("OUTOFSTATE", AZ_LTW), c("AZ_LTH", "AZ_LTW") := .(toupper(AzoneWork), AZ_LTH)]
-
-  # loop through the groups by origin and then destination and draw from the distribution
-  for(azlth in unique(worker$AZ_LTH)){
-    for(azltw in unique(worker[AZ_LTH == azlth]$AZ_LTW)){
-      if(azltw %in% names(DistToWork_ls[[azlth]])){
-        prob_vec <- unlist(DistToWork_ls[[azlth]][,azltw, with = FALSE])
-      } else {
-        prob_vec <- c(0, rep(0.1,10),rep(0,90))    
+  if(!"DistanceToWork" %in% colnames(worker)){
+    DistToWork_ls <- loadPackageDataset("DistToWork_ls")
+
+    # Names of the table in the list is the home location (county and loc type combination)
+    # Column name is the work location
+    # convert to data.table and changes all names to upper case
+    DistToWork_ls_names <- names(DistToWork_ls)
+    DistToWork_ls <- lapply(1:length(DistToWork_ls), function(x) data.table(DistToWork_ls[[x]]))
+    names(DistToWork_ls) <- toupper(DistToWork_ls_names)
+    lapply(DistToWork_ls, function(x) {setnames(x, toupper); invisible()})
+
+    # household locations and worker locations
+    worker[, AZ_LTH := toupper(paste(Azone, LocType, sep = "_"))]
+    worker[, AZ_LTW := toupper(paste(AzoneWork, LocTypeWork, sep = "_"))]
+
+    # Deal with some differences for out of state:
+    # Distance to work matrices names for out of state geographies do not include the loctype
+    # Distance to work matrices out of state geographies only out of state to in state direction
+    # No out of state to out of state distance (allow for missing combinations in code).
+    worker[grepl("OUTOFSTATE", AZ_LTH), AZ_LTH := toupper(Azone)]
+    worker[grepl("OUTOFSTATE", AZ_LTW), c("AZ_LTH", "AZ_LTW") := .(toupper(AzoneWork), AZ_LTH)]
+
+    # loop through the groups by origin and then destination and draw from the distribution
+    for(azlth in unique(worker$AZ_LTH)){
+      for(azltw in unique(worker[AZ_LTH == azlth]$AZ_LTW)){
+        if(azltw %in% names(DistToWork_ls[[azlth]])){
+          prob_vec <- unlist(DistToWork_ls[[azlth]][,azltw, with = FALSE])
+        } else {
+          prob_vec <- c(0, rep(0.1,10),rep(0,90))    
+        }
+        if(length(prob_vec[is.na(prob_vec)])>0) prob_vec <- c(0, rep(0.1,10),rep(0,90))
+        worker[AZ_LTH == azlth & AZ_LTW == azltw, 
+               CommuteDistanceBin := sample(101, 
+                                            size = .N, 
+                                            replace = TRUE, 
+                                            prob = prob_vec)]
       }
-      if(length(prob_vec[is.na(prob_vec)])>0) prob_vec <- c(0, rep(0.1,10),rep(0,90))
-      worker[AZ_LTH == azlth & AZ_LTW == azltw, 
-             CommuteDistanceBin := sample(101, 
-                                          size = .N, 
-                                          replace = TRUE, 
-                                          prob = prob_vec)]
     }
+
+    # Draw a value to change from integer bin value, which represents the upper bound commute distance, 
+    # Round max value to 100
+    worker[, CommuteDistance := CommuteDistanceBin - runif(.N)]
+    worker[, CommuteDistance := ifelse(CommuteDistance > 100, 100, CommuteDistance)]
+  } else {
+    worker[, CommuteDistance := DistanceToWork]
   }
 
-  # Draw a value to change from integer bin value, which represents the upper bound commute distance, 
-  # Round max value to 100
-  worker[, CommuteDistance := CommuteDistanceBin - runif(.N)]
-  worker[, CommuteDistance := ifelse(CommuteDistance > 100, 100, CommuteDistance)]
-
   # for workers from home, replace commute distance with 0
   worker[WorkFromHome == "Yes", CommuteDistance := 0]