changed prediction handling in toolDisaggregate

pik-piam · Jul 27, 2024 · 38131e6 · 38131e6
1 parent 67b5ba2
commit 38131e6
Showing 1 changed file with 15 additions and 15 deletions.
diff --git a/R/toolDisaggregate.R b/R/toolDisaggregate.R
@@ -23,7 +23,7 @@
 #' @param dataDisagg data.frame similar to \code{data} but already disaggregated
 #'   by carriers and end uses. The average distribution of its disaggregation
 #'   will be used as the target distribution for the minisation.
-#' @param regionMapping data.frame with the columns \code{region} and
+#' @param regionmapping data.frame with the columns \code{region} and
 #'   \code{regionAgg} that maps the regions between \code{data} and
 #'   \code{enduseShares}.
 #' @param outliers list of regions where naive disaggregation estimate shall
@@ -314,22 +314,21 @@ toolDisaggregate <- function(data,
   # identity matrix
   identityMatrix <- diag(nrow(variables))
 
-
   # first look for exact solution
   # If there is none, find one that matches end use quantities closely
   for (precision in c("exact", "close")) {
-    # for (precision in c("close")) {
+  # for (precision in c("close")) {
 
     # BUILD MATRICES -----------------------------------------------------------
 
     if (precision == "exact") {
 
-      dMat <- identityMatrix
+      Dmat <- identityMatrix
 
       dvec <- variables %>%
         getElement("estimate")
 
-      aMat <- constraintMatrix %>%
+      Amat <- constraintMatrix %>%
         reduce(full_join, by = c("region", "carrier", "enduse")) %>%
         select(-"region", -"carrier", -"enduse") %>%
         as.matrix()
@@ -347,7 +346,7 @@ toolDisaggregate <- function(data,
         as.matrix()
       objectiveMatrix <- rbind(identityMatrix, weight * t(enduseMatrix))
 
-      dMat <- t(objectiveMatrix) %*% objectiveMatrix
+      Dmat <- t(objectiveMatrix) %*% objectiveMatrix
 
       objectiveRHS <- constraintRHS[["enduse"]] %>%
         getElement("value")
@@ -357,7 +356,7 @@ toolDisaggregate <- function(data,
 
       dvec <- t(objectiveMatrix) %*% objectiveRHS
 
-      aMat <- constraintMatrix[c("carrier", "zero")] %>%
+      Amat <- constraintMatrix[c("carrier", "zero")] %>%
         reduce(full_join, by = c("region", "carrier", "enduse")) %>%
         select(-"region", -"carrier", -"enduse") %>%
         as.matrix()
@@ -383,7 +382,7 @@ toolDisaggregate <- function(data,
     #   deviations from estimate)
     #   subject to matching regional carrier totals with non-negative
     #   disaggregated quantities
-    r <- tryCatch(solve.QP(dMat, dvec, aMat, bvec, meq),
+    r <- tryCatch(solve.QP(Dmat, dvec, Amat, bvec,meq),
                   error = function(e) NULL)
 
     # no need to lower the ambition if a solution is found
@@ -394,22 +393,23 @@ toolDisaggregate <- function(data,
   }
 
 
+
   # RETURN ---------------------------------------------------------------------
 
-  subsetOut <- variables %>%
-    select("region", "carrier", "enduse")
+  subsetOut <- subset %>%
+    select("region", "carrier", "enduse", "value")
 
   if (is.null(r)) {
-    subsetOut[["value"]] <- as.numeric(NA)
+    subsetOut[["pred"]] <- as.numeric(NA)
     subsetOut[["precision"]] <- as.character(NA)
   } else {
-    subsetOut[["value"]] <- r[["solution"]]
+    subsetOut[["pred"]] <- r[["solution"]]
     subsetOut[["precision"]] <- precision
   }
 
-  subsetOut[replace_na(subsetOut[["value"]], 0) < 1E-5 &
-              !is.na(subsetOut[["value"]]),
-            "value"] <- 0
+  subsetOut[replace_na(subsetOut[["pred"]], 0) < 1E-6 &
+              !is.na(subsetOut[["pred"]]),
+            "pred"] <- 0
 
   return(subsetOut)
 }