Merge pull request #283 from USEPA/release_v1.5.0

Release v1.5.0

.Rbuildignore

@@ -1,3 +1,5 @@
+^renv$
+^renv\.lock$
 ^.*\.Rproj$
 ^\.Rproj\.user$
 ^data-raw$

.github/workflows/R-CMD-check.yaml

@@ -37,7 +37,7 @@ jobs:
       fail-fast: false
       matrix:
         config:
-          - {os: macOS-latest,   r: 'release'}
+          # - {os: macOS-latest,   r: 'release'}
           - {os: windows-latest, r: 'release'}
           #- {os: ubuntu-latest,   r: 'devel', http-user-agent: 'release'}
           - {os: ubuntu-latest,   r: 'release'}
@@ -48,7 +48,7 @@ jobs:
       R_KEEP_PKG_SOURCE: yes
 
     steps:
-      - uses: actions/checkout@v3
+      - uses: actions/checkout@v4
 
       - uses: r-lib/actions/setup-pandoc@v2
 
@@ -66,78 +66,9 @@ jobs:
 
       - uses: r-lib/actions/check-r-package@v2
 
-      - name: Build and validate models - USEEIOv2.0-411 detail model with waste disaggregation
-        if: always()
-        run: |
-          require(devtools)
-          devtools::load_all()
-          m <- useeior::buildModel("USEEIOv2.0-411")
-          useeior::printValidationResults(m)
-        shell: Rscript {0}
-
-      - name: Build and validate models - USEEIOv2.0-i-411 detail industry model with waste disaggregation
-        if: always()
-        run: |
-          require(devtools)
-          devtools::load_all()
-          m <- useeior::buildModel("USEEIOv2.0-i-411")
-          useeior::printValidationResults(m)
-        shell: Rscript {0}
-
-      - name: Build and validate models - USEEIOv2.0 industry model
-        if: always()
-        run: |
-          require(devtools)
-          devtools::load_all()
-          m <- useeior::buildModel("USEEIOv2.0-i-GHG")
-          useeior::printValidationResults(m)
-        shell: Rscript {0}
-
-      - name: Build and validate models - USEEIOv2.0 summary model
-        if: always()
-        run: |
-          require(devtools)
-          devtools::load_all()
-          m <- useeior::buildModel("USEEIOv2.0-s-GHG")
-          useeior::printValidationResults(m)
-        shell: Rscript {0}
-
-      - name: Build and validate models - USEEIOv2.0.1-411 detail model with waste disaggregation
-        if: always()
-        run: |
-          require(devtools)
-          devtools::load_all()
-          m <- useeior::buildModel("USEEIOv2.0.1-411")
-          useeior::printValidationResults(m)
-        shell: Rscript {0}
-
-      - name: Build and validate models - USEEIOv2 - integrated hybrid
-        if: always()
-        run: |
-          require(devtools)
-          devtools::load_all()
-          m <- useeior::buildModel("USEEIOv2.0-GHG-NGCombustion")
-          useeior::printValidationResults(m)
-        shell: Rscript {0}
-
-      - name: Build and validate models - GAEEIOv1.0-s-WAT-12 summary two-region model
-        if: always()
-        run: |
-          require(devtools)
-          devtools::load_all()
-          m <- useeior::buildModel("GAEEIOv1.0-s-WAT-12")
-          useeior::print2RValidationResults(m)
-        shell: Rscript {0}
-
-      #- name: Show testthat output
-      #  if: always()  # step will run even if previous steps fail
-      #  run: find check -name 'testthat.Rout*' -exec cat '{}' \; || true
-      #  shell: bash
-
-      - name: Upload check results
-        if: failure()  # if any of the previous steps fail, export a log
+      - name: Upload model build and validation log
         uses: actions/upload-artifact@main
         with:
-          name: ${{ runner.os }}-r${{ matrix.config.r }}-results
-          path: check    
+          name: ${{ runner.os }}-r${{ matrix.config.r }}-test_model_build
+          path: check/useeior.Rcheck/tests/test_model_build*
 

.github/workflows/save-BEA-data.yaml

@@ -34,8 +34,6 @@ jobs:
           http-user-agent: ${{ matrix.config.http-user-agent }}
           use-public-rspm: true
 
-      - uses: r-lib/actions/setup-renv@v2
-
       - uses: r-lib/actions/setup-r-dependencies@v2
         with:
           extra-packages: devtools

.github/workflows/save-annual-BEA-data.yaml

@@ -34,8 +34,6 @@ jobs:
           http-user-agent: ${{ matrix.config.http-user-agent }}
           use-public-rspm: true
 
-      - uses: r-lib/actions/setup-renv@v2
-
       - uses: r-lib/actions/setup-r-dependencies@v2
         with:
           extra-packages: devtools

.gitignore

@@ -2,5 +2,8 @@
 .Rhistory
 .RData
 .Ruserdata
+.RProfile
 work
 inst/doc/**/*.html
+renv/
+examples

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: useeior
 Type: Package
 Title: USEEIO R modeling software
-Version: 1.4.0
-Date: 2024-1-19
+Version: 1.5.0
+Date: 2024-3-22
 Authors@R: c(
   person("Ben","Young", email="[email protected]", role="aut"),
   person("Jorge","Vendries", email="[email protected]", role="aut"),

R/AdjustPrice.R

@@ -46,11 +46,12 @@ calculateProducerbyPurchaserPriceRatio <- function(model) {
   Margins <- Margins[match(rownames(model$Rho), Margins$Code_Loc), ]
   # Prepare ratio table PHI
   PHI <- model$Rho
+  schema <- getSchemaCode(model$specs)
   for (year in colnames(model$Rho)) {
     # Adjust ProducersValue from model$specs$IOyear to currency year using model$Rho
     ProducersValue <- Margins$ProducersValue * (Margins[, year]/Margins[, as.character(model$specs$IOYear)])
     # Adjust Transportation, Wholesale and Retail using corresponding CPI_ratio
-    TWR_CPI <- useeior::Sector_CPI_IO[c("48TW", "42", "44RT"), ]
+    TWR_CPI <- get(paste0(na.omit(c('Sector_CPI_IO', schema)), collapse = "_"))[c("48TW", "42", "44RT"), ]
     TWR_CPI_ratio <- TWR_CPI[, year]/TWR_CPI[, as.character(model$specs$IOYear)]
     TWRValue <- sweep(Margins[, c("Transportation", "Wholesale", "Retail")], 2, TWR_CPI_ratio, "*")
     # Generate PRObyPURRatios, or phi vector

R/CalculationFunctions.R

@@ -322,44 +322,65 @@ calculateMarginSectorImpacts <- function(model) {
   return(ls)
 }
 
-#' For a given indicator, disaggregate total impacts per purchase (N) into 
-#' direct impacts (D) and upstream, Tier 1 purchase impacts. Return a long format
-#' dataframe of exchanges, with sector names mapped to sector codes.
+#' For a given impact, provided via indicator or elementary flow label, 
+#' disaggregate the total impacts per purchase (indicator: N, flow: M) into 
+#' direct impacts (indicator: D, flow: B) and upstream, Tier 1 purchase impacts. 
+#' Return a long-format df of exchanges, with sector names mapped to sector codes.
 #' @param model A complete EEIO model: a list with USEEIO model components and attributes
-#' @param indicator str, index of a model indicator, e.g. "Greenhouse Gases".
+#' @param impact str, a model indicator (e.g., "Greenhouse Gases") row index of N, 
+#'                    or elementary flow (e.g., "Methane/emission/air/kg") index of M
+#' @param opt_impact str {'indicator', 'elemflow'}, string code to specify impact type
 #' @export
 #' @return A data frame of direct and per-tier-1-purchase sector impacts
-disaggregateTotalToDirectAndTier1 <- function(model, indicator) {
-  sector_map <- setNames(model$Commodities$Name, model$Commodities$Code_Loc)
-
-  # direct sector impacts
-  df_D <- tibble::enframe(model$D[indicator,])
-  df_D <- dplyr::rename(df_D, impact_per_purchase=value, sector_code=name) 
+disaggregateTotalToDirectAndTier1 <- function(model, impact, opt_impact="indicator") {
+  mtx_direct <- c("indicator"="D", "elemflow"="B")[opt_impact]
+  if (is.na(mtx_direct)) {
+    stop(paste0("'",opt_impact,"' is not a valid opt_impact string code"))
+  }
+  # get direct sector impacts
+  df_direct <- tryCatch({  # catches bad `impact` row label
+      tibble::enframe(model[[mtx_direct]][impact,])
+  }, error=function(e) {
+      stop(paste0("'",impact,"' is not a valid ",opt_impact," label"))
+  })
+  df_direct <- dplyr::rename(df_direct, impact_per_purchase=value, sector_code=name) 
   # assign "Direct" as purchased commodity label for data-vis & stat convenience
-  df_D <- dplyr::mutate(df_D, purchased_commodity = 'Direct')
-
-  # total impacts per Tier 1 purchase by sector
-  df_N <- calculateTotalImpactbyTier1Purchases(model, indicator) 
-  df_N <- tibble::as_tibble(df_N, rownames="purchased_commodity_code") 
-  df_N <- reshape2::melt(df_N, id.vars="purchased_commodity_code", 
-                         variable.name="sector_code", 
-                         value.name="impact_per_purchase") 
-  df_N <- dplyr::mutate(df_N, purchased_commodity = dplyr::recode(
-    purchased_commodity_code, !!!sector_map))
-
-  # combined df 
-  df_impacts <- dplyr::bind_rows(df_N, df_D) 
-  df_impacts <- dplyr::mutate(df_impacts, sector = dplyr::recode(sector_code, !!!sector_map))
+  df_direct <- dplyr::mutate(df_direct, purchased_commodity = 'Direct')
+  # get total impacts per Tier 1 purchase by sector
+  df_total <- calculateTotalImpactbyTier1Purchases(model, impact, opt_impact) 
+  df_total <- tibble::as_tibble(df_total, rownames="purchased_commodity_code") 
+  df_total <- reshape2::melt(df_total, id.vars="purchased_commodity_code",
+                                       variable.name="sector_code",
+                                       value.name="impact_per_purchase") 
+  # map sector codes to names
+  sector_map <- setNames(model$Commodities$Name, model$Commodities$Code_Loc)
+  df_total <- dplyr::mutate(df_total, 
+    purchased_commodity = dplyr::recode(purchased_commodity_code, !!!sector_map))
+  # concat direct + total impacts  
+  df_impacts <- dplyr::bind_rows(df_total, df_direct) 
+  df_impacts <- dplyr::mutate(df_impacts, 
+    sector = dplyr::recode(sector_code, !!!sector_map))
   return(df_impacts)
 }
 
-#' Calculate sector x sector total impacts (single indicator) for Tier 1 purchases
-#' Multiply each row of sector x sector A matrix by scalar elements of an
-#' indicator (single) x sector array from N
+#' Calculate sector x sector total impacts (single indicator or elementary flow) 
+#' for Tier 1 purchases. Multiply each row of the sector by sector A matrix by 
+#' the scalar elements of a single-impact by sector array (indicator: N, flow: M)
 #' @param model A complete EEIO model: a list with USEEIO model components and attributes
-#' @param indicator str, index of a model indicator, e.g. "Greenhouse Gases".
-#' @return A sector x sector, impact-per-tier-1-purchase matrix.
-calculateTotalImpactbyTier1Purchases <- function(model, indicator) {
-  totalImpactPerPurchase <- model$N[indicator,] * model$A
+#' @param impact str, a model indicator (e.g., "Greenhouse Gases") row index of N, 
+#'                    or elementary flow (e.g., "Methane/emission/air/kg") index of M
+#' @param opt_impact str {'indicator', 'elemflow'}, string code to specify impact type
+#' @return A sector by sector, impact-per-tier-1-purchase matrix.
+calculateTotalImpactbyTier1Purchases <- function(model, impact, opt_impact='indicator') {
+  mtx_total <- c("indicator"="N", "elemflow"="M")[opt_impact]
+  if (is.na(mtx_total)) {
+    stop(paste0("'",opt_impact,"' is not a valid opt_impact string code"))
+  }
+  df_direct <- tryCatch({  # catches bad `impact` row label
+    totalImpactPerPurchase <- model[[mtx_total]][impact,] * model$A
+    # totalImpactPerPurchase <- model$N[impact,] * model[["A"]]
+  }, error=function(e) {
+    stop(paste0("'",impact,"' is not a valid ",opt_impact," label"))
+  })
   return(totalImpactPerPurchase)
 }

R/ConfigurationFunctions.R

@@ -12,7 +12,7 @@ getConfiguration <- function(configname, configtype, configpaths = NULL, pkg="us
   if (is.null(configpaths)) {
     configpath <- system.file(paste0("extdata/", configtype, "specs/"), configfile, package = pkg)
   } else {
-    configpath <- configpaths[endsWith(configpaths, configfile)]
+    configpath <- configpaths[endsWith(configpaths, paste0("/", configfile))]
     if (length(configpath) == 0) {
       # Specific input file not found in configpaths, assume it is in useeior
       configpath <- system.file(paste0("extdata/", configtype, "specs/"), configfile, package = "useeior")
@@ -24,6 +24,10 @@ getConfiguration <- function(configname, configtype, configpaths = NULL, pkg="us
     }
   }
   config <- configr::read.config(configpath)
+  if (typeof(config) == "logical" && config == FALSE) {
+    logging::logwarn(paste0("Configuration not found for ", configname))
+    return(NULL)
+  }
   return(config)
 }
 

R/CrosswalkFunctions.R

@@ -1,19 +1,11 @@
 # Functions that use sector crosswalks
 
-#' Function to externalize the BEA to NAICS crosswalk
-#' @return A crosswalk linking 2007 and 2012 NAICS codes to 2012 Sector, Summary, and Detail BEA codes
-loadMasterCrosswalk <- function(){
-  # Pull the mastercrosswalk created in the data-raw subdirectory
-  BEAtoNAICSCrosswalk <- useeior::MasterCrosswalk2012
-  return(BEAtoNAICSCrosswalk)
-}
-
 #' Determine allocation factors between NAICS and BEA sectors based on Industry output.
 #' @param model A complete EEIO model: a list with USEEIO model components and attributes.
 #' @param year Year of model Industry output.
 #' @return A table of allocation factors between NAICS and BEA sectors.
 getNAICStoBEAAllocation <- function (year, model) {
-  # Keep USEEIO and NAICS columns in MasterCrosswalk2012 table based on the model specs
+  # Keep USEEIO and NAICS columns in MasterCrosswalk table based on the model specs
   NAICStoBEA <- unique(model$crosswalk[, c("NAICS", "USEEIO")])
   colnames(NAICStoBEA) <- c("NAICS_Code", "BEA_Code")
   # Drop 2-digit NAICS code
@@ -41,26 +33,40 @@ getNAICStoBEAAllocation <- function (year, model) {
   return(AllocationTable)
 }
 
-
-#' Get 2-6 digit NAICS codes and names for year specified.
-#' @param year int. 2012 or 2007 accepted.
-#' @return dataframe with columns NAICS_year_Code and NAICS_year_Name.
-getNAICS2to6DigitsCodeName <- function (year) {
+#' Download NAICS file for 2-6 digit NAICS codes if not present.
+#' @param year int, 2017, 2012, or 2007 accepted.
+#' @return FileName str
+downloadNAICS2to6DigitsFile <- function (year) {
   # Download 2-6 digits NAICS table
-  if (year == 2012) {
-    FileName <- "inst/extdata/2-digit_2012_Codes.xls"
+  dir <- file.path(rappdirs::user_data_dir(), "USEEIO-input")
+  if (year == 2017) {
+    FileName <- file.path(dir, "2-digit_2017_Codes.xlsx")
+    url <- "https://www.census.gov/naics/2017NAICS/2-6%20digit_2017_Codes.xlsx"
+  } else if (year == 2012) {
+    FileName <- file.path(dir, "2-digit_2012_Codes.xls")
     url <- "https://www.census.gov/eos/www/naics/2012NAICS/2-digit_2012_Codes.xls"
-  } else {
-    FileName <- "inst/extdata/naics07.xls"
+  } else if (year == 2007) {
+    FileName <- file.path(dir, "naics07.xls")
     url <- "https://www.census.gov/eos/www/naics/reference_files_tools/2007/naics07.xls"
+  } else {
+    stop('Specify available year for crosswalk')
   }
   if(!file.exists(FileName)) {
     utils::download.file(url, FileName, mode = "wb")
   }
-
+  return(FileName)
+}
+
+
+#' Get 2-6 digit NAICS codes and names for year specified.
+#' @param year int. 2017, 2012, or 2007 accepted.
+#' @return dataframe with columns NAICS_year_Code and NAICS_year_Name.
+getNAICS2to6DigitsCodeName <- function (year) {
+  FileName <- downloadNAICS2to6DigitsFile(year)
   # Load 2-6 digits NAICS table
   NAICS <- as.data.frame(readxl::read_excel(FileName, sheet = 1, col_names = TRUE))[-1,-1]
   colnames(NAICS) <- c("NAICS_Code", "NAICS_Name")
+  NAICS <- NAICS[c("NAICS_Code", "NAICS_Name")] # Avoid extra columns
   # Split the NAICS code with dash ("-)
   DashSplit <- do.call("rbind.data.frame", apply(do.call("rbind", strsplit(NAICS$NAICS_Code, "-")),
                                                  1, function(x) seq(x[1], x[2], 1)))
@@ -80,24 +86,14 @@ getNAICS2to6DigitsCodeName <- function (year) {
 }
 
 #' Get 2-6 digit NAICS codes in a crosswalk format for year specified.
-#' @param year int, 2012 or 2007 accepted.
+#' @param year int, 2017, 2012 or 2007 accepted.
 #' @return data frame with columns NAICS_2, NAICS_3, NAICS_4, NAICS_5, NAICS_6.
 getNAICS2to6Digits <- function (year) {
-  # Download 2-6 digits NAICS table
-  if (year == 2012) {
-    FileName <- "inst/extdata/2-digit_2012_Codes.xls"
-    url <- "https://www.census.gov/eos/www/naics/2012NAICS/2-digit_2012_Codes.xls"
-  } else {
-    FileName <- "inst/extdata/naics07.xls"
-    url <- "https://www.census.gov/eos/www/naics/reference_files_tools/2007/naics07.xls"
-  }
-  if(!file.exists(FileName)) {
-    utils::download.file(url, FileName, mode = "wb")
-  }
-
+  FileName <- downloadNAICS2to6DigitsFile(year)
   # Load 2-6 digits NAICS table
   NAICS <- as.data.frame(readxl::read_excel(FileName, sheet = 1, col_names = TRUE))[-1,-1]
   colnames(NAICS) <- c("NAICS_Code", "NAICS_Name")
+  NAICS <- NAICS[c("NAICS_Code", "NAICS_Name")] # Avoid extra columns
   NAICS$NAICS_Code <- suppressWarnings(as.integer(NAICS$NAICS_Code))
   NAICS <- NAICS[!is.na(NAICS$NAICS_Code), ]
   # Reshape the table
@@ -201,7 +197,7 @@ getNAICSCodeName <- function(year) {
 #' @return data frame with columns '2012 NAICS Code', '2012 NAICS Title',
 #' '2007 NAICS Code', and '2007 NAICS Title'.
 getNAICS2012to2007Concordances <- function() {
-  filename <- "inst/extdata/2012_to_2007_NAICS.xls"
+  filename <- file.path(rappdirs::user_data_dir(), "USEEIO-input", "2012_to_2007_NAICS.xls")
   if(!file.exists(filename)) {
     utils::download.file("https://www.census.gov/naics/concordances/2012_to_2007_NAICS.xls",
                          filename, mode = "wb")
@@ -215,9 +211,9 @@ getNAICS2012to2007Concordances <- function() {
 #' @return data frame with columns '2012 NAICS Code', '2012 NAICS Title',
 #' '2017 NAICS Code', and '2017 NAICS Title'.
 getNAICS2012to2017Concordances <- function() {
-  filename <- "inst/extdata/2012_to_2017_NAICS.xlsx"
+  filename <- file.path(rappdirs::user_data_dir(), "USEEIO-input", "2012_to_2017_NAICS.xlsx")
   if(!file.exists(filename)) {
-    utils::download.file("https://www.census.gov/naics/concordances/2012_to_2017_NAICS.xlsx",
+    utils::download.file("https://www.census.gov/naics/concordances/2012_to_2017_NAICS.xls",
                          filename, mode = "wb")
   }
   df <- as.data.frame(readxl::read_excel(filename, sheet = 1, col_names = TRUE, skip = 2))