add households to CbS based on final demand totals; cast those coeffi…

…cients into new `B_h` matrix

R/BuildModel.R

@@ -88,6 +88,7 @@ constructEEIOMatrices <- function(model, configpaths = NULL) {
   # Generate B matrix
   logging::loginfo("Building B matrix (direct emissions and resource use per dollar)...")
   model$B <- createBfromFlowDataandOutput(model)
+  model$B_h <- as.matrix(standardizeandcastSatelliteTable(model$CbS, model, final_demand=TRUE))
   if(model$specs$ModelType == "EEIO-IH"){
     model$B <- hybridizeBMatrix(model)
   }
@@ -188,7 +189,8 @@ createBfromFlowDataandOutput <- function(model) {
 #' @return A dataframe of Coefficients-by-Sector (CbS) table
 generateCbSfromTbSandModel <- function(model) {
   CbS <- data.frame()
-
+  hh_codes <- subset(model$FinalDemandMeta, Group == "Household", select="Code")
+  hh_codes <- hh_codes[,"Code"]
     #Loop through model regions to get regional output
     for (r in model$specs$ModelRegionAcronyms) {
       tbs_r <- model$TbS[model$TbS$Location==r, ]
@@ -204,7 +206,12 @@ generateCbSfromTbSandModel <- function(model) {
         cbs_r_y <- generateFlowtoDollarCoefficient(tbs_r[tbs_r$Year==year, ], year,
                                                    model$specs$IOYear, r, IsRoUS = IsRoUS,
                                                    model, output_type = "Industry")
-        cbs_r <- rbind(cbs_r,cbs_r_y)
+        # Split out Household emissions and generate coefficients from final demand
+        cbs_h_r_y <- generateFlowtoDollarCoefficient(tbs_r[tbs_r$Year==year & tbs_r$Sector %in% hh_codes, ],
+                                                     year, model$specs$IOYear, r, IsRoUS = IsRoUS,
+                                                     model, output_type = "Industry",
+                                                     final_demand = TRUE)
+        cbs_r <- rbind(cbs_r,cbs_r_y,cbs_h_r_y)
       }
       CbS <- rbind(CbS,cbs_r)
     }
@@ -214,8 +221,9 @@ generateCbSfromTbSandModel <- function(model) {
 #' Converts flows table into flows x sector matrix-like format
 #' @param df a dataframe of flowables, contexts, units, sectors and locations
 #' @param model An EEIO model object with model specs, IO tables, satellite tables, and indicators loaded
+#' @param final_demand, bool, generate matrix based on final demand columns
 #' @return A matrix-like dataframe of flows x sector 
-standardizeandcastSatelliteTable <- function(df,model) {
+standardizeandcastSatelliteTable <- function(df, model, final_demand = FALSE) {
   # Add fields for sector as combinations of existing fields
   df[, "Sector"] <- apply(df[, c("Sector", "Location")],
                           1, FUN = joinStringswithSlashes)
@@ -224,10 +232,14 @@ standardizeandcastSatelliteTable <- function(df,model) {
   # Move Flow to rowname so matrix is all numbers
   rownames(df_cast) <- df_cast$Flow
   df_cast$Flow <- NULL
-  # Complete sector list according to model$Industries
-  df_cast[, setdiff(model$Industries$Code_Loc, colnames(df_cast))] <- 0
-  # Adjust column order to be the same with V_n rownames
-  df_cast <- df_cast[, model$Industries$Code_Loc]
+  if(final_demand) {
+    df_cast <- df_cast[, names(df_cast) %in% model$FinalDemandMeta$Code_Loc, drop=FALSE]
+  } else {
+    # Complete sector list according to model$Industries
+    df_cast[, setdiff(model$Industries$Code_Loc, colnames(df_cast))] <- 0
+    # Adjust column order to be the same with V_n rownames
+    df_cast <- df_cast[, model$Industries$Code_Loc]    
+  }
   return(df_cast)
 }
 

R/SatelliteFunctions.R

@@ -64,11 +64,19 @@ mapFlowTotalsbySectorandLocationfromNAICStoBEA <- function (totals_by_sector, to
 #' @param IsRoUS A logical parameter indicating whether to adjust Industry output for Rest of US (RoUS).
 #' @param model A complete EEIO model: a list with USEEIO model components and attributes.
 #' @param output_type Type of the output, e.g. "Commodity" or "Industry"
+#' @param final_demand, bool, generate coefficients using final demand vector
 #' @return A dataframe contains intensity coefficient (kg/$).
-generateFlowtoDollarCoefficient <- function (sattable, outputyear, referenceyear, location_acronym, IsRoUS = FALSE, model, output_type = "Industry") {
-  # Generate adjusted industry output
-  Output_adj <- adjustOutputbyCPI(outputyear, referenceyear, location_acronym, IsRoUS, model, output_type)
-  rownames(Output_adj) <- gsub(paste0("/", location_acronym), "", rownames(Output_adj))
+generateFlowtoDollarCoefficient <- function (sattable, outputyear, referenceyear, location_acronym,
+                                             IsRoUS = FALSE, model, output_type = "Industry", final_demand = FALSE) {
+  if(final_demand) {
+    Output_adj <- data.frame(colSums(model$FinalDemand))
+    # TODO adjust the final demand to reflect emission year!!
+    colnames(Output_adj) <- paste0(outputyear, output_type, "Output")
+  } else {
+    # Generate adjusted industry output
+    Output_adj <- adjustOutputbyCPI(outputyear, referenceyear, location_acronym, IsRoUS, model, output_type)
+  }
+  rownames(Output_adj) <- gsub(paste0("/", location_acronym), "", rownames(Output_adj))    
   # Merge the satellite table with the adjusted industry output
   Sattable_USEEIO_wOutput <- merge(sattable, Output_adj, by.x = "Sector", by.y = 0, all.x = TRUE)
   # Drop rows where output is zero