Merge pull request #270 from johannah-pik/bugfixHistTimesteps

Bugfix histTimesteps & ICEban trucks, busses

.buildlibrary

@@ -1,4 +1,4 @@
-ValidationKey: '4188030'
+ValidationKey: '4208817'
 AutocreateReadme: yes
 AcceptedWarnings:
 - 'Warning: package ''.*'' was built under R version'

CITATION.cff

@@ -2,8 +2,8 @@ cff-version: 1.2.0
 message: If you use this software, please cite it using the metadata from this file.
 type: software
 title: 'edgeTransport: Prepare EDGE Transport Data for the REMIND model'
-version: 2.1.0
-date-released: '2024-08-08'
+version: 2.1.1
+date-released: '2024-08-12'
 abstract: EDGE-T is a fork of the GCAM transport module https://jgcri.github.io/gcam-doc/energy.html#transportation
   with a high level of detail in its representation of technological and modal options.
   It is a partial equilibrium model with a nested multinomial logit structure and

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: edgeTransport
 Title: Prepare EDGE Transport Data for the REMIND model
-Version: 2.1.0
+Version: 2.1.1
 Authors@R: c(
     person("Johanna", "Hoppe", , "[email protected]", role = c("aut", "cre"),
            comment = c(ORCID = "0009-0004-6753-5090")),
@@ -18,7 +18,7 @@ Encoding: UTF-8
 LazyData: true
 RoxygenNote: 7.3.2
 VignetteBuilder: knitr
-Date: 2024-08-08
+Date: 2024-08-12
 Config/testthat/edition: 3
 Imports:
     rmndt,

NAMESPACE

@@ -6,6 +6,7 @@ export(checkForNAsDups)
 export(csv2RDS)
 export(getFilterEntriesUnivocalName)
 export(iterativeEdgeTransport)
+export(toolApplyICEbanOnPreferences)
 export(toolApplyMixedTimeRes)
 export(toolCalculateFS3share)
 export(toolCalculateFleetComposition)
@@ -17,6 +18,7 @@ export(toolLoadDecisionTree)
 export(toolLoadInputs)
 export(toolLoadIterativeInputs)
 export(toolLoadREMINDesDemand)
+export(toolNormalizePreferences)
 export(toolOrderandCheck)
 export(toolPrepareScenInputData)
 export(toolTraverseDecisionTree)

R/supportFunctions.R

@@ -1,3 +1,30 @@
+#' Normalize preferences so that the maximum in each branch of the decision tree equals 1
+#'
+#' @author Johanna Hoppe
+#' @param preferenceTab data.table including preferences for all levels of the decision tree
+#' @returns Normalized preferences
+#' @import data.table
+#' @export
+
+toolNormalizePreferences <- function(preferenceTab) {
+  preferenceTab[level == "S1S", max := max(value), by = c("region", "period", "sector")]
+  preferenceTab[level == "S1S" & max != 0, value := value/max(value), by = c("region", "period", "sector")] # S1S: logit level: distances (e.g. short-medium, long)
+  preferenceTab[level == "S2S1", max := max(value), by = c("region", "period", "sector", "subsectorL1")]
+  preferenceTab[level == "S2S1" & max != 0, value := value/max(value), by = c("region", "period", "sector", "subsectorL1")] # S2S1: logit level: modes/categories (e.g. walk, road, rail)
+  preferenceTab[level == "S3S2", max := max(value), by = c("region", "period", "sector", "subsectorL1", "subsectorL2")]
+  preferenceTab[level == "S3S2" & max != 0, value := value/max(value), by = c("region", "period", "sector", "subsectorL1", "subsectorL2")] # S3S2: logit level: modes/technologies (e.g. LDV, bus, Liquids)
+  preferenceTab[level == "VS3", max := max(value), by = c("region", "period", "sector", "subsectorL1", "subsectorL2", "subsectorL3")]
+  preferenceTab[level == "VS3" & max != 0, value := value/max(value), by = c("region", "period", "sector", "subsectorL1", "subsectorL2", "subsectorL3")] # VS3: logit level: modes/technologies (e.g. cars, Liquids)
+  preferenceTab[level == "FV", max := max(value), by = c("region", "period", "sector", "subsectorL1", "subsectorL2", "subsectorL3", "vehicleType")]
+  preferenceTab[level == "FV" & max != 0, value := value/max(value), by = c("region", "period", "sector", "subsectorL1", "subsectorL2", "subsectorL3", "vehicleType")]  # FV: logit level: vehicle type (e.g. large car, moped)
+  preferenceTab[, max := NULL]
+
+  if (anyNA(preferenceTab)) stop("Something went wrong with the normalization of the preference trends. Please check toolNormalizePreferences()")
+
+  return(preferenceTab)
+}
+
+
 #' Read and build the complete structure of the edgeTransport decision tree
 #'
 #' @author Johanna Hoppe

R/toolApplyICEbanOnPreferences.R

@@ -0,0 +1,30 @@
+#' Apply ICE ban on vehicle types that feature preference factors
+#'
+#' @author Johanna Hoppe
+#' @param preferenceTab data.table including preferences for all levels of the decision tree
+#' @param helpers list of helpers
+#' @returns Preferences in accordance to the ICE ban policy
+#' @import data.table
+#' @export
+
+toolApplyICEbanOnPreferences <- function(preferenceTab, helpers) {
+  #Ban is applied to EU28
+  affectedRegions <- unique(helpers$regionmappingISOto21to12[regionCode12 == "EUR"]$regionCode21)
+  #affectedRegions <- affectedRegions[!affectedRegions == "UKI"] currently we apply the ban also to UK
+  preferenceTab[level == "FV" & region %in% affectedRegions & (subsectorL1 == "trn_freight_road" | subsectorL2 == "Bus") & technology %in% c("Liquids", "Gases"),
+             value := ifelse(period == 2025, 0.98 * value[period == 2015], value), by = c("region","technology")]
+  preferenceTab[level == "FV" & region %in% affectedRegions & (subsectorL1 == "trn_freight_road" | subsectorL2 == "Bus") & technology %in% c("Liquids", "Gases"),
+             value := ifelse(period == 2030, 0.75 * value[period == 2015], value), by = c("region","technology")]
+  preferenceTab[level == "FV" & region %in% affectedRegions & (subsectorL1 == "trn_freight_road" | subsectorL2 == "Bus") & technology %in% c("Liquids", "Gases"),
+             value := ifelse(period == 2035, 0.3 * value[period == 2015], value), by = c("region","technology")]
+  preferenceTab[level == "FV" & region %in% affectedRegions & (subsectorL1 == "trn_freight_road" | subsectorL2 == "Bus") & technology %in% c("Liquids", "Gases"),
+             value := ifelse(period == 2040, 0.2 * value[period == 2015], value), by = c("region","technology")]
+  preferenceTab[level == "FV" & region %in% affectedRegions & (subsectorL1 == "trn_freight_road" | subsectorL2 == "Bus") & technology %in% c("Liquids", "Gases"),
+             value := ifelse(period == 2045, 0.1  * value[period == 2015], value), by = c("region","technology")]
+  preferenceTab[level == "FV" & region %in% affectedRegions & (subsectorL1 == "trn_freight_road" | subsectorL2 == "Bus") & technology %in% c("Liquids", "Gases"),
+             value := ifelse(period > 2045, value * 0.05, value), by = c("region","technology")]
+
+  if (anyNA(preferenceTab)) stop("Something went wrong with the ICE ban application. Please check toolApplyICEbanOnPreferences()")
+
+  return(preferenceTab)
+}

R/toolApplyScenPrefTrends.R

@@ -31,7 +31,6 @@ toolApplyScenPrefTrends <- function(baselinePrefTrends, scenParPrefTrends, GDPpc
   GDPpcMER[, regionCat := ifelse(region %in% individualReg, region, regionCat)]
   mitigationFactors <- merge(mitigationFactors, GDPpcMER, by = "regionCat", allow.cartesian = TRUE, all.x = TRUE)[, regionCat := NULL]
   # apply mitigation factors
-
   checkMitigation <- copy(baselinePrefTrends)
   setnames(checkMitigation, "value", "old")
   PrefTrends <- merge(baselinePrefTrends, mitigationFactors, by = c("region", "level", "subsectorL1", "subsectorL2", "vehicleType", "technology"), all.x = TRUE, allow.cartesian = TRUE)
@@ -40,32 +39,6 @@ toolApplyScenPrefTrends <- function(baselinePrefTrends, scenParPrefTrends, GDPpc
   check[, diff := abs(value - old)]
   if (max(check$diff) < 0.001) stop("Mitigation preference factors have not been applied correctly. Please check toolApplyScenPrefTrends()")
 
-  # normalize preferences in each level
-  PrefTrends[level == "S1S", value := value/max(value), by = c("region", "period", "sector")] # S1S: logit level: distances (e.g. short-medium, long)
-  PrefTrends[level == "S2S1", value := value/max(value), by = c("region", "period", "sector", "subsectorL1")] # S2S1: logit level: modes/categories (e.g. walk, road, rail)
-  PrefTrends[level == "S3S2", value := value/max(value), by = c("region", "period", "sector", "subsectorL1", "subsectorL2")] # S3S2: logit level: modes/technologies (e.g. LDV, bus, Liquids)
-  PrefTrends[level == "VS3", value := value/max(value), by = c("region", "period", "sector", "subsectorL1", "subsectorL2", "subsectorL3")] # VS3: logit level: modes/technologies (e.g. cars, Liquids)
-  PrefTrends[level == "FV", value := value/max(value), by = c("region", "period", "sector", "subsectorL1", "subsectorL2", "subsectorL3", "vehicleType")]  # FV: logit level: vehicle type (e.g. large car, moped)
-
-  # Apply ICE ban if switched on
-  if (isICEban) {
-    #Ban is applied to EU28
-    affectedRegions <- unique(helpers$regionmappingISOto21to12[regionCode12 == "EUR"]$regionCode21)
-    #affectedRegions <- affectedRegions[!affectedRegions == "UKI"] currently we apply the ban also to UK
-    PrefTrends[level == "FV" & region %in% affectedRegions & (subsectorL1 == "trn_freight_road" | subsectorL2 == "Bus") & technology %in% c("Liquids", "Gases"),
-               value := ifelse(period == 2025, 0.98 * value[period == 2015], value), by = c("region","technology")]
-    PrefTrends[level == "FV" & region %in% affectedRegions & (subsectorL1 == "trn_freight_road" | subsectorL2 == "Bus") & technology %in% c("Liquids", "Gases"),
-               value := ifelse(period == 2030, 0.75 * value[period == 2015], value), by = c("region","technology")]
-    PrefTrends[level == "FV" & region %in% affectedRegions & (subsectorL1 == "trn_freight_road" | subsectorL2 == "Bus") & technology %in% c("Liquids", "Gases"),
-               value := ifelse(period == 2035, 0.3 * value[period == 2015], value), by = c("region","technology")]
-    PrefTrends[level == "FV" & region %in% affectedRegions & (subsectorL1 == "trn_freight_road" | subsectorL2 == "Bus") & technology %in% c("Liquids", "Gases"),
-               value := ifelse(period == 2040, 0.2 * value[period == 2015], value), by = c("region","technology")]
-    PrefTrends[level == "FV" & region %in% affectedRegions & (subsectorL1 == "trn_freight_road" | subsectorL2 == "Bus") & technology %in% c("Liquids", "Gases"),
-               value := ifelse(period == 2045, 0.1  * value[period == 2015], value), by = c("region","technology")]
-    PrefTrends[level == "FV" & region %in% affectedRegions & (subsectorL1 == "trn_freight_road" | subsectorL2 == "Bus") & technology %in% c("Liquids", "Gases"),
-               value := ifelse(period > 2045, value * 0.05, value), by = c("region","technology")]
-  }
-
   PrefTrends[, variable := paste0("Preference|", level)][, unit := "-"]
   # order
   PrefTrends <- PrefTrends[, c("region", "period", "technology", "vehicleType", "subsectorL3", "subsectorL2", "subsectorL1", "sector", "level", "variable", "unit", "value")]

R/toolCalculateFS3share.R

@@ -1,5 +1,5 @@
 #' @title toolCalculateFS3share
-#' @description Provides updates for endogenous cost components e.g. inconvenience costs for cars
+#' @description Calculates fuel subsector L3 shares
 #'
 #' @param endoCostData data.table containing all cost components on technology level
 #' @param timesteps years for which to calculate FS3 shares
@@ -52,7 +52,6 @@ toolCalculateFS3share <- function(endoCostData, timesteps, timeValue, preference
   VS3share[, test := sum(VS3share), by = c("region", "period", "subsectorL3")]
   if (nrow(VS3share[test < 0.9999 | test > 1.0001]) > 0) stop("VS3 shares in toolPrepareEndogenousCosts were not calculated correctly")
   VS3share[, test := NULL]
-
   shares <- merge(FVshare, VS3share, by = c("region", "period", "sector", "subsectorL1", "subsectorL2", "subsectorL3", "vehicleType"), allow.cartesian = TRUE)
   shares <- shares[, .(FS3share = sum(VS3share * FVshare)), by = c("region", "period", "sector", "subsectorL1", "subsectorL2", "subsectorL3", "technology")]
   shares[, test := sum(FS3share), by = c("region", "period", "subsectorL3")]

R/toolEdgeTransportSA.R

@@ -80,10 +80,13 @@ toolEdgeTransportSA <- function(SSPscen,
                                       inputDataRaw$timeValueCosts,
                                       genModelPar$lambdasDiscreteChoice,
                                       helpers)
+
   scenSpecPrefTrends <- rbind(histPrefs$historicalPreferences,
                               scenSpecInputData$scenSpecPrefTrends)
   scenSpecPrefTrends <- toolApplyMixedTimeRes(scenSpecPrefTrends,
                                               helpers)
+  if (isICEban) scenSpecPrefTrends <- toolApplyICEbanOnPreferences(scenSpecPrefTrends, helpers)
+  scenSpecPrefTrends <- toolNormalizePreferences(scenSpecPrefTrends)
 
   #-------------------------------------------------------
   inputData <- list(
@@ -227,6 +230,7 @@ toolEdgeTransportSA <- function(SSPscen,
     fleetSizeAndComposition = fleetSizeAndComposition,
     endogenousCosts = endogenousCosts,
     vehSalesAndModeShares = vehSalesAndModeShares,
+    sectorESdemand = sectorESdemand,
     ESdemandFVsalesLevel = ESdemandFVsalesLevel,
     helpers = helpers
   )

README.md

@@ -1,6 +1,6 @@
 # Prepare EDGE Transport Data for the REMIND model
 
-R package **edgeTransport**, version **2.1.0**
+R package **edgeTransport**, version **2.1.1**
 
 [![CRAN status](https://www.r-pkg.org/badges/version/edgeTransport)](https://cran.r-project.org/package=edgeTransport)  [![R build status](https://github.com/pik-piam/edgeTransport/workflows/check/badge.svg)](https://github.com/pik-piam/edgeTransport/actions) [![codecov](https://codecov.io/gh/pik-piam/edgeTransport/branch/master/graph/badge.svg)](https://app.codecov.io/gh/pik-piam/edgeTransport) [![r-universe](https://pik-piam.r-universe.dev/badges/edgeTransport)](https://pik-piam.r-universe.dev/builds)
 
@@ -46,7 +46,7 @@ In case of questions / problems please contact Johanna Hoppe <johanna.hoppe@pik-
 
 To cite package **edgeTransport** in publications use:
 
-Hoppe J, Dirnaichner A, Rottoli M, Muessel J (2024). _edgeTransport: Prepare EDGE Transport Data for the REMIND model_. R package version 2.1.0, <https://github.com/pik-piam/edgeTransport>.
+Hoppe J, Dirnaichner A, Rottoli M, Muessel J (2024). _edgeTransport: Prepare EDGE Transport Data for the REMIND model_. R package version 2.1.1, <https://github.com/pik-piam/edgeTransport>.
 
 A BibTeX entry for LaTeX users is
 
@@ -55,7 +55,7 @@ A BibTeX entry for LaTeX users is
   title = {edgeTransport: Prepare EDGE Transport Data for the REMIND model},
   author = {Johanna Hoppe and Alois Dirnaichner and Marianna Rottoli and Jarusch Muessel},
   year = {2024},
-  note = {R package version 2.1.0},
+  note = {R package version 2.1.1},
   url = {https://github.com/pik-piam/edgeTransport},
 }
 ```