Merge branch 'develop' into 2023_summary

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: useeior
 Type: Package
 Title: USEEIO R modeling software
-Version: 1.6.0
-Date: 2024-8-6
+Version: 1.6.1
+Date: 2024-11-4
 Authors@R: c(
   person("Ben","Young", email="[email protected]", role="aut"),
   person("Jorge","Vendries", email="[email protected]", role="aut"),

NAMESPACE

@@ -22,6 +22,8 @@ export(normalizeResultMatrixByTotalImpacts)
 export(plotMatrixCoefficient)
 export(printValidationResults)
 export(seeAvailableModels)
+export(testCalculationFunctions)
+export(testVisualizationFunctions)
 export(writeModelMatrices)
 export(writeModelforAPI)
 export(writeModeltoXLSX)

R/AdjustPrice.R

@@ -19,8 +19,12 @@ adjustResultMatrixPrice <- function(matrix_name, currency_year, purchaser_price=
   }
   # Adjust price type of multiplier
   if (purchaser_price) {
-    logging::loginfo(paste("Adjusting", matrix_name, "matrix from producer to purchaser price..."))
-    mat <- adjustMultiplierPriceType(mat, currency_year, model)
+    if(is.null(model$Phi)) {
+      logging::logwarn("Model does not contain margins, purchaser price can not be calculated")
+    } else {
+      logging::loginfo(paste("Adjusting", matrix_name, "matrix from producer to purchaser price..."))
+      mat <- adjustMultiplierPriceType(mat, currency_year, model)
+    }
   } else {
     logging::loginfo(paste("Keeping", matrix_name, "matrix in producer price..."))
   }

R/ValidateModel.R

@@ -494,3 +494,93 @@ validateHouseholdEmissions <- function(model) {
   result <- r$LCI_f[codes, names(flows)]
   all.equal(flows, result)
 }
+
+#' Test that model calculation functions are successful
+#' Includes tests for the following functions:
+#' adjustResultMatrixPrice, calculateFlowContributiontoImpact,
+#' calculateSectorContributiontoImpact, disaggregateTotalToDirectAndTier1,
+#' calculateSectorPurchasedbySectorSourcedImpact, aggregateResultMatrix,
+#' calculateMarginSectorImpacts
+#' 
+#' @param model, A fully built EEIO model object
+#' @export
+testCalculationFunctions <- function(model) {
+  target_year <- ifelse(model$specs$IOYear != 2019, 2019, 2020)
+  sector <- model$Commodities$Code_Loc[[10]]
+  indicator <- model$Indicators$meta$Name[[1]]
+
+  matrix <- adjustResultMatrixPrice(matrix_name = "N",
+                                    currency_year = target_year,
+                                    purchaser_price = TRUE,
+                                    model)
+  if(!all(dim(model$N) == dim(matrix)) && !all(model$N == matrix)) {
+    print("Error in adjustResultMatrixPrice()")
+  }
+
+  flow_contrib <- calculateFlowContributiontoImpact(model, sector, indicator)
+  if(!all.equal(sum(flow_contrib$contribution), 1)) {
+    print("Error in calculateFlowContributiontoImpact()")
+  }
+
+  sector_contrib <- calculateSectorContributiontoImpact(model, sector, indicator)
+  if(!all.equal(sum(sector_contrib$contribution), 1)) {
+    print("Error in calculateSectorContributiontoImpact()")
+  }
+
+  demand = model$DemandVectors$vectors[[1]]
+  result <- calculateSectorPurchasedbySectorSourcedImpact(y=demand, model, indicator)
+  if(model$specs$IODataSource != "stateior") {
+    # not working for 2R mode
+    agg_result <- aggregateResultMatrix(result, "Sector", model$crosswalk)
+  }
+
+  result <- disaggregateTotalToDirectAndTier1(model, indicator)
+
+  if(model$specs$IODataSource != "stateior") {
+    margins <- calculateMarginSectorImpacts(model)
+  }
+
+}
+
+#' Test that visualization functions are successful
+#' Includes tests for the following functions:
+#' barplotFloworImpactFractionbyRegion, barplotIndicatorScoresbySector, 
+#' heatmapSatelliteTableCoverage, heatmapSectorRanking, plotMatrixCoefficient
+#' 
+#' @param model, A fully built EEIO model object
+#' @export
+testVisualizationFunctions <- function(model) {
+  model_list <- list("model" = model)
+  loc <- model$specs$ModelRegionAcronyms[[1]]
+  indicator <- model$Indicators$meta$Name[[1]]
+
+  fullcons <- calculateEEIOModel(model, perspective='DIRECT', demand="Consumption",
+                                 location = loc)
+  domcons <- calculateEEIOModel(model, perspective='DIRECT', demand="Consumption",
+                                location = loc,  use_domestic_requirements = TRUE)
+  barplotFloworImpactFractionbyRegion(domcons$LCIA_d,
+                                      fullcons$LCIA_d,
+                                      "Domestic Proportion of Impact")
+  ## ^^ This may not be working correctly for 2R models
+
+  barplotIndicatorScoresbySector(model_list,
+                                 totals_by_sector_name = "GHG",
+                                 indicator_name = "Greenhouse Gases",
+                                 sector = FALSE, y_title = "")
+
+  heatmapSatelliteTableCoverage(model, form = "Industry")
+  # ^^ not working for form = "Commodity"
+
+  indicators <- model$Indicators$meta$Code[1:min(5, length(model$Indicators$meta$Code))]
+
+  if(model$specs$IODataSource != "stateior") {
+    # not working for 2R models
+    heatmapSectorRanking(model, matrix = fullcons$LCIA_d, indicators,
+                         sector_to_remove = "", N_sector = 20)
+  }
+
+  plotMatrixCoefficient(model_list, matrix_name = "D",
+                        coefficient_name = indicator,
+                        sector_to_remove = "", y_title = indicator,
+                        y_label = "Name")
+}

R/VisualizationFunctions.R

@@ -237,6 +237,9 @@ heatmapSatelliteTableCoverage <- function(model, form="Commodity") {
 #' @export
 heatmapSectorRanking <- function(model, matrix, indicators, sector_to_remove, N_sector, x_title = NULL,
                                  use_codes = TRUE) {
+  if(model$specs$IODataSource == "stateior") {
+    stop("heatmapSectorRanking not available for two-region models.")
+  }
   # Generate BEA sector color mapping
   mapping <- getBEASectorColorMapping(model)
   mapping$GroupName <- mapping$SectorName

tests/test_model_build.R

@@ -4,12 +4,14 @@
 # setwd("tests")
 library(useeior)
 # library(unittest, quietly = TRUE)
-if (!interactive()) options(warn=2, error = function() { sink(stderr()) ; traceback(3) ; q(status = 1) })
+if (!interactive()) options(warn=1, error = function() { sink(stderr()) ; traceback(3) ; q(status = 1) })
 
 ## USEEIOv2.0.1-411 Detail model with waste disaggregation
 m <- "USEEIOv2.0.1-411"
 model <- buildModel(m)
 printValidationResults(model)
+testCalculationFunctions(model)
+testVisualizationFunctions(model)
 
 ## USEEIOv2.0.1-411 Detail model with waste disaggregation (Economic only)
 m <- "USEEIOv2.0.1-411"
@@ -128,23 +130,24 @@ writeModeltoXLSX(model, ".")
 m <- "USEEIOv2.3-s-GHG-19"
 model <- buildModel(m)
 printValidationResults(model)
+testCalculationFunctions(model)
+testVisualizationFunctions(model)
 
 ## StateEEIOv1.0 Two-region Summary model
 m <- "GAEEIOv1.0-GHG-19"
-cfg <- paste0("modelspecs/", m, ".yml")
-model <- buildModel(m, configpaths = file.path(cfg))
+model <- buildModel(m)
 printValidationResults(model)
 writeModeltoXLSX(model, ".")
+testCalculationFunctions(model)
+testVisualizationFunctions(model)
 
 ## StateEEIOv1.0 Two-region Summary model (Economic only)
-model <- buildIOModel(m, configpaths = file.path(cfg))
+model <- buildIOModel(m)
 printValidationResults(model)
 writeModeltoXLSX(model, ".")
 
 ## StateEEIOv1.1 Two-region Summary model with Import Factors
-cfg <- c(paste0("modelspecs/", m, ".yml"),
-         "US_summary_import_factors_exio_2019_12sch.csv"
-         )
+cfg <- c("US_summary_import_factors_exio_2019_12sch.csv")
 model <- useeior:::initializeModel(m, configpaths = file.path(cfg))
 model$specs$Model <- "GAEEIOv1.1-GHG-19-IF"
 model$specs$ExternalImportFactors <- TRUE
@@ -157,6 +160,8 @@ model <- useeior:::loadandbuildIndicators(model)
 model <- useeior:::loadDemandVectors(model)
 model <- useeior:::constructEEIOMatrices(model, file.path(cfg))
 printValidationResults(model)
+testCalculationFunctions(model)
+testVisualizationFunctions(model)
 
 # ## StateEEIOv1.0 Two-region Summary model with Utility disaggregation
 # model <- useeior:::initializeModel(m, configpaths = file.path(cfg))