Updates from VisionEval-Dev.

See VisionEval/VisionEval-Dev#66 for a summary of changes

sources/modules/VEHouseholdTravel/R/CalculateAltModeTrips.R

@@ -477,11 +477,14 @@ CalculateAltModeTrips <- function(L) {
     IsMetro_ <- Hh_df$LocType == "Urban"
     Trips_[IsMetro_] <-
       applyHurdleTripModel(Hh_df[IsMetro_,], AltModeModels_ls$Metro[[Mode]])
+
+    if (any(Hh_df$LocType!="Urban")) {
     Trips_[!IsMetro_] <-
       applyHurdleTripModel(Hh_df[!IsMetro_,], AltModeModels_ls$NonMetro[[Mode]])
-    Trips_
+
   }
-
+    Trips_
+}
   #Calculate trips and return results
   #----------------------------------
   Out_ls <- initDataList()

sources/modules/VEHouseholdTravel/R/CalculateVehicleTrips.R

@@ -633,8 +633,10 @@ CalculateVehicleTrips <- function(L) {
   AveTrpLen_Hh[IsMetro] <-
     applyLinearModel(VehTrpLenModel_ls$Metro, Hh_df[IsMetro,])
   #Model average trip length for non-metropolitan households
+  if (any(Hh_df$LocType!="Urban")) {
   AveTrpLen_Hh[!IsMetro] <-
     applyLinearModel(VehTrpLenModel_ls$NonMetro, Hh_df[!IsMetro,])
+  }
   #Cap the maximum value at the 99th percentile value
   MaxAveTrpLen <- quantile(AveTrpLen_Hh, probs = 0.99)
   AveTrpLen_Hh[AveTrpLen_Hh > MaxAveTrpLen] <- MaxAveTrpLen

sources/modules/VEHouseholdVehicles/R/AssignDrivers.R

@@ -572,7 +572,8 @@ AssignDrivers <- function(L) {
     HhIdx <- match(names(NumDrivers_Hh), L$Year$Household$HhId)
     Out_ls$Year$Household[[BinName]][HhIdx] <- unname(NumDrivers_Hh)
     rm(MetroPer_df, Driver_, NumDrivers_Hh, HhIdx)
-    # Run nonmetropolitan model
+    # Run nonmetropolitan model(if any)
+    if (any(Per_df$LocType!="Urban")) {
     NonMetroPer_df <- Per_df[Per_df$LocType != "Urban",]
     Driver_ <- applyBinomialModel(
       DriverModel_ls$NonMetro,
@@ -590,6 +591,7 @@ AssignDrivers <- function(L) {
     HhIdx <- match(names(NumDrivers_Hh), L$Year$Household$HhId)
     Out_ls$Year$Household[[BinName]][HhIdx] <- unname(NumDrivers_Hh)
     rm(NonMetroPer_df, Driver_, NumDrivers_Hh, HhIdx)
+    }
   }
 
   #Tabulate number of driving age persons in each household

sources/modules/VEHouseholdVehicles/R/AssignVehicleOwnership.R

@@ -157,9 +157,9 @@ AutoOwnModels_ls$Stats$NonMetroZeroAnova <-
   capture.output(anova(AutoOwnModels_ls$NonMetro$Zero, test = "Chisq"))
 #Trim down model
 AutoOwnModels_ls$NonMetro$Zero[c("residuals", "fitted.values",
-                              "linear.predictors", "weights",
-                              "prior.weights", "y", "model",
-                              "data")] <- NULL
+                                 "linear.predictors", "weights",
+                                 "prior.weights", "y", "model",
+                                 "data")] <- NULL
 #Model number of vehicles of non-zero vehicle households
 EstData_df <- EstData_df[EstData_df$ZeroVeh == 0,]
 EstData_df$VehOrd <- EstData_df$NumVeh
@@ -409,7 +409,7 @@ AssignVehicleOwnership <- function(L) {
   Bz <- L$Year$Bzone$Bzone
   #Calculate number of households
   NumHh <- length(L$Year$Household[[1]])
-
+  
   #Set up data frame of household data needed for model
   #----------------------------------------------------
   Hh_df <- data.frame(L$Year$Household)
@@ -421,7 +421,7 @@ AssignVehicleOwnership <- function(L) {
   Hh_df$LogDensity <- log(Density_)
   TranRevMiPC_Bz <- L$Year$Marea$TranRevMiPC[match(L$Year$Bzone$Marea, L$Year$Marea$Marea)]
   Hh_df$TranRevMiPC <- TranRevMiPC_Bz[match(L$Year$Household$Bzone, L$Year$Bzone$Bzone)]
-
+  
   #Run the model
   #-------------
   #Probability no vehicles
@@ -430,25 +430,28 @@ AssignVehicleOwnership <- function(L) {
     predict(AutoOwnModels_ls$Metro$Zero,
             newdata = Hh_df[Hh_df$LocType == "Urban",],
             type = "response")
-  NoVehicleProb_[Hh_df$LocType %in% c("Town", "Rural")] <-
-    predict(AutoOwnModels_ls$NonMetro$Zero,
-            newdata = Hh_df[Hh_df$LocType %in% c("Town", "Rural"),],
-            type = "response")
+  if (any(Hh_df$LocType!="Urban")) {
+    NoVehicleProb_[Hh_df$LocType %in% c("Town", "Rural")] <-
+      predict(AutoOwnModels_ls$NonMetro$Zero,
+              newdata = Hh_df[Hh_df$LocType %in% c("Town", "Rural"),],
+              type = "response")
+  }
   #Vehicle counts
   Vehicles_ <- integer(NumHh)
   Vehicles_[Hh_df$LocType == "Urban"] <-
     as.integer(predict(AutoOwnModels_ls$Metro$Count,
-            newdata = Hh_df[Hh_df$LocType == "Urban",],
-            type = "class")$fit)
-  Vehicles_[Hh_df$LocType %in% c("Town", "Rural")] <-
-    as.integer(predict(AutoOwnModels_ls$NonMetro$Count,
-            newdata = Hh_df[Hh_df$LocType %in% c("Town", "Rural"),],
-            type = "class")$fit)
-  #Set count to zero for households modeled as having no vehicles
-  Vehicles_[NoVehicleProb_ >= runif(NumHh)] <- 0
-  #Set count to zero for households having no drivers
-  Vehicles_[L$Year$Household$Drivers == 0] <- 0
-
+                       newdata = Hh_df[Hh_df$LocType == "Urban",],
+                       type = "class")$fit)
+  if (any(Hh_df$LocType!="Urban")) {
+    Vehicles_[Hh_df$LocType %in% c("Town", "Rural")] <-
+      as.integer(predict(AutoOwnModels_ls$NonMetro$Count,
+                         newdata = Hh_df[Hh_df$LocType %in% c("Town", "Rural"),],
+                         type = "class")$fit)
+    #Set count to zero for households modeled as having no vehicles
+    Vehicles_[NoVehicleProb_ >= runif(NumHh)] <- 0
+    #Set count to zero for households having no drivers
+    Vehicles_[L$Year$Household$Drivers == 0] <- 0
+  }
   #Return the results
   #------------------
   #Initialize output list

sources/modules/VELandUse/R/AssignLocTypes.R

@@ -332,9 +332,13 @@ AssignLocTypes <- function(L) {
     SplitInt_
   }
   #Calculate dwelling units by Bzone and housing type
-  DU_BzHt <- table(L$Year$Household$Bzone, L$Year$Household$HouseType)[Bz,Ht]
+  DU_BzHt_full <- matrix(0,nrow = length(Bz), ncol = length(Ht), dimnames = list(Bz,Ht))
+  DU_BzHt <- table(L$Year$Household$Bzone, L$Year$Household$HouseType)
+  rowmatch <- match(rownames(DU_BzHt),rownames(DU_BzHt_full))
+  colmatch <- match(colnames(DU_BzHt), colnames(DU_BzHt_full))
+  DU_BzHt_full[rowmatch, colmatch] <- DU_BzHt
   #Calculate dwelling units by Bzone, housing type and location type
-  DU_BzHtLt <- sweep(Props_BzHtLt, c(1,2), DU_BzHt, splitInt)
+  DU_BzHtLt <- sweep(Props_BzHtLt, c(1,2), DU_BzHt_full, splitInt)
   #Function to assign a location type to a set of households
   assignLocType <- function(HouseID_, NumDU_Lt) {
     Lt <- names(NumDU_Lt)

sources/modules/VELandUse/R/PredictHousing.R

@@ -637,7 +637,7 @@ PredictHousing <- function(L) {
   #Identify which households are group quarters
   IsGQ_Hh <- L$Year$Household$HhType == "Grp"
   HouseType_Hh[IsGQ_Hh] <- "GQ"
-
+  
   #Predict housing type for each household
   #---------------------------------------
   #Make data frame of household variables and split by Azone
@@ -663,7 +663,7 @@ PredictHousing <- function(L) {
     HouseType_Hh[names(HouseType_)] <- HouseType_
     rm(SFDU, MFDU, PropSFDU, HouseType_)
   }
-
+  
   #Tabulate households by house type, income quartile, and Azone
   #-------------------------------------------------------------
   #Calculate regional income quartiles for households
@@ -691,14 +691,14 @@ PredictHousing <- function(L) {
   Ht <- c("SF", "MF")
   HhTab_HtIq_Az <-
     lapply(Hh_df_Az, function(x) table(x$HouseType, x$IncQ)[Ht,Iq])
-
+  
   #Tabulate housing unit inputs by Bzone and housing type
   #------------------------------------------------------
   InitUnits_BzHt <-
     as.matrix(data.frame(L$Year$Bzone[c("SFDU", "MFDU")]))
   rownames(InitUnits_BzHt) <- L$Year$Bzone$Bzone
   colnames(InitUnits_BzHt) <- Ht
-
+  
   #Tabulate input assumptions of household income distribution for each Bzone
   #--------------------------------------------------------------------------
   #Extract matrix of input assumptions of Bzone unit proportions by income
@@ -711,7 +711,7 @@ PredictHousing <- function(L) {
   rownames(HhIqProp_BzIq) <- Bz
   #Make sure that rows add to 1
   HhIqProp_BzIq <- t(apply(HhIqProp_BzIq, 1, function(x) x / sum(x)))
-
+  
   #Balance housing units with housing demand and assign households to locations
   #----------------------------------------------------------------------------
   #Each Azone is a housing market. The number of housing units by type and
@@ -777,7 +777,7 @@ PredictHousing <- function(L) {
         rm(UnitDiff_By)
       }
       rm(i, BxPropUnits_BxHt)
-
+      
       #Create seed array for IPF balancing of units by Bzone, type, and income
       #-----------------------------------------------------------------------
       HhIqProp_BxIq <- HhIqProp_BzIq[Bx,]
@@ -787,7 +787,7 @@ PredictHousing <- function(L) {
         Seed_BxHtIq[bx,,] <- outer(UnitDemand_BxHt[bx,], HhIqProp_BxIq[bx,])
       }
       Seed_BxHtIq[Seed_BxHtIq == 0] <- 1e-6
-
+      
       #Balance unit demand for each Bzone by unit type and income quartile
       #-------------------------------------------------------------------
       #Use IPF to allocate unit demand to Bzones, unit types, and income quartile
@@ -842,7 +842,7 @@ PredictHousing <- function(L) {
       rm(Bzone_Hx)
     }
   }
-
+  
   #Assign group quarters households to Bzones
   #------------------------------------------
   #Iterate through Azones to assign Bzones
@@ -878,17 +878,41 @@ PredictHousing <- function(L) {
       }
     }
   }
-
+  
   #Tabulate households, population, workers, and units by Bzone
   #------------------------------------------------------------
   Bz <- L$Year$Bzone$Bzone
-  NumHh_Bz <- tapply(Bzone_Hh, Bzone_Hh, length)[Bz]
-  Pop_Bz <- tapply(L$Year$Household$HhSize, Bzone_Hh, sum)[Bz]
-  NumWkr_Bz <- tapply(L$Year$Household$Workers, Bzone_Hh, sum)[Bz]
-  SF_Bz <- tapply(HouseType_Hh == "SF", Bzone_Hh, sum)[Bz]
-  MF_Bz <- tapply(HouseType_Hh == "MF", Bzone_Hh, sum)[Bz]
-  GQ_Bz <- tapply(HouseType_Hh == "GQ", Bzone_Hh, sum)[Bz]
-
+  Bz_list <- setNames(rep(0,length(Bz)),Bz)
+  NumHh_Bz <- tapply(Bzone_Hh, Bzone_Hh, length)
+  t <- match(names(NumHh_Bz),names(Bz_list))
+  Bz_list[t] <- NumHh_Bz 
+  NumHh_Bz <- Bz_list
+  Bz_list <- setNames(rep(0,length(Bz)),Bz)
+  Pop_Bz <- tapply(L$Year$Household$HhSize, Bzone_Hh, sum)
+  t <- match(names(Pop_Bz),names(Bz_list))
+  Bz_list[t] <- Pop_Bz
+  Pop_Bz <- Bz_list  
+  Bz_list <- setNames(rep(0,length(Bz)),Bz)  
+  NumWkr_Bz <- tapply(L$Year$Household$Workers, Bzone_Hh, sum)
+  t <- match(names(NumWkr_Bz),names(Bz_list))
+  Bz_list[t] <- NumWkr_Bz
+  NumWkr_Bz <- Bz_list
+  Bz_list <- setNames(rep(0,length(Bz)),Bz)  
+  SF_Bz <- tapply(HouseType_Hh == "SF", Bzone_Hh, sum)
+  t <- match(names(SF_Bz),names(Bz_list))
+  Bz_list[t] <- SF_Bz 
+  SF_Bz  <- Bz_list
+  Bz_list <- setNames(rep(0,length(Bz)),Bz)  
+  MF_Bz <- tapply(HouseType_Hh == "MF", Bzone_Hh, sum)
+  t <- match(names(MF_Bz),names(Bz_list))
+  Bz_list[t] <- MF_Bz 
+  MF_Bz  <- Bz_list
+  Bz_list <- setNames(rep(0,length(Bz)),Bz)  
+  GQ_Bz <- tapply(HouseType_Hh == "GQ", Bzone_Hh, sum)
+  t <- match(names(GQ_Bz),names(Bz_list))
+  Bz_list[t] <- GQ_Bz 
+  GQ_Bz  <- Bz_list
+
   #Return list of results
   #----------------------
   #Initialize output list

sources/modules/VEPowertrainsAndFuels/DESCRIPTION

@@ -18,6 +18,7 @@ Imports:
     visioneval,
     usethis,
     VE2001NHTS,
+    VEHouseholdTravel,
     data.table
 Suggests:
     knitr

sources/modules/VEPowertrainsAndFuels/NAMESPACE

@@ -9,4 +9,5 @@ export(interpolate)
 export(interpolateDfVals)
 import(stats)
 import(visioneval)
+import(VEHouseholdTravel)
 importFrom(stats,smooth.spline)

sources/modules/VEPowertrainsAndFuels/R/Initialize.R

@@ -387,6 +387,7 @@ usethis::use_data(InitializeSpecifications, overwrite = TRUE)
 #' Warnings component.
 #' @name Initialize
 #' @import visioneval
+#' @import VEHouseholdTravel
 #' @export
 Initialize <- function(L) {
   #Set up

sources/modules/VEScenario/DESCRIPTION

@@ -15,6 +15,7 @@ Depends: R (>= 3.4.0)
 Imports:
     visioneval,
     usethis,
+    future,
     future.callr,
     jsonlite,
     data.table

sources/modules/VEScenario/NAMESPACE

@@ -6,6 +6,7 @@ export(VERPATResults)
 export(VERSPMResults)
 export(ViewResults)
 import(data.table)
+import(future)
 import(future.callr)
 import(jsonlite)
 import(visioneval)

sources/modules/VEScenario/R/BuildScenarios.R

@@ -186,11 +186,11 @@ BuildScenarios <- function(L){
     # LEVELS is a list of DF of LEVEL NAMES and INPUTS
     # INPUTS is a list of DF of Scenario NAMES and LEVEL
     CategoryLevels_df <- do.call(rbind,
-                                 lapply(CategoryConfig_ls$LEVELS, function(x) {
-                                   y <- lapply(seq_along(x$NAME),
+                                 lapply(CategoryConfig_ls$LEVELS, function(x189) {
+                                   y <- lapply(seq_along(x189$NAME),
                                                function(z) {
-                                                 inputtable <- x$INPUTS[[z]]
-                                                 inputtable$CATLEVEL <- x$NAME[[z]]
+                                                 inputtable <- x189$INPUTS[[z]]
+                                                 inputtable$CATLEVEL <- x189$NAME[[z]]
                                                  return(inputtable)
                                                })
                                    do.call(rbind, y)
@@ -228,8 +228,8 @@ BuildScenarios <- function(L){
     ScenarioDef_df <- expand.grid(LevelDef_ls, stringsAsFactors = FALSE)
   }
 
-  ScenarioNames_ar <- apply(ScenarioDef_df, 1, function(x) {
-    Name <- paste(x, collapse = "/")
+  ScenarioNames_ar <- apply(ScenarioDef_df, 1, function(x231) {
+    Name <- paste(x231, collapse = "/")
     gsub("/", "", Name)
   })
   rownames(ScenarioDef_df) <- ScenarioNames_ar
@@ -265,8 +265,8 @@ BuildScenarios <- function(L){
     #           file.path(RunDir, L$Global$Model$ScenarioOutputFolder))
     catconfig_ls <- fromJSON(file.path(ScenarioInputPath,"category_config.json"),
                               simplifyDataFrame = FALSE)
-    cat_list <- c("Community Design","Marketing/Incentive", "Pricing", "Vehicles/Fuels", "Fuel Price", "Income" )
-    cat_names <- do.call( function(x) x$NAME, catconfig_ls )
+    cat_list <- c("Community Design","Marketing/Incentive", "Pricing", "Vehicles/Fuels", "Fuel Price" )
+    cat_names <- sapply( catconfig_ls, function(x) x$NAME  )
     cat_diff <- setdiff(cat_list,cat_names)   
     n = length(catconfig_ls)
     if (length(cat_diff)>0) {
@@ -279,7 +279,6 @@ BuildScenarios <- function(L){
       }
     }
 
-
     catconfig_ch <- paste0("var catconfig = ",
                             toJSON(catconfig_ls, pretty = TRUE), ";")
     write(catconfig_ch, file = file.path(RunDir,

sources/modules/VEScenario/R/RunScenarios.R

@@ -122,7 +122,7 @@ usethis::use_data(RunScenariosSpecifications, overwrite = TRUE)
 #' a value.
 #' @param debug A logical. TRUE if want to print more intermediate messages.
 #' @return A list containing all the parameters to the function.
-#' @import future.callr
+#' @import future future.callr
 startAsyncTask <-  function(asyncTasksRunning = vector(mode = "list"), asyncTaskName, futureObj,
                             callback = NULL, debug = FALSE){
   # Record start time
@@ -173,7 +173,7 @@ startAsyncTask <-  function(asyncTasksRunning = vector(mode = "list"), asyncTask
 #'
 #' @param asyncTasksRunning A list of asynchronous tasks running currently.
 #' @return An integer indicating the number of tasks currently running
-#' @import future.callr
+#' @import future future.callr
 getNumberOfRunningTasks <- function(asyncTasksRunning = vector(mode = "list")) {
   return(min(length(asyncTasksRunning)-1,nbrOfWorkers()))
 }
@@ -189,7 +189,7 @@ getNumberOfRunningTasks <- function(asyncTasksRunning = vector(mode = "list")) {
 #'
 #' @param asyncTasksRunning A list of asynchronous tasks running currently.
 #' @return A string indicating the status of the tasks running currently
-#' @import future.callr
+#' @import future future.callr
 getRunningTasksStatus <- function(asyncTasksRunning = vector(mode = "list")) {
   # Function to return the status of single task
   getRunningTaskStatus <- function(asyncTaskObject) {
@@ -238,7 +238,7 @@ getRunningTasksStatus <- function(asyncTasksRunning = vector(mode = "list")) {
 #' @param debug A logical. Set to TRUE if need to print intermediate results.
 #' @param maximumTaskToResolve An integer for the maximum number of tasks to resolve.
 #' @return An integer indicating the number of tasks currently running
-#' @import future.callr
+#' @import future future.callr
 processRunningTasks <- function(asyncTasksRunning = vector(mode = "list"),
                                 wait = FALSE, catchErrors = TRUE,
                                 debug = FALSE, maximumTasksToResolve = NULL){
@@ -404,7 +404,7 @@ processRunningTasks <- function(asyncTasksRunning = vector(mode = "list"),
 #' @return A list containing the components specified in the Set
 #' specifications for the module.
 #' @name RunScenarios
-#' @import future.callr
+#' @import future future.callr
 #' @export
 RunScenarios <- function(L){
   # Setup