# Functions for assembling final demand vectors
#'Registry of functions that construct various demand vector in the form of as a named list with nested names
#'as keys and function name as values
DemandVectorFunctionRegistry <- list()
# Production
DemandVectorFunctionRegistry$Production$Complete <- "prepareProductionDemand"
DemandVectorFunctionRegistry$Production$Domestic <- "prepareDomesticProductionDemand"
# Consumption
DemandVectorFunctionRegistry$Consumption$Complete <- "prepareConsumptionDemand"
DemandVectorFunctionRegistry$Consumption$Domestic <- "prepareDomesticConsumptionDemand"
DemandVectorFunctionRegistry$Consumption$Household <- "prepareHouseholdDemand"
#' Sums across sectors for a given set of codes/cols in a given final demand df
#' @param Y, a model Demand df
#' @param codes, sector code(s) for a subset of Final Demand cols
#' @return A named vector with model sectors and demand amounts
sumDemandCols <- function(Y,codes) {
if (length(codes)>1) {
y <- rowSums(Y[,codes])
} else {
y <- Y[,codes]
names(y) <- rownames(Y)
}
return(y)
}
#' Sums the demand cols representing final consumption, i.e. household, investment, and government
#' Complete national consumption formula: y_c <- Y_h + Y_v + Y_g
#' Domestic portion of national consumption: y_dc <- Y_dh + Y_dv + Y_dg
#' @param model An EEIO model object with model specs and IO tables loaded
#' @param Y, a model Demand df.
#' @param location, str of location code for demand vector
#' @return A named vector with model sectors and demand amounts
sumforConsumption <- function(model, Y, location) {
codes <- model$FinalDemandMeta[model$FinalDemandMeta$Group%in%c("Household", "Investment", "Government") &
grepl(location, model$FinalDemandMeta$Code_Loc),
"Code_Loc"]
y_c <- sumDemandCols(Y, codes)
return (y_c)
}
#' Prepares a demand vector representing production
#' Formula for production vector: y_p <- y_c + y_e + y_m + y_delta
#' where y_c = consumption, y_e = exports, y_m = imports, y_delta = change in inventories
#' y_m values are generally negative in the BEA data and thus are added (whereas when positive they are subtracted)
#' @param model An EEIO model object with model specs and IO tables loaded
#' @param location, str of location code for demand vector
#' @return A named vector with demand
prepareProductionDemand <- function(model, location) {
if (model$specs$IODataSource == "stateior") {
y_p <- prepare2RDemand(model, location, domestic = FALSE)
} else {
loc <- grepl(location, model$FinalDemandMeta$Code_Loc)
export_code <- model$FinalDemandMeta[model$FinalDemandMeta$Group=="Export" & loc, "Code_Loc"]
changeinventories_code <- model$FinalDemandMeta[model$FinalDemandMeta$Group=="ChangeInventories" & loc, "Code_Loc"]
import_code <- model$FinalDemandMeta[model$FinalDemandMeta$Group=="Import" & loc, "Code_Loc"]
y_c <- sumforConsumption(model, model$FinalDemand, location)
y_e <- sumDemandCols(model$FinalDemand, export_code)
y_m <- sumDemandCols(model$FinalDemand, import_code)
y_delta <- sumDemandCols(model$FinalDemand, changeinventories_code)
y_p <- y_c + y_e + y_m + y_delta
}
return(y_p)
}
#' Prepares a demand vector representing domestic production
#' Formula for production vector: y_p <- y_dc + y_e + y_d_delta + mu
#' @param model An EEIO model object with model specs and IO tables loaded
#' @param location, str of location code for demand vector
#' @return A named vector with demand
prepareDomesticProductionDemand <- function(model, location) {
if (model$specs$IODataSource == "stateior") {
# This calls the same function as non-domestic demand since for 2R models the non-domestic Use table is replaced with
# domestic Use table with trade, meaning the model$U and model$U_d objects are equal.
y_d_p <- prepare2RDemand(model, location, domestic = TRUE)
} else {
loc <- grepl(location, model$FinalDemandMeta$Code_Loc)
export_code <- model$FinalDemandMeta[model$FinalDemandMeta$Group=="Export" & loc, "Code_Loc"]
changeinventories_code <- model$FinalDemandMeta[model$FinalDemandMeta$Group=="ChangeInventories" & loc, "Code_Loc"]
y_d_c <- sumforConsumption(model, model$DomesticFinalDemand, location)
y_d_e <- sumDemandCols(model$DomesticFinalDemand, export_code)
y_d_delta <- sumDemandCols(model$DomesticFinalDemand, changeinventories_code)
mu <- model$InternationalTradeAdjustment
y_d_p <- y_d_c + y_d_e + y_d_delta + mu
}
return(y_d_p)
}
#' Prepares a demand vector representing consumption
#' @param model An EEIO model object with model specs and IO tables loaded
#' @param location, str of location code for demand vector
#' @return a named vector with demand
prepareConsumptionDemand <- function(model, location) {
if (model$specs$IODataSource == "stateior") {
y_c <- prepare2RDemand(model, location, domestic = FALSE, demand_type = "Consumption")
} else {
y_c <- sumforConsumption(model, model$FinalDemand, location)
}
return(y_c)
}
#' Prepares a demand vector representing domestic consumption
#' @param model An EEIO model object with model specs and IO tables loaded
#' @param location, str of location code for demand vector
#' @return A named vector with demand
prepareDomesticConsumptionDemand <- function(model, location) {
if (model$specs$IODataSource == "stateior") {
y_c_d <- prepare2RDemand(model, location, domestic = TRUE, demand_type = "Consumption")
} else {
y_c_d <- sumforConsumption(model, model$DomesticFinalDemand, location)
}
return(y_c_d)
}
#' Prepares a demand vector representing household consumption
#' @param model An EEIO model object with model specs and IO tables loaded
#' @param location, str of location code for demand vector
#' @return A named vector with demand
prepareHouseholdDemand <- function(model, location) {
Y <- model$FinalDemand
household_code <- model$FinalDemandMeta[model$FinalDemandMeta$Group=="Household" &
grepl(location, model$FinalDemandMeta$Code_Loc), "Code_Loc"]
y_h <- sumDemandCols(Y, household_code)
return(y_h)
}
#' A function to validate a user provided demand vector
#' @param dv a user provided demand vector
#' @param L, the L matrix for the given model, used as a reference
#' @return A logical value indicating demand vector is valid or not.
isDemandVectorValid <- function(dv, L){
# dv should be a named numeric vector
# names of dv should be part of sectors in L
is_valid <- all(is.numeric(dv), all(names(dv)%in%rownames(L)))
return(is_valid)
}
#' Format a named demand vector with partial sectors to have all the rows and ordering needed
#' @param dv, a user provided demand vector. See calculateEEIOModel()
#' @param L, the L matrix for the given model, used as a reference
#' @return A named vector with values for all names in L and ordered like L
#' @export
formatDemandVector <- function(dv,L) {
#create a named vector using the first col of L
d <- c(L[,1])
#Set all values to 0
d[0:nrow(L)] <- 0
#merge in names from dv
#replace the values from d
d[match(names(dv),names(d))] <- dv
return(d)
}
#' Read demand vector from a csv file and format for use in model calculations
#' @param file_path str, path to csv file containing demand data
#' @param demand_name str, name of demand data as field header
#' @param model, a model
#' @return a demand vector formatted for use in calculating model results
#' @export
extractAndFormatDemandVector <- function(file_path, demand_name, model){
demand_df <- read.csv(file_path, stringsAsFactors = FALSE)
row.names(demand_df) <- demand_df$Code
demand_df$Code <- NULL
y <- na.omit(demand_df[,demand_name])
names(y) <- row.names(demand_df)
if(isDemandVectorValid(y, model$L)) {
y <- formatDemandVector(y, model$L)
} else {
stop("Format of the demand vector is invalid.")
}
return(y)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.