Merge pull request #27 from johannah-pik/AdjustReporting

Adjust reporting

.buildlibrary

@@ -1,8 +1,9 @@
-ValidationKey: '1019439'
+ValidationKey: '1201560'
 AutocreateReadme: yes
 AcceptedWarnings:
 - 'Warning: package ''.*'' was built under R version'
 - 'Warning: namespace ''.*'' is not available and has been replaced'
 AcceptedNotes: 'Undefined global functions or variables:'
 allowLinterWarnings: yes
 enforceVersionUpdate: no
+skipCoverage: no

.github/workflows/check.yaml

@@ -23,14 +23,14 @@ jobs:
       - uses: r-lib/actions/setup-r-dependencies@v2
         with:
           extra-packages: |
-            any::lucode2
-            any::covr
-            any::madrat
-            any::magclass
-            any::citation
-            any::gms
-            any::goxygen
-            any::GDPuc
+            lucode2
+            covr
+            madrat
+            magclass
+            citation
+            gms
+            goxygen
+            GDPuc
           # piam packages also available on CRAN (madrat, magclass, citation,
           # gms, goxygen, GDPuc) will usually have an outdated binary version
           # available; by using extra-packages we get the newest version
@@ -63,6 +63,6 @@ jobs:
         shell: Rscript {0}
         run: |
           nonDummyTests <- setdiff(list.files("./tests/testthat/"), c("test-dummy.R", "_snaps"))
-          if(length(nonDummyTests) > 0) covr::codecov(quiet = FALSE)
+          if(length(nonDummyTests) > 0 && !lucode2:::loadBuildLibraryConfig()[["skipCoverage"]]) covr::codecov(quiet = FALSE)
         env:
           NOT_CRAN: "true"

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: 'reporttransport: Reporting package for edgeTransport'
-version: 0.5.1
-date-released: '2024-09-23'
+version: 0.6.0
+date-released: '2024-10-30'
 abstract: This package contains edgeTransport-specific routines to report model results.
   The main functionality is to generate transport reporting variables in MIF format
   from a given edgeTransport model run folder or REMIND input data.

DESCRIPTION

@@ -1,8 +1,8 @@
 Type: Package
 Package: reporttransport
 Title: Reporting package for edgeTransport
-Version: 0.5.1
-Date: 2024-09-23
+Version: 0.6.0
+Date: 2024-10-30
 Authors@R:
     person("Johanna", "Hoppe", , "[email protected]", role = c("aut", "cre"))
 Description: This package contains edgeTransport-specific routines to

R/aggregateVariables.R

@@ -75,6 +75,7 @@ aggregateVariables <- function(vars, mapAggregation, weight = NULL) {
   # Test for duplicated entries to prevent double counting in the aggregation
   test <- copy(vars)
   test[, value := NULL]
+
   if (anyDuplicated(test)) stop("Variables for aggregation contain duplicates.
                                 Check reportEdgeTransport() to prevent double counting")
 
@@ -96,6 +97,14 @@ aggregateVariables <- function(vars, mapAggregation, weight = NULL) {
     setnames(weight, "value", "weight")
   }
 
+  # Exclude vars that are not aggregated and create solely the variable entry
+  exclude <- c("Load factor", "Load factor raw", "Preference|FV", "Preference|S1S", "Preference|S2S1",
+               "Preference|S3S2", "Preference|VS3", "TCO sales Operating costs (total non-fuel)", "TCO sales Fuel costs", "TCO sales Capital costs", "Time value costs",
+               "Annual mileage", "Energy intensity sales", "Energy intensity (raw)", "Purchase Price", "Load factor (raw)")
+
+  aggregatedvars <- createVariableEntry(vars[variable %in% exclude | grepl(".*Iteration.*", variable)], aggrOrder)
+  vars <- vars[!(variable %in% exclude | grepl(".*Iteration.*", variable))]
+
   # Aggregate each level of the decision tree --------------------------------------------------------------------
   for (i in seq(0, length(aggrOrder) - 1)) {
     aggrvars <- copy(vars)
@@ -135,7 +144,7 @@ aggregateVariables <- function(vars, mapAggregation, weight = NULL) {
     }
   }
 
-  exclude <- c("Sales", "Vintages", "Stock", "Load factor")
+  exclude <- c("Sales", "Vintages", "Stock")
   varsForFurtherAggregation <- vars[!variable %in% exclude]
 
   # Aggregate Pass with bunkers --------------------------------------------------------------------
@@ -283,8 +292,8 @@ aggregateVariables <- function(vars, mapAggregation, weight = NULL) {
   aggregatedvars <- rbind(aggregatedvars, aggrvars)
 
   if (anyNA(aggregatedvars)) stop("Output variable contains NAs.
-                                  Please check reportAndAggregatedMIF()")
+                                  Please check aggregateVariables()")
   if (anyDuplicated(aggregatedvars[, c("region", "period", "variable")])) stop("Output variable contains Duplicates.
-                                         Please check reportAndAggregatedMIF()")
+                                         Please check aggregateVariables()")
   return(aggregatedvars)
 }

R/convertToMIF.R

@@ -22,13 +22,15 @@ convertToMIF <- function(vars, GDPMER, helpers, scenario, model, gdx,  isTranspo
   applyReportingNames <- function(vars, mapNames) {
 
     rename <- function(columns, mapNames) {
+
       dt <- data.table(name = c(columns))
       dt[, rownum := .I]
       dt <- merge(dt, mapNames, by = "name", allow.cartesian = TRUE, all.x = TRUE)
       # Important to prevent change of row order
       setkey(dt, "rownum")
       dt <- dt[!is.na(reportName), name := reportName]
       dt[grepl(".*tmp", name), name := NA]
+      dt[name == "", name := NA]
       dt[!is.na(name), name := paste0("|", name)]
 
       return(dt$name)
@@ -45,42 +47,46 @@ convertToMIF <- function(vars, GDPMER, helpers, scenario, model, gdx,  isTranspo
     return(varsNew)
   }
 
-  # Use ES demand as weight to aggregate over modes-------------------------------------------
-  varsToMIFext <- vars$ext[!names(vars$ext) %in% c("GDPppp", "population")]
-  noAggregationvars <- vars$ext[c("GDPppp","population")]
-  varsToMIFext <- rbindlist(varsToMIFext, fill = TRUE, use.names = TRUE)
-  varsToMIFint <- rbindlist(vars$int, fill = TRUE, use.names = TRUE)
-
-  # Prepare vars that are not aggregated over modes
-  if (!is.null(noAggregationvars$GDPppp)){
-    noAggregationvars$GDPppp[, variable := "GDP|PPP"][, value := value * 1e-3][, unit := "billion constant 2017 Int$PPP"]
-    noAggregationvars$population[, variable := "Population"][, unit := "million"]
-    noAggregationvars <- rbindlist(noAggregationvars, fill = TRUE, use.names = TRUE)
-  }
-
-  # Apply variable naming convention----------------------------------------------------------
-  varsToMIFext <- applyReportingNames(varsToMIFext, helpers$reportingNames)
-  varsToMIFint[, fuel := NA]
-  varsToMIFint <- applyReportingNames(varsToMIFint, helpers$reportingNames)
+  noAggregationvars <- rbindlist(vars$int[c("GDPpcPPP", "GDPpcMER")], fill = TRUE, use.names = TRUE)
+  varsToMIFint <- rbindlist(vars$int[!names(vars$int) %in% c("GDPpcPPP", "GDPpcMER")], fill = TRUE, use.names = TRUE)
+  varsToMIFext <- rbindlist(vars$ext[!names(vars$ext) %in% c("GDPppp", "population", "GDPMER")], fill = TRUE, use.names = TRUE)
 
   # Regional aggregation----------------------------------------------------------------------
   ## Aggregation to world is always supplied
-  mapWorld <- unique(varsToMIFext[, c("region")])[, aggrReg := "World"]
-  worldDataExt <- as.data.table(aggregate_map(varsToMIFext, mapWorld, by = "region"))
-  if (!is.null(noAggregationvars$GDPppp)) worldDatanoAggregationvars <- as.data.table(aggregate_map(noAggregationvars, mapWorld, by = "region"))
-  weight <- copy(varsToMIFext[variable == "ES"])
-  weight[, c("variable", "unit", "fuel") := NULL]
+  mapWorld <- unique(vars$ext[[1]][, c("region")])[, aggrReg := "World"]
+  worldDataExt <- lapply(vars$ext, function(x, mapWorld) as.data.table(aggregate_map(x, mapWorld, by = "region")), mapWorld)
+
+  weight <- copy(vars$ext$fleetESdemand)
+  weight[, c("variable", "unit") := NULL]
   setnames(weight, "value", "weight")
-  weightedInt <- merge(weight,varsToMIFint, by = intersect(names(varsToMIFint), names(weight)), all.x = TRUE)
-  byCols <- names(weightedInt)
-  byCols <- byCols[!byCols %in% c("region", "value", "weight")]
-  weightedInt[, sum := sum(weight), by = eval(byCols)]
-  weightedInt[sum == 0, weight := 1, by = eval(byCols)][, sum := NULL]
-  worldDataInt <- weightedInt[, .(value = sum(value * (weight / sum(weight)))), by = eval(byCols)]
-  worldDataInt[, region := "World"]
-  varsToMIFint <- rbind(varsToMIFint, worldDataInt)
-  varsToMIFext <- rbind(varsToMIFext, worldDataExt)
-  if (!is.null(noAggregationvars$GDPppp)) noAggregationvars <- rbind(noAggregationvars, worldDatanoAggregationvars)
+
+  #split shareweights
+  if (!is.null(vars$int$scenScpecPrefTrends)) {
+    Preferences <- list(
+      PrefrenceFV = vars$int$scenScpecPrefTrends[variable == "Preference|FV"],
+      PrefrenceS1S = vars$int$scenScpecPrefTrends[variable == "Preference|S1S"],
+      PrefrenceS2S1 = vars$int$scenScpecPrefTrends[variable == "Preference|S2S1"],
+      PrefrenceS3S2 = vars$int$scenScpecPrefTrends[variable == "Preference|S3S2"],
+      PrefrenceVS3 = vars$int$scenScpecPrefTrends[variable == "Preference|VS3"]
+    )
+    vars$int <- vars$int[!names(vars$int) == "scenScpecPrefTrends"]
+    vars$int <- append(vars$int, Preferences)
+  }
+
+  worldDataInt <- lapply(vars$int, function(x, weight) {
+    byCols <- names(x)
+    #sharweights include empty columns
+    emptyColumns <- names(x)[sapply(x, function(x) all(is.na(x) | x == ""))]
+    byCols <- byCols[!byCols %in% c("value") & byCols %in% names(weight) & !byCols %in% emptyColumns]
+    weight <- weight[, .(weight = sum(weight)), by = eval(byCols)]
+    weightedInt <- merge(x, weight, by = intersect(names(x), names(weight)), all.x = TRUE)
+    byCols <- names(weightedInt)
+    byCols <- byCols[!byCols %in% c("region", "value", "weight")]
+    weightedInt[, sum := sum(weight), by = eval(byCols)]
+    weightedInt[sum == 0, weight := 1, by = eval(byCols)][, sum := NULL]
+    worldDataInt <- weightedInt[, .(value = sum(value * (weight / sum(weight)))), by = eval(byCols)]
+    worldDataInt[, region := "World"]
+    return(worldDataInt)}, weight)
 
   ## Additional regions
   ## if regionSubsetList != NULL -> gdx provides 21 region resolution
@@ -99,33 +105,52 @@ convertToMIF <- function(vars, GDPMER, helpers, scenario, model, gdx,  isTranspo
       tmp <- data.table(region = regionSubsetList[[i]], aggrReg = namesReg[i])
       regSubsetMap <- rbind(regSubsetMap, tmp)
     }
-    regSubsetDataExt <- as.data.table(aggregate_map(varsToMIFext[region %in% unique(regSubsetMap$region)],
-                                                 regSubsetMap, by = "region"))
-    if (!is.null(noAggregationvars$GDPppp)) regSubsetDataNoAggregationVars <- as.data.table(aggregate_map(noAggregationvars[region %in% unique(regSubsetMap$region)],
-                                                                  regSubsetMap, by = "region"))
-    weightedInt <- merge(varsToMIFint, regSubsetMap, by = intersect(names(varsToMIFint), names(regSubsetMap)), all.y = TRUE)
-    weightedInt <- merge(weight, weightedInt, by = intersect(names(weightedInt), names(weight)), all.y = TRUE)
-    byCols <- names(weightedInt)
-    byCols <- byCols[!byCols %in% c("region", "value", "weight")]
-    weightedInt[, sum := sum(weight), by = eval(byCols)]
-    weightedInt[sum == 0, weight := 1, by = eval(byCols)][, sum := NULL]
-    regSubsetDataInt <- weightedInt[, .(value = sum(value * (weight / sum(weight)))), by = eval(byCols)]
-    setnames(regSubsetDataInt, "aggrReg", "region")
-
-    regSubsetDataExt <- as.data.table(aggregate_map(varsToMIFext[region %in% unique(regSubsetMap$region)],
-                                                    regSubsetMap, by = "region"))
-
-    varsToMIFint <- rbind(varsToMIFint, regSubsetDataInt)
-    varsToMIFext <- rbind(varsToMIFext, regSubsetDataExt)
-    if (!is.null(noAggregationvars$GDPppp)) noAggregationvars <- rbind(regSubsetDataNoAggregationVars, noAggregationvars)
+    regSubsetDataExt <- lapply(vars$ext, function(x, regSubsetMap) {
+      as.data.table(aggregate_map(x[region %in% unique(regSubsetMap$region)],
+                                                 regSubsetMap, by = "region"))}, regSubsetMap)
+    regSubsetDataInt <- lapply(vars$int, function(x, regSubsetMap, weight) {
+      weightedInt <- merge(x, regSubsetMap, by = intersect(names(x), names(regSubsetMap)), all.y = TRUE)
+      byCols <- names(x)
+      #sharweights include empty columns
+      emptyColumns <- names(x)[sapply(x, function(x) all(is.na(x) | x == ""))]
+      byCols <- byCols[!byCols %in% c("value") & byCols %in% names(weight) & !byCols %in% emptyColumns]
+      weight <- weight[, .(weight = sum(weight)), by = eval(byCols)]
+      weightedInt <- merge(weight, weightedInt, by = intersect(names(weightedInt), names(weight)), all.y = TRUE)
+      byCols <- names(weightedInt)
+      byCols <- byCols[!byCols %in% c("region", "value", "weight")]
+      weightedInt[, sum := sum(weight), by = eval(byCols)]
+      weightedInt[sum == 0, weight := 1, by = eval(byCols)][, sum := NULL]
+      regSubsetDataInt <- weightedInt[, .(value = sum(value * (weight / sum(weight)))), by = eval(byCols)]
+      setnames(regSubsetDataInt, "aggrReg", "region")
+      return(regSubsetDataInt)}, regSubsetMap, weight)
+
+    noAggregationvars <- rbind(noAggregationvars,
+                               rbindlist(regSubsetDataInt[c("GDPpcPPP", "GDPpcMER")], fill = TRUE, use.names = TRUE),
+                               rbindlist(worldDataInt[c("GDPpcPPP", "GDPpcMER")], fill = TRUE, use.names = TRUE),
+                               rbindlist(vars$ext[c("GDPppp", "population", "GDPMER")], fill = TRUE, use.names = TRUE),
+                               rbindlist(regSubsetDataExt[c("GDPppp", "population", "GDPMER")], fill = TRUE, use.names = TRUE),
+                               rbindlist(worldDataExt[c("GDPppp", "population", "GDPMER")], fill = TRUE, use.names = TRUE))
+
+    varsToMIFint <- rbind(varsToMIFint,
+                          rbindlist(regSubsetDataInt[!names(regSubsetDataInt) %in% c("GDPpcPPP", "GDPpcMER")], fill = TRUE, use.names = TRUE),
+                          rbindlist(worldDataInt[!names(worldDataInt) %in% c("GDPpcPPP", "GDPpcMER")], fill = TRUE, use.names = TRUE))
+
+    varsToMIFext <- rbind(varsToMIFext,
+                          rbindlist(regSubsetDataExt[!names(regSubsetDataExt) %in% c("GDPppp", "population", "GDPMER")], fill = TRUE, use.names = TRUE),
+                          rbindlist(worldDataExt[!names(worldDataExt) %in% c("GDPppp", "population", "GDPMER")], fill = TRUE, use.names = TRUE))
   }
 
+  # Apply variable naming convention----------------------------------------------------------
+  varsToMIFext <- applyReportingNames(varsToMIFext, helpers$reportingNames)
+  varsToMIFint[, fuel := NA]
+  varsToMIFint <- applyReportingNames(varsToMIFint, helpers$reportingNames)
+
   # Aggregate variables-----------------------------------------------------------------------
   toMIFext <- aggregateVariables(varsToMIFext, helpers$reportingAggregation)
   weight <- varsToMIFext[variable == "ES"]
   toMIFint <- aggregateVariables(varsToMIFint, helpers$reportingAggregation, weight)
 
-  if (!is.null(noAggregationvars$GDPppp)) {
+  if (!is.null(noAggregationvars)) {
     toMIF <- rbind(toMIFint, toMIFext, noAggregationvars)
   } else {toMIF <- rbind(toMIFint, toMIFext)}
 

R/reportAnalyticsVarSet.R

@@ -13,19 +13,52 @@ reportAnalyticsVarSet <- function(data, timeResReporting) {
   updatedEndogenousCosts <- list()
   policyMask <- list()
   rawEndogenousCost <- list()
+  allCostsFV <- list()
+  allCostsVS3 <- list()
+  allCostsS3S2 <- list()
+  allCostsS2S1 <- list()
+  allCostsS1S <- list()
 
-  for (i in seq_along(data$endogenousCostsIterations)) {
-    updatedEndogenousCosts[[i]] <- data$endogenousCostsIterations[[i]]$updatedEndogenousCosts
-    policyMask[[i]] <- data$endogenousCostsIterations[[i]]$policyMask
-    rawEndogenousCost[[i]] <- data$endogenousCostsIterations[[i]]$rawEndogenousCost
+  endogenousCostsData <- data[names(data)[grepl("endogenousCostsIteration.*", names(data))]]
+  for (i in 1:length(endogenousCostsData)) {
+    updatedEndogenousCosts[[i]] <- endogenousCostsData[[i]]$updatedEndogenousCosts
+    policyMask[[i]] <- endogenousCostsData[[i]]$policyMask
+    rawEndogenousCost[[i]] <- endogenousCostsData[[i]]$rawEndogenousCosts
   }
 
   updatedEndogenousCosts <- rbindlist(updatedEndogenousCosts)
   policyMask <- rbindlist(policyMask)
   rawEndogenousCost <- rbindlist(rawEndogenousCost)
-  fleetVehNumbersIterations <- rbindlist(data$fleetVehNumbersIterations)
+  fleetVehNumbersIterations <- rbindlist(data[names(data)[grepl("fleetVehNumbersIteration[0-9]+", names(data))]])
+  costsDiscreteChoiceData <- data[names(data)[grepl("costsDiscreteChoiceIteration[0-9]+", names(data))]]
+  cols <- names(data$helpers$decisionTree)
+  for (i in 1:length(costsDiscreteChoiceData)) {
+    lapply(costsDiscreteChoiceData[[i]], function(dt, cols){
+      colsdt <- names(dt)
+      missingCols <- cols[!cols %in% intersect(colsdt, cols)]
+      if (!length(missingCols) == 0) dt[, eval(missingCols) := ""]
+    }, cols)
+    allCostsFV[[i]] <- costsDiscreteChoiceData[[i]]$allCostsFV
+    allCostsVS3[[i]] <- costsDiscreteChoiceData[[i]]$allCostsVS3
+    allCostsS3S2[[i]] <- costsDiscreteChoiceData[[i]]$allCostsS3S2
+    allCostsS2S1[[i]] <- costsDiscreteChoiceData[[i]]$allCostsS2S1
+    allCostsS1S[[i]] <- costsDiscreteChoiceData[[i]]$allCostsS1S
+  }
 
-  analyticsData <- list(updatedEndogenousCosts, policyMask, rawEndogenousCost, fleetVehNumbersIterations)
+  allCostsFV <- rbindlist(allCostsFV)
+  allCostsVS3 <- rbindlist(allCostsVS3)
+  allCostsS3S2 <- rbindlist(allCostsS3S2)
+  allCostsS2S1 <- rbindlist(allCostsS2S1)
+  allCostsS1S <- rbindlist(allCostsS1S)
 
+  analyticsData <- list(updatedEndogenousCosts = updatedEndogenousCosts,
+                        policyMask = policyMask,
+                        rawEndogenousCost = rawEndogenousCost,
+                        fleetVehNumbersIterations = fleetVehNumbersIterations,
+                        allCostsFV = allCostsFV,
+                        allCostsVS3 = allCostsVS3,
+                        allCostsS3S2 = allCostsS3S2,
+                        allCostsS2S1 = allCostsS2S1,
+                        allCostsS1S = allCostsS1S)
   return(analyticsData)
 }