improved disaggregation and stability

.gitignore

@@ -8,18 +8,10 @@ inst/extdata/regional/.DS_Store
 inst/extdata/sectoral/baitregression-files_test.csv
 inst/regional/
 inst/sectoral/
-man/aggCells.Rd
-man/blend.Rd
-man/calcBAIT.Rd
-man/calcBAITpars.Rd
-man/calcCellHDDCDD.Rd
-man/calcHDDCDDFactors.Rd
-man/calcStackHDDCDD.Rd
-man/cfac.Rd
-man/checkDates.Rd
-man/convertISIMIPbuildings.Rd
-man/convertWEO.Rd
-man/prepBaitInput.Rd
-man/readISIMIPbuildings.Rd
-man/readWEO.Rd
-man/smooth.Rd
+R/readUvalues.R
+
+inst/extdata/sectoral/filemappings/start_GFDL-ESM4_picontrol.R
+inst/extdata/sectoral/filemappings/start_IPSL-CM6A-LR_picontrol.R
+inst/extdata/sectoral/filemappings/start_MPI-ESM1-2-HR_picontrol.R
+inst/extdata/sectoral/filemappings/start_MRI-ESM2-0_picontrol.R
+inst/extdata/sectoral/filemappings/start_UKESM1-0-LL_picontrol.R

NAMESPACE

@@ -43,7 +43,6 @@ export(convertPFUDB)
 export(convertTCEP)
 export(convertUNHouseholds)
 export(fullEDGEBUILDINGS)
-export(getFEbyEUEC)
 export(readCensusHub)
 export(readDaioglou)
 export(readDeetman2020)

R/calcFEbyEUEC.R

@@ -104,7 +104,8 @@ calcFEbyEUEC <- function() {
     toolDisaggregate(enduseShares  = sharesEU,
                      exclude       = exclude,
                      dataDisagg    = feDisagg,
-                     regionMapping = regmapping) %>%
+                     regionMapping = regmapping,
+                     outliers      = c("IND", "CHN", "ZAF")) %>%
     select("region", "period", "unit", "carrier", "enduse", "value")
 
 
@@ -129,28 +130,9 @@ calcFEbyEUEC <- function() {
     reframe(replaceValue = .data[["value"]],
             period = .data[["period"]])
 
-  # partial value replacements (due to e.g. partial optimization infeasibilities)
-  data <- ieaIODis %>%
-    left_join(dataReplaceFill, by = c("region", "carrier", "enduse", "period")) %>%
-    mutate(delta = .data[["value"]] / .data[["replaceValue"]]) %>%
-    group_by(across(all_of(c("region", "enduse", "carrier")))) %>%
-    mutate(delta = mean(.data[["delta"]], na.rm = TRUE)) %>%
-    ungroup() %>%
-    mutate(value = ifelse(!is.na(.data[["value"]]),
-                          ifelse(.data[["value"]] == 0,
-                                 ifelse(.data[["replaceValue"]] > 0 | is.na(.data[["replaceValue"]]),
-                                        .data[["replaceValue"]] * .data[["delta"]],
-                                        .data[["value"]]),
-                                 ifelse(.data[["replaceValue"]] == 0 & !is.na(.data[["replaceValue"]]),
-                                        .data[["replaceValue"]],
-                                        .data[["value"]])),
-                          0)) %>%
-    select(-"replaceValue") %>%
-    interpolate_missing_periods(expand.values = TRUE) %>%
-    mutate(value = replace_na(.data[["value"]], 0))
 
   # existing disaggregated data replaces values from optimization
-  data <- data %>%
+  data <- ieaIODis %>%
     left_join(dataReplaceFull, by = c("region", "period", "carrier", "enduse")) %>%
     mutate(value = ifelse(is.na(.data[["replaceValue"]]),
                           .data[["value"]],
@@ -163,11 +145,11 @@ calcFEbyEUEC <- function() {
   # For unknown reasons, the enduse share of "space_cooling" for region "Africa"
   # is not met and will therefore be corrected. Since "space_cooling" only corresponds
   # to the carrier "elec", the correction is straight-forward.
-  # TODO: check if this can be fixed #nolint
+  # TODO: check if this can be fixed
 
   elecSpaceCoolingShare <- sharesEU %>%
-    filter(.data[["region"]] == "Africa",
-           .data[["enduse"]] == "space_cooling") %>%
+    filter(region == "Africa",
+           enduse == "space_cooling") %>%
     select("period", "value") %>%
     rename("share" = "value")
 

R/calcHDDCDD.R

@@ -599,7 +599,7 @@ compHDDCDDFactors <- function(tlow, tup, tlim, tambStd = 5, tlimStd = 5) {
         check <- FALSE
       }
     } else if (typeDD == "CDD") {
-      if (tlim - tamb > 2 * stdDif) {
+      if (tlim - tamb > stdDif) {
         check <- FALSE
       }
     }
@@ -625,19 +625,16 @@ compHDDCDDFactors <- function(tlow, tup, tlim, tambStd = 5, tlimStd = 5) {
                                         "factor_err"   = 0,
                                         "typeDD"       = typeDD)
                     } else {
-
-                      # integration boundaries
-                      x1 <- .tlim - 4 * tlimStd
-                      x2 <- .tlim + 4 * tlimStd
-                      y1 <- min(.tlim - 3 * tlimStd, tamb - 3 * tlimStd)
-                      y2 <- max(.tlim + 3 * tlimStd, tamb + 3 * tlimStd)
+                      # tlim integration boundaries
+                      x1 <- .tlim - 3*tlimStd
+                      x2 <- .tlim + 3*tlimStd
 
                       if (typeDD == "HDD") {
                         f <- integral2(heatingFactor,
                                        xmin = x1,
                                        xmax = x2,
-                                       ymin = y1,
-                                       ymax = function(x) {x}, #nolint
+                                       ymin = tamb - 3*tambStd,
+                                       ymax = min(.tlim, tamb + 3*tambStd),
                                        tamb = tamb,
                                        tambStd = tambStd,
                                        tlim = .tlim,
@@ -647,8 +644,8 @@ compHDDCDDFactors <- function(tlow, tup, tlim, tambStd = 5, tlimStd = 5) {
                         f <- integral2(coolingFactor,
                                        xmin = x1,
                                        xmax = x2,
-                                       ymin = function(x) {x}, #nolint
-                                       ymax = y2,
+                                       ymin = max(.tlim, tamb - 3*tambStd),
+                                       ymax = tamb + 3*tambStd,
                                        tamb = tamb,
                                        tambStd = tambStd,
                                        tlim = .tlim,
@@ -657,7 +654,7 @@ compHDDCDDFactors <- function(tlow, tup, tlim, tambStd = 5, tlimStd = 5) {
                       }
                       tmp <- data.frame("T_amb"        = tamb,
                                         "T_amb_K"      = round(tamb + 273.15, 1),
-                                        "tLim"        = .tlim,
+                                        "tLim"         = .tlim,
                                         "factor"       = f$Q,
                                         "factor_err"   = f$error,
                                         "typeDD"       = typeDD)

R/calcPFUDB.R

@@ -13,7 +13,6 @@
 #' @importFrom quitte aggregate_map as.quitte factor.data.frame revalue.levels
 #' @importFrom dplyr %>% .data filter group_by summarise mutate ungroup select
 #'   all_of any_of pull
-#'
 #' @export
 
 calcPFUDB <- function() {
@@ -43,6 +42,32 @@ calcPFUDB <- function() {
     }
   }
 
+  # convert enduse "appliances" to "refrigerators" with respective scaling factor
+  addThermal <- function(df, mapping, fridgeShare, feOnly) {
+    df <- df %>%
+      filter(.data[["enduse"]] != "lighting") %>%
+      left_join(regmappingEDGE %>%
+                  select(-"RegionCodeEUR", -"RegionCodeEUR_ETP", -"X") %>%
+                  rename(region = "CountryCode") %>%
+                  left_join(fridgeShare, by = "RegionCode") %>%
+                  select(-"RegionCode"),
+                by = "region") %>%
+      mutate(value = ifelse(.data[["enduse"]] != "appliances",
+                            .data[["value"]],
+                            .data[["value"]] * .data[["share"]]),
+             enduse = ifelse(.data[["enduse"]] == "appliances",
+                             "refrigerators",
+                             as.character(.data[["enduse"]]))) %>%
+      select(-"share")
+
+    if (!feOnly) {
+      df <- normalize(df, shareOf)
+      return(df)
+    }
+
+    return(df)
+  }
+
 
 
   # PARAMETERS -----------------------------------------------------------------
@@ -56,10 +81,13 @@ calcPFUDB <- function() {
   exclude <- toolGetMapping("excludeEnduseCarrier.csv", "sectoral",
                             "mredgebuildings")
 
-  # fridge share of europe
-  fridgeShare <- 0.17
+  # fridge electricity shares (see calcShares)
+  fridgeShare <- rbind(
+    data.frame(RegionCode = "USA", share  = 0.12),
+    data.frame(RegionCode = c("EUR", "OCD", "RUS", "JPN"), share = 0.17),
+    data.frame(RegionCode = c("CHN", "IND", "NCD", "AFR", "MIE", "OAS"), share = 0.3))
 
-  # lower temporal boundary of historic data
+  # lower temporal threshold of historical data
   periodBegin <- 1990
 
 
@@ -114,6 +142,11 @@ calcPFUDB <- function() {
                                   type  = "sectoral",
                                   where = "mredgebuildings")
 
+  # EDGE mapping
+  regmappingEDGE <- toolGetMapping(name  = "regionmappingEDGE.csv",
+                                   type  = "regional",
+                                   where = "mredgebuildings")
+
 
 
   # PROCESS DATA ---------------------------------------------------------------
@@ -144,14 +177,6 @@ calcPFUDB <- function() {
 
   ## Prepare toolDisaggregate Input ====
 
-  # merge existing disaggregated FE data
-  feDisagg <- feOdyssee %>%
-    left_join(feIEAEEI, by = c("region", "period", "carrier", "enduse")) %>%
-    mutate(value = ifelse(is.na(.data[["value.x"]]),
-                          .data[["value.y"]],
-                          .data[["value.x"]])) %>%
-    select("region", "period", "carrier", "enduse", "value")
-
   # calculate enduse-carrier shares for IEA EEI data
   sharesIEAEEI <- feIEAEEI %>%
     group_by(across(all_of(c("region", "period")))) %>%
@@ -171,19 +196,22 @@ calcPFUDB <- function() {
 
   # correct fridgeShare
   sharesReplace <- sharesReplace %>%
-    filter(.data[["enduse"]] != "lighting") %>%
-    mutate(value = .data[["value"]] * ifelse(.data[["enduse"]] != "appliances",
-                                             1, fridgeShare),
-           enduse = ifelse(.data[["enduse"]] == "appliances",
-                           "refrigerators",
-                           as.character(.data[["enduse"]])))
+    addThermal(regmappingEDGE, fridgeShare, feOnly = TRUE)
+
+  feDisagg <- feOdyssee %>%
+    left_join(feIEAEEI,
+              by = c("region", "period", "carrier", "enduse")) %>%
+    mutate(value = ifelse(is.na(.data[["value.x"]]),
+                          .data[["value.y"]],
+                          .data[["value.x"]])) %>%
+    addThermal(regmappingEDGE, fridgeShare, feOnly = TRUE) %>%
+    select("region", "period", "carrier", "enduse", "value")
 
 
   # Extract regions with existing disaggregated FE shares
   replaceRegs <- sharesReplace %>%
     filter(!is.na(.data[["value"]])) %>%
     pull("region") %>%
-    droplevels() %>%
     unique()
 
   # re-aggregate Odyssee shares to carrier level
@@ -239,12 +267,13 @@ calcPFUDB <- function() {
   pfuThermFE <- pfu %>%
     filter(.data[["enduse"]] == "Low-T heat",
            !(.data[["region"]] %in% replaceRegs),
-           .data[["unit"]] == "fe") %>%
+           unit == "fe") %>%
     select(-"enduse") %>%
-    toolDisaggregate(sharesEU,
-                     exclude,
-                     feDisagg,
-                     regmapping) %>%
+    toolDisaggregate(enduseShares  = sharesEU,
+                     outliers      = c("IND", "CHN", "ZAF"),
+                     exclude       = exclude,
+                     dataDisagg    = feDisagg,
+                     regionMapping = regmapping) %>%
     select(colnames(pfuNonTherm))
 
   # Use carrier-enduse distribution to apply on useful energy

R/calcShareETP.R

@@ -26,7 +26,6 @@
 #' @export
 
 calcShareETP <- function(subtype = c("enduse", "carrier"), feOnly = FALSE) {
-
   # FUNCTIONS ------------------------------------------------------------------
 
   # Calculate Shares
@@ -239,3 +238,4 @@ calcShareETP <- function(subtype = c("enduse", "carrier"), feOnly = FALSE) {
               max = 1,
               description = "Share of carrier or end use in buildings demand"))
 }
+

R/calcShares.R

@@ -210,44 +210,6 @@ calcShares <- function(subtype = c("carrier_nonthermal",
   }
 
 
-  extrapolateMissingPeriods <- function(chunk, key, slopeOfLast = 5) {
-    # remove NAs
-    outChunk <- chunk
-    chunk <- chunk[!is.na(chunk$value), ]
-    upperPeriod <- max(chunk$period)
-    lowerPeriod <- min(chunk$period)
-
-    # linear regression at upper and lower end
-    mUpper <- lm(value ~ period, tail(arrange(chunk, "period"), slopeOfLast))
-    mLower <- lm(value ~ period, head(arrange(chunk, "period"), slopeOfLast))
-
-    # extrapolate both ends
-    outChunk[["valueUpper"]] <- predict(mUpper, newdata = outChunk["period"])
-    outChunk[["valueLower"]] <- predict(mLower, newdata = outChunk["period"])
-
-    # shift extrapolation to match last data points
-    outChunk[["valueUpper"]] <- outChunk[["valueUpper"]] *
-      as.numeric(outChunk[outChunk$period == upperPeriod, "value"] /
-                   outChunk[outChunk$period == upperPeriod, "valueUpper"])
-    outChunk[["valueLower"]] <- outChunk[["valueLower"]] *
-      as.numeric(outChunk[outChunk$period == lowerPeriod, "value"] /
-                   outChunk[outChunk$period == lowerPeriod, "valueLower"])
-
-    # fill missing lower/upper ends
-    outChunk[["value"]] <- ifelse(outChunk[["period"]] > max(chunk$period),
-                                  outChunk[["valueUpper"]],
-                                  outChunk[["value"]])
-    outChunk[["value"]] <- ifelse(outChunk[["period"]] < min(chunk$period),
-                                  outChunk[["valueLower"]],
-                                  outChunk[["value"]])
-    outChunk[["valueUpper"]] <- NULL
-    outChunk[["valueLower"]] <- NULL
-
-    return(outChunk)
-  }
-
-
-
   # PROCESS DATA ---------------------------------------------------------------
 
   # Adjust ETP Mapping
@@ -290,18 +252,17 @@ calcShares <- function(subtype = c("carrier_nonthermal",
                     rename(region = "CountryCode",
                            regionAgg = "EEAReg"),
                   by = "region") %>%
+        select("region", "period", "enduse", "regionAgg", "value") %>%
         group_by(across(all_of(c("regionAgg", "enduse", "period")))) %>%
-        summarise(value = sum(.data[["value"]], na.rm = TRUE)) %>%
-        ungroup() %>%
+        reframe(value = sum(.data[["value"]], na.rm = TRUE)) %>%
         group_by(across(all_of(c("regionAgg", "enduse")))) %>%
-        summarise(factor = .data[["value"]] / dplyr::lead(.data[["value"]])) %>%
-        ungroup() %>%
+        reframe(factor = .data[["value"]] / dplyr::lead(.data[["value"]])) %>%
         filter(!is.na(.data[["factor"]])) %>%
         left_join(regmappingETP %>%
                     select("CountryCode", "EEAReg") %>%
                     rename(region = "CountryCode",
                            regionAgg = "EEAReg"),
-                  by = "regionAgg") %>%
+                  by = "regionAgg", relationship = "many-to-many") %>%
         select(-"regionAgg")
 
 
@@ -314,16 +275,16 @@ calcShares <- function(subtype = c("carrier_nonthermal",
 
 
       sharesFull <- rbind(sharesStart,
-                          shares %>%
-                            filter(!is.na(.data[["value"]])))
+                           shares %>%
+                             filter(!is.na(.data[["value"]])))
 
 
       sharesFull <- sharesFull %>%
         factor.data.frame() %>%
         as.quitte() %>%
         interpolate_missing_periods(period = seq(1990, 2020)) %>%
         group_by(across(all_of(c("region", "enduse")))) %>%
-        group_modify(extrapolateMissingPeriods) %>%
+        group_modify(~ extrapolateMissingPeriods(.x, key = "value")) %>%
         ungroup() %>%
         select("region", "period", "enduse", "value")
 
@@ -388,7 +349,7 @@ calcShares <- function(subtype = c("carrier_nonthermal",
         as.quitte() %>%
         interpolate_missing_periods(period = seq(1990, 2020)) %>%
         group_by(across(all_of(c("region", "enduse")))) %>%
-        group_modify(extrapolateMissingPeriods) %>%
+        group_modify(~ extrapolateMissingPeriods(.x, key = "value")) %>%
         ungroup() %>%
         select("region", "period", "enduse", "value")