Merge pull request #40 from robinhasse/fixedgeInput

Bugfix: End use share calculation

.buildlibrary

@@ -1,4 +1,4 @@
-ValidationKey: '1459854'
+ValidationKey: '1480518'
 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: 'mredgebuildings: Prepare data to be used by the EDGE-Buildings model'
-version: 0.7.3
-date-released: '2024-10-02'
+version: 0.7.4
+date-released: '2024-10-11'
 abstract: Prepare data to be used by the EDGE-Buildings model.
 authors:
 - family-names: Hasse

DESCRIPTION

@@ -1,8 +1,8 @@
 Type: Package
 Package: mredgebuildings
 Title: Prepare data to be used by the EDGE-Buildings model
-Version: 0.7.3
-Date: 2024-10-02
+Version: 0.7.4
+Date: 2024-10-11
 Authors@R: c(
     person("Robin", "Hasse", , "robin.hasse@pik-potsdam.de", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0003-1818-3186")),

NAMESPACE

@@ -24,6 +24,8 @@ export(calcRenovationCostModel)
 export(calcShareETP)
 export(calcShareOdyssee)
 export(calcShareTCEP)
+export(calcShareWEO)
+export(calcShares)
 export(calcSharesBuildingDemand)
 export(calcSurface)
 export(calcTCEP)
@@ -95,6 +97,7 @@ importFrom(dplyr,group_by)
 importFrom(dplyr,group_modify)
 importFrom(dplyr,inner_join)
 importFrom(dplyr,last_col)
+importFrom(dplyr,lead)
 importFrom(dplyr,left_join)
 importFrom(dplyr,matches)
 importFrom(dplyr,mutate)

R/calcFEbyEUEC.R

@@ -134,66 +134,33 @@ calcFEbyEUEC <- function() {
   # existing disaggregated data replaces values from optimization
   data <- ieaIODis %>%
     left_join(dataReplaceFull, by = c("region", "period", "carrier", "enduse")) %>%
-    group_by(across(all_of(c("region", "period", "carrier")))) %>%
     mutate(valueUncorrected = ifelse(is.na(.data[["replaceValue"]]),
                                      .data[["value"]],
-                                     .data[["replaceValue"]]),
-           value = .data[["valueUncorrected"]] * .data[["value"]] / sum(.data[["value"]])) %>%
+                                     .data[["replaceValue"]])) %>%
+    group_by(across(all_of(c("region", "period", "carrier")))) %>%
+    mutate(value = ifelse(.data[["valueUncorrected"]] == 0,
+                          0,
+                          sum(.data[["value"]]) * proportions(.data[["valueUncorrected"]]))) %>%
+    ungroup() %>%
     select(-"valueUncorrected") %>%
     select("region", "period", "unit", "carrier", "enduse", "value")
 
 
   # CORRECTIONS ----------------------------------------------------------------
 
-  # 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
-
-  elecSpaceCoolingShare <- sharesEU %>%
-    filter(.data[["region"]] == "Africa",
-           .data[["enduse"]] == "space_cooling") %>%
-    select("period", "value") %>%
-    rename("share" = "value")
+  # Since the data on district cooling is very sparse and the technology
+  # exhibits a low global penetration rate, we assume that all historic cooling
+  # demand is covered by # electricity but assume that district cooling might
+  # play a more significant role in the future.
 
   dataCorr <- data %>%
-    left_join(regmapping, by = c("region")) %>%
-    filter(.data[["regionAgg"]] == "Africa") %>%
-    left_join(elecSpaceCoolingShare, by = c("period")) %>%
-    select(-"regionAgg") %>%
-    group_by(across(-all_of(c("enduse", "carrier", "share", "value")))) %>%
-    mutate(value = ifelse(.data[["enduse"]] == "space_cooling",
-                          ifelse(.data[["carrier"]] == "elec",
-                                 sum(.data[["value"]], na.rm = TRUE) * .data[["share"]],
-                                 0),
-                          .data[["value"]] * (1 - .data[["share"]])),
-           value = .data[["value"]] * ifelse(.data[["enduse"]] == "space_cooling",
-                                             1,
-                                             .data[["share"]] * sum(.data[["value"]]) /
-                                               sum(.data[["value"]][.data[["enduse"]] == "space_cooling"]))) %>%
-    ungroup() %>%
-    select(-"share")
-
-  dataFull <- rbind(dataCorr,
-                    data %>%
-                      left_join(regmapping, by = c("region")) %>%
-                      filter(.data[["regionAgg"]] != "Africa") %>%
-                      select(-"regionAgg"))
-
-
-  # Since the data on district cooling is very sparse and the low global penetration
-  # of the technology, we assume that all historic cooling demand is covered by
-  # electricity but assume that district cooling might play a more significant role
-  # in the future.
-
-  dataCorr <- dataFull %>%
     select(-"enduse", -"carrier", -"value") %>%
     unique() %>%
     mutate(enduse = "space_cooling",
            carrier = "heat",
            value = 0)
 
-  dataFull <- rbind(dataCorr, dataFull)
+  dataFull <- rbind(dataCorr, data)
 
 
 
@@ -205,7 +172,7 @@ calcFEbyEUEC <- function() {
     mutate(scenario = "history") %>%
     as.quitte() %>%
     as.magpie() %>%
-    toolCountryFill(1, verbosity = 2)
+    toolCountryFill(0, verbosity = 2)
 
 
   return(list(x = dataFull,

R/calcGDPPop.R

@@ -9,7 +9,8 @@ calcGDPPop <- function() {
 
   # LOAD DATA ------------------------------------------------------------------
 
-  gdp <- calcOutput("GDP", aggregate = FALSE, average2020 = FALSE) %>%
+  gdp <- calcOutput("GDP", aggregate = FALSE, average2020 = FALSE,
+                    unit = "constant 2005 Int$PPP") %>%
     mselect(variable = "gdp_SSP2") %>%
     as.quitte()
 

R/calcShareWEO.R

@@ -0,0 +1,23 @@
+#' Calculate end use shares from WEO 2015
+#'
+#' Table 10.2 in the WEO 2015 report lists the chare of regional enduses in the
+#' global final energy demand. Here, we calculate the share of enduses in the
+#' final energ demand for buildings in each region.
+#'
+#' @author Robin Hasse
+#'
+#' @importFrom madrat readSource
+#' @importFrom magclass dimSums
+#' @export
+
+calcShareWEO <- function() {
+  weo <- readSource("WEO", subtype = "Buildings", convert = FALSE)
+  shares <- weo / dimSums(weo)
+
+  return(list(x = shares,
+              min = 0,
+              max = 1,
+              unit = "1",
+              isocountries = FALSE,
+              description = "regional end use shares in buildings final energy demand"))
+}

R/calcShares.R

@@ -18,7 +18,7 @@
 #' Hence, this case is by default disabled.
 #'
 #' In the thermal case, the enduse "appliances" is transformed to "refrigerators"
-#' using the region-specific refrigerator share used in EDGE-B. Higher-resoluted
+#' using the region-specific refrigerator share used in EDGE-B. Higher resolved
 #' data was not available.
 #'
 #' @param subtype specifies share
@@ -37,14 +37,13 @@
 #'
 #' @author Hagen Tockhorn, Robin Hasse
 #'
-#' @importFrom dplyr mutate as_tibble filter select rename group_by across
-#'   all_of ungroup %>% .data left_join reframe group_modify cross_join .data
+#' @importFrom dplyr mutate as_tibble filter select rename group_by across lead
+#'   all_of ungroup %>% .data left_join reframe cross_join .data
 #' @importFrom tidyr replace_na unite complete
 #' @importFrom madrat toolGetMapping calcOutput readSource toolCountryFill
-#' @importFrom magclass time_interpolate as.magpie
-#' @importFrom quitte inline.data.frame as.quitte factor.data.frame
-#'   interpolate_missing_periods
-
+#' @importFrom magclass time_interpolate as.magpie dimSums getItems
+#' @importFrom quitte  as.quitte interpolate_missing_periods
+#' @export
 
 calcShares <- function(subtype = c("carrier_nonthermal",
                                    "carrier_thermal",
@@ -85,7 +84,7 @@ calcShares <- function(subtype = c("carrier_nonthermal",
     as.quitte()
 
   # WEO
-  sharesWEO <- readSource("WEO", subtype = "Buildings") %>%
+  sharesWEO <- calcOutput("ShareWEO", aggregate = FALSE) %>%
     as.quitte()
 
   if (shareOf == "enduse") {
@@ -104,7 +103,7 @@ calcShares <- function(subtype = c("carrier_nonthermal",
 
   if (shareOf == "enduse") {
     # TCEP
-    dataTCEP <- readSource("TCEP") %>%
+    feTCEP <- readSource("TCEP") %>%
       as.quitte()
   }
 
@@ -153,6 +152,29 @@ calcShares <- function(subtype = c("carrier_nonthermal",
       ungroup()
   }
 
+  getGrowth <- function(df, regmap, regionAgg = "EEAReg") {
+    regmap <- regmap %>%
+      select(region = "CountryCode", regionAgg = !!regionAgg)
+    df %>%
+      left_join(regmap, by = "region") %>%
+      select("region", "period", "enduse", "regionAgg", "value") %>%
+      group_by(across(all_of(c("regionAgg", "enduse", "period")))) %>%
+      reframe(value = sum(.data[["value"]], na.rm = TRUE)) %>%
+      group_by(across(all_of(c("regionAgg", "enduse")))) %>%
+      reframe(growth = (lead(.data[["value"]]) /
+                          .data[["value"]])^(1 / c(diff(.data[["period"]]), NA))) %>%
+      filter(!is.na(.data[["growth"]])) %>%
+      left_join(regmap, by = "regionAgg", relationship = "many-to-many") %>%
+      select(-"regionAgg")
+  }
+
+  extrapolateGrowth <- function(df, growth, periods = 1990:2020) {
+    df %>%
+      left_join(growth, by = c("region", "enduse")) %>%
+      group_by(across(all_of(c("region", "enduse")))) %>%
+      reframe(value = .data[["value"]] * .data[["growth"]]^(periods - .data[["period"]]),
+              period = periods)
+  }
 
 
   # PROCESS DATA ---------------------------------------------------------------
@@ -191,56 +213,9 @@ calcShares <- function(subtype = c("carrier_nonthermal",
 
     if (isFALSE(feOnly)) {
       # Extrapolate ETP FE Data
-      evolutionFactor <- sharesTCEP %>%
-        left_join(regmappingETP %>%
-                    select("CountryCode", "EEAReg") %>%
-                    rename(region = "CountryCode",
-                           regionAgg = "EEAReg"),
-                  by = "region") %>%
-        select("region", "period", "enduse", "regionAgg", "value") %>%
-        group_by(across(all_of(c("regionAgg", "enduse", "period")))) %>%
-        reframe(value = sum(.data[["value"]], na.rm = TRUE)) %>%
-        group_by(across(all_of(c("regionAgg", "enduse")))) %>%
-        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", relationship = "many-to-many") %>%
-        select(-"regionAgg")
-
-
-      sharesStart <- shares %>%
-        left_join(evolutionFactor, by = c("region", "enduse")) %>%
-        mutate(value = .data[["value"]] * .data[["factor"]],
-               period = 2000) %>%
-        select(-"factor") %>%
-        filter(!is.na(.data[["value"]]))
-
-
-      sharesFull <- rbind(sharesStart,
-                          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(.x, key = "value")) %>%
-        ungroup() %>%
-        select("region", "period", "enduse", "value")
-
-
-      # NOTE: The linear regression might lead to negative values which will be
-      # filled up with zeros and then re-normalized.
-      # (However, this is a very practical fix...)
-
-      sharesFull <- sharesFull %>%
-        mutate(value = ifelse(.data[["value"]] < 0, 1e-6, .data[["value"]]))
-
+      evolutionFactor <- getGrowth(sharesTCEP, regmappingETP)
+      sharesFull <- extrapolateGrowth(shares, evolutionFactor) %>%
+        normalize(shareOf)
 
       # Merge Data
       data <- sharesOdyssee %>%
@@ -256,60 +231,13 @@ calcShares <- function(subtype = c("carrier_nonthermal",
     # Calculate FE Data
 
     # Extrapolate ETP FE Data
-    evolutionFactor <- dataTCEP %>%
-      left_join(regmappingETP %>%
-                  select("CountryCode", "EEAReg") %>%
-                  rename(region = "CountryCode",
-                         regionAgg = "EEAReg"),
-                by = "region") %>%
-      group_by(across(all_of(c("regionAgg", "enduse", "period")))) %>%
-      reframe(value = sum(.data[["value"]], na.rm = TRUE)) %>%
-      group_by(across(all_of(c("regionAgg", "enduse")))) %>%
-      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") %>%
-      select(-"regionAgg")
-
-
-    dataETPstart <- feETP %>%
-      left_join(evolutionFactor, by = c("region", "enduse")) %>%
-      mutate(value = .data[["value"]] * .data[["factor"]],
-             period = 2000) %>%
-      select(-"factor") %>%
-      filter(!is.na(.data[["value"]]))
-
-
-    dataETPfull <- rbind(dataETPstart,
-                         feETP %>%
-                           filter(!is.na(.data[["value"]])))
-
-
-    dataETPfull <- dataETPfull %>%
-      select(-"unit") %>%
-      quitte::factor.data.frame() %>%
-      as.quitte() %>%
-      interpolate_missing_periods(period = seq(1990, 2020)) %>%
-      group_by(across(all_of(c("region", "enduse")))) %>%
-      group_modify(~ extrapolateMissingPeriods(.x, key = "value")) %>%
-      ungroup() %>%
-      select("region", "period", "enduse", "value")
-
-
-    # NOTE: The linear regression might lead to negative values which will be
-    # filled up with small values and then re-normalized.
-    # (However, this is a very practical fix...)
-
-    dataETPfull <- dataETPfull %>%
-      mutate(value = ifelse(.data[["value"]] < 0, 1e-6, .data[["value"]]))
+    evolutionFactor <- getGrowth(feTCEP, regmappingETP)
+    feETPfull <- extrapolateGrowth(feETP, evolutionFactor)
 
     if (feOnly) {
-      data  <- dataETPfull
+      data  <- feETPfull
     } else {
-      regFE <- dataETPfull %>%
+      regFE <- feETPfull %>%
         mutate(value = replace_na(.data[["value"]], 0))
     }
   }
@@ -442,13 +370,12 @@ calcShares <- function(subtype = c("carrier_nonthermal",
 
     description <- "Final energy demand of carrier or end use in buildings"
   } else {
-    regFE <- regFE %>%
+    weight <- regFE %>%
+      as.quitte() %>%
       as.magpie() %>%
-      collapseDim() %>%
+      dimSums() %>%
       time_interpolate(getItems(data, 2)) %>%
       toolCountryFill(1, verbosity = 2)
-
-    weight <- regFE
     unit   <- "1"
     max    <- 1
 

R/calcTCEP.R

@@ -6,8 +6,12 @@
 #' @importFrom madrat readSource
 #' @export
 
-calcTCEP <- function(subtype) {
-  return(list(x = readSource("TCEP", subtype, convert = FALSE),
+calcTCEP <- function(subtype = "enduse") {
+  x <- switch(subtype,
+    enduse = readSource("TCEP", "enduse", convert = FALSE),
+    floorspace = readSource("TCEP", "floorspace", convert = FALSE)
+  )
+  return(list(x = x,
               min = 0,
               isocountries = FALSE,
               unit = "m2/cap",