bugfix in 67k (lpjcell) version of calcFAOForestRelocate and introduc…

…ed spaces through linter

.buildlibrary

@@ -1,4 +1,4 @@
-ValidationKey: '90678980778'
+ValidationKey: '9073638'
 AcceptedWarnings:
 - 'Warning: package ''.*'' was built under R version'
 - 'Warning: namespace ''.*'' is not available and has been replaced'

.zenodo.json

@@ -1,6 +1,6 @@
 {
   "title": "mrcommons: MadRat commons Input Data Library",
-  "version": "0.48.2.9001",
+  "version": "0.48.3",
   "description": "<p>Provides useful functions and a common structure to all the input data required to run models like MAgPIE and REMIND\n    of model input data.<\/p>",
   "creators": [
     {

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: mrcommons
 Type: Package
 Title: MadRat commons Input Data Library
-Version: 0.48.2.9001
-Date: 2021-05-31
+Version: 0.48.3
+Date: 2021-06-08
 Authors@R: c(person("Benjamin Leon", "Bodirsky", email = "[email protected]", role = "aut"),
              person("Kristine", "Karstens", role = "aut"),
              person("Lavinia", "Baumstark", role = "aut"),

R/calcFAOForestRelocate.R

@@ -14,14 +14,13 @@
 #' @return List of magpie object with results on cellular level, weight on cellular level, unit and description.
 #' @author Kristine Karstens, Felicitas Beier, Patrick v. Jeetze
 #' @examples
-#'
 #' \dontrun{
 #' calcOutput("FAOForestRelocate")
 #' }
 #' @import madrat
 #' @importFrom magclass setNames new.magpie nyears
 #' @importFrom nleqslv nleqslv
-#' 
+#'
 #' @export
 
 calcFAOForestRelocate <- function(selectyears = "past", nclasses = "seven", cells = "magpiecell") {
@@ -34,18 +33,18 @@ calcFAOForestRelocate <- function(selectyears = "past", nclasses = "seven", cell
 
   if (cells == "lpjcell") {
     mapping   <- toolGetMappingCoord2Country()
-    cellvegc  <- calcOutput("LPJmL_new", version = "LPJmL4_for_MAgPIE_84a69edd", climatetype = "GSWP3-W5E5:historical", subtype = "vegc", stage="smoothed", aggregate = FALSE)[,getYears(countrydata),]
-    countries <- unique(gsub("[^A-Z]","", getCells(cellvegc)))
-    getCells(LUH2v2_init) <-  paste(c(1:67420), gsub("[^A-Z]","", getCells(cellvegc)), sep=".")
-    getCells(cellvegc)    <-  paste(c(1:67420), gsub("[^A-Z]","", getCells(cellvegc)), sep=".")
+    cellvegc  <- calcOutput("LPJmL_new", version = "LPJmL4_for_MAgPIE_84a69edd", climatetype = "GSWP3-W5E5:historical", subtype = "vegc", stage = "smoothed", aggregate = FALSE)[, getYears(countrydata), ]
+    countries <- unique(gsub("[^A-Z]", "", getCells(cellvegc)))
+    getCells(LUH2v2_init) <-  paste(gsub("[^A-Z]", "", getCells(cellvegc)), c(1:67420), sep = ".")
+    getCells(cellvegc)    <-  paste(gsub("[^A-Z]", "", getCells(cellvegc)), c(1:67420), sep = ".")
     names(dimnames(LUH2v2_init))[1] <- "celliso"
     names(dimnames(cellvegc))[1]    <- "celliso"
-    mapping   <- data.frame(mapping, celliso= paste(c(1:67420), gsub("[^A-Z]","", getCells(cellvegc)), sep="."), stringsAsFactors = F)
+    mapping   <- data.frame(mapping, celliso = paste(gsub("[^A-Z]", "", getCells(cellvegc)), c(1:67420), sep = "."), stringsAsFactors = F)
   } else {
     mapping   <- toolGetMapping(type = "cell", name = "CountryToCellMapping.csv")
     countries <- unique(mapping$iso)
 
-    cellvegc <- calcOutput("LPJmL_new", version = "LPJmL4_for_MAgPIE_84a69edd", climatetype = "GSWP3-W5E5:historical", subtype = "vegc", stage="smoothed", aggregate = FALSE)[,getYears(countrydata),]
+    cellvegc <- calcOutput("LPJmL_new", version = "LPJmL4_for_MAgPIE_84a69edd", climatetype = "GSWP3-W5E5:historical", subtype = "vegc", stage = "smoothed", aggregate = FALSE)[, getYears(countrydata), ]
     # reduce to 59199 cells and rename cells
     cellvegc <- toolCoord2Isocell(cellvegc)
   }
@@ -72,126 +71,126 @@ calcFAOForestRelocate <- function(selectyears = "past", nclasses = "seven", cell
 
   # loop over countries and years
   for (iso in countries) {
-
-     luiso <- LUH2v2_init[iso, , ]
-
-     cveg <- cellvegc[iso, , ]
-
-      # normalized vegetation carbon (with small correction to ensure values between [0,1))
-      cellvegc_n <- t(as.array(cveg / (as.magpie(apply(cveg,2,max)) + 10^-10))[,,1])
-
-      ###########################
-      ### Reduction procedure ###
-      ###########################
-
-      # loop over all land use categories, that has to be reallocated
-      for (cat in nature) {
-
-        catreduce <- as.array(reduce[iso, , cat])[,,1]
-
-        # check if area has to be cleared
-        if (any(catreduce != 0)) {
-
-          # check for one cell countries
-          if (dim(cellvegc_n)[1] == 1) {
-            # trivial case of one cell countries
-            remove <- -as.magpie(catreduce)
-          } else {
-            # for other land cell with highest vegc and for all forest categories lowest vegc should be cleared first
-            if (cat == "other") {
-              cellweight <- cellvegc_n
-            } else {
-              cellweight <- (1 - 10^-16 - cellvegc_n)
-            }
-
-            # check for edge case in which all land of that category must be removed and treat it separately
-            fullremoval <- (round(dimSums(luiso,dim = 1)[,,cat] + catreduce,2) == 0)
-            if (any(fullremoval)) {
-              luiso[, fullremoval , "to_be_allocated"] <- luiso[, fullremoval , "to_be_allocated"] + setNames(luiso[, fullremoval, cat], NULL)
-              luiso[, fullremoval, cat] <- 0
-              catreduce[fullremoval] <- 0
-            }
-
-            t <- (catreduce != 0) 
-            if(any(t)) {
-              # determine correct parameter for weights for multiple cell countries (weights below zero indicate an error)
-              p <- nleqslv(rep(1,nyears(luiso)), findweight, cellarea = t(as.array(luiso)[, , cat]), isoreduction = catreduce, cellweight = cellweight)$x
-              names(p) <- rownames(cellweight)
-              if (any(p[t] < 0)) stop(verbosity = 2, paste0("Negative weight of p=", p, " for: ", cat, " ", iso, " ", t))
-              remove <- luiso[, , cat] * (1 - (1 - as.magpie(cellweight))^as.magpie(p))
-              remove[,!t,] <- 0
-            } else {
-              remove <- 0
-            }
-          }
 
-          # remove area from cells and put to "to_be_allocated" area
-          luiso[, , cat] <- luiso[, , cat] - remove
-          luiso[, , "to_be_allocated"] <- luiso[, , "to_be_allocated"] + remove
-        }
-      }
+    luiso <- LUH2v2_init[iso, , ]
+
+    cveg <- cellvegc[iso, , ]
+
+    # normalized vegetation carbon (with small correction to ensure values between [0,1))
+    cellvegc_n <- t(as.array(cveg / (as.magpie(apply(cveg, 2, max)) + 10^-10))[, , 1])
 
-      ############################
-      ### Allocation procedure ###
-      ############################
+    ###########################
+    ### Reduction procedure ###
+    ###########################
 
-      catincrease <- as.array(increase[iso, , "other"])[,,1]
-
-      # relocate other land to areas with low vegetation carbon density
-      # check if other land has to be filled
-      if (any(catincrease != 0)) {
-
-        t <- (catincrease != 0)
-
-        cellweight <- (1 - 10^-16 - cellvegc_n)
+    # loop over all land use categories, that has to be reallocated
+    for (cat in nature) {
 
+      catreduce <- as.array(reduce[iso, , cat])[, , 1]
+
+      # check if area has to be cleared
+      if (any(catreduce != 0)) {
 
         # check for one cell countries
         if (dim(cellvegc_n)[1] == 1) {
           # trivial case of one cell countries
-          add <- as.magpie(catincrease)
+          remove <- -as.magpie(catreduce)
         } else {
-          # determine correct parameter for weights for multiple cell countries (weights below zero indicate an error)
-          p <- nleqslv(rep(1,nyears(luiso)), findweight, cellarea = t(as.array(luiso)[, , "to_be_allocated"]), isoreduction = -catincrease, cellweight = cellweight)$x
-          names(p) <- rownames(cellweight)
-          if (any(p[t] < 0)) stop(verbosity = 2, paste0("Negative weight of p=", p, " for: ", cat, " ", iso, " ", t))
-          add <- luiso[, , "to_be_allocated"] * (1 - (1 - as.magpie(cellweight))^as.magpie(p))
+          # for other land cell with highest vegc and for all forest categories lowest vegc should be cleared first
+          if (cat == "other") {
+            cellweight <- cellvegc_n
+          } else {
+            cellweight <- (1 - 10^-16 - cellvegc_n)
+          }
+
+          # check for edge case in which all land of that category must be removed and treat it separately
+          fullremoval <- (round(dimSums(luiso, dim = 1)[, , cat] + catreduce, 2) == 0)
+          if (any(fullremoval)) {
+            luiso[, fullremoval, "to_be_allocated"] <- luiso[, fullremoval, "to_be_allocated"] + setNames(luiso[, fullremoval, cat], NULL)
+            luiso[, fullremoval, cat] <- 0
+            catreduce[fullremoval] <- 0
+          }
+
+          t <- (catreduce != 0)
+          if (any(t)) {
+            # determine correct parameter for weights for multiple cell countries (weights below zero indicate an error)
+            p <- nleqslv(rep(1, nyears(luiso)), findweight, cellarea = t(as.array(luiso)[, , cat]), isoreduction = catreduce, cellweight = cellweight)$x
+            names(p) <- rownames(cellweight)
+            if (any(p[t] < 0)) stop(verbosity = 2, paste0("Negative weight of p=", p, " for: ", cat, " ", iso, " ", t))
+            remove <- luiso[, , cat] * (1 - (1 - as.magpie(cellweight))^as.magpie(p))
+            remove[, !t, ] <- 0
+          } else {
+            remove <- 0
+          }
         }
-        add[,!t,] <- 0
 
-        # move area from "to_be_allocated" area to other land
-        luiso[, , "other"] <- luiso[, , "other"] + add
-        luiso[, , "to_be_allocated"] <- luiso[, , "to_be_allocated"] - add
+        # remove area from cells and put to "to_be_allocated" area
+        luiso[, , cat] <- luiso[, , cat] - remove
+        luiso[, , "to_be_allocated"] <- luiso[, , "to_be_allocated"] + remove
       }
+    }
 
-      # relocate forest land to remaining "to_be_allocated" area
-      # check if forests has to be filled
-
-      catincrease <- increase[iso, , forests]
-
-      if (any(catincrease != 0)) {
-
-        # move area from "to_be_allocated" area to forests
-        forests_share <- catincrease / (setNames(dimSums(catincrease, dim = 3), NULL) + 10^-10)
-        luiso[, , forests] <- luiso[, , forests] + setCells(forests_share, "GLO") * setNames(luiso[, , "to_be_allocated"], NULL)
-
-        luiso[, , "to_be_allocated"] <- 0
-      }
+    ############################
+    ### Allocation procedure ###
+    ############################
+
+    catincrease <- as.array(increase[iso, , "other"])[, , 1]
+
+    # relocate other land to areas with low vegetation carbon density
+    # check if other land has to be filled
+    if (any(catincrease != 0)) {
+
+      t <- (catincrease != 0)
 
-      ############################
-      ### Check reallocation   ###
-      ############################
+      cellweight <- (1 - 10^-16 - cellvegc_n)
 
-      if (any(round(dimSums(luiso[, , landuse], dim = 1) - countrydata[iso, , landuse],3) != 0)) {
-        warning("Missmatch in data for in ", iso)
+
+      # check for one cell countries
+      if (dim(cellvegc_n)[1] == 1) {
+        # trivial case of one cell countries
+        add <- as.magpie(catincrease)
+      } else {
+        # determine correct parameter for weights for multiple cell countries (weights below zero indicate an error)
+        p <- nleqslv(rep(1, nyears(luiso)), findweight, cellarea = t(as.array(luiso)[, , "to_be_allocated"]), isoreduction = -catincrease, cellweight = cellweight)$x
+        names(p) <- rownames(cellweight)
+        if (any(p[t] < 0)) stop(verbosity = 2, paste0("Negative weight of p=", p, " for: ", cat, " ", iso, " ", t))
+        add <- luiso[, , "to_be_allocated"] * (1 - (1 - as.magpie(cellweight))^as.magpie(p))
       }
-
-      LUH2v2_init[iso, , ] <- luiso
-
+      add[, !t, ] <- 0
+
+      # move area from "to_be_allocated" area to other land
+      luiso[, , "other"] <- luiso[, , "other"] + add
+      luiso[, , "to_be_allocated"] <- luiso[, , "to_be_allocated"] - add
+    }
+
+    # relocate forest land to remaining "to_be_allocated" area
+    # check if forests has to be filled
+
+    catincrease <- increase[iso, , forests]
+
+    if (any(catincrease != 0)) {
+
+      # move area from "to_be_allocated" area to forests
+      forests_share <- catincrease / (setNames(dimSums(catincrease, dim = 3), NULL) + 10^-10)
+      luiso[, , forests] <- luiso[, , forests] + setCells(forests_share, "GLO") * setNames(luiso[, , "to_be_allocated"], NULL)
+
+      luiso[, , "to_be_allocated"] <- 0
+    }
+
+    ############################
+    ### Check reallocation   ###
+    ############################
+
+    if (any(round(dimSums(luiso[, , landuse], dim = 1) - countrydata[iso, , landuse], 3) != 0)) {
+      warning("Missmatch in data for in ", iso)
+    }
+
+    LUH2v2_init[iso, , ] <- luiso
+
   }
 
   if (nclasses == "nine") {
-    LUH2v2_nocorr <- calcOutput("LUH2v2", aggregate = FALSE, landuse_types = "LUH2v2", irrigation = FALSE, cellular = TRUE, selectyears = selectyears, round=8)
+    LUH2v2_nocorr <- calcOutput("LUH2v2", aggregate = FALSE, landuse_types = "LUH2v2", irrigation = FALSE, cellular = TRUE, selectyears = selectyears, round = 8)
 
     # calculate shares of primary and secondary non-forest vegetation
     totother_luh <- dimSums(LUH2v2_nocorr[, , c("primn", "secdn")], dim = 3)
@@ -225,7 +224,7 @@ calcFAOForestRelocate <- function(selectyears = "past", nclasses = "seven", cell
     )
   }
 
-  if (!any(round(dimSums(out, dim = c(1, 3)) - round(totalarea, 3),3) != 0)) {
+  if (!any(round(dimSums(out, dim = c(1, 3)) - round(totalarea, 3), 3) != 0)) {
     vcat(2, "Something went wrong. Missmatch in total land cover area after reallocation.")
   }
 

README.md

@@ -1,6 +1,6 @@
 # MadRat commons Input Data Library
 
-R package **mrcommons**, version **0.48.2.9001**
+R package **mrcommons**, version **0.48.3**
 
 [![CRAN status](https://www.r-pkg.org/badges/version/mrcommons)](https://cran.r-project.org/package=mrcommons) [![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.3822009.svg)](https://doi.org/10.5281/zenodo.3822009)  [![R build status](https://github.com/pik-piam/mrcommons/workflows/check/badge.svg)](https://github.com/pik-piam/mrcommons/actions) [![codecov](https://codecov.io/gh/pik-piam/mrcommons/branch/master/graph/badge.svg)](https://codecov.io/gh/pik-piam/mrcommons)
 
@@ -39,12 +39,10 @@ In case of questions / problems please contact Jan Philipp Dietrich <dietrich@pi
 
 To cite package **mrcommons** in publications use:
 
-Bodirsky B, Karstens K, Baumstark L, Weindl I, Wang X, Mishra A, Wirth S, Stevanovic M, Steinmetz N,
-Kreidenweis U, Rodrigues R, Popov R, Humpenoeder F, Giannousakis A, Levesque A, Klein D, Araujo E, Beier F,
-Oeser J, Pehl M, Leip D, Crawford M, Molina Bacca E, von Jeetze P, Martinelli E, Schreyer F, Dietrich J
-(2021). _mrcommons: MadRat commons Input Data Library_. doi: 10.5281/zenodo.3822009 (URL:
-https://doi.org/10.5281/zenodo.3822009), R package version 0.48.2.9001, <URL:
-https://github.com/pik-piam/mrcommons>.
+Bodirsky B, Karstens K, Baumstark L, Weindl I, Wang X, Mishra A, Wirth S, Stevanovic M, Steinmetz N, Kreidenweis U, Rodrigues R, Popov
+R, Humpenoeder F, Giannousakis A, Levesque A, Klein D, Araujo E, Beier F, Oeser J, Pehl M, Leip D, Crawford M, Molina Bacca E, von
+Jeetze P, Martinelli E, Schreyer F, Dietrich J (2021). _mrcommons: MadRat commons Input Data Library_. doi: 10.5281/zenodo.3822009 (URL:
+https://doi.org/10.5281/zenodo.3822009), R package version 0.48.3, <URL: https://github.com/pik-piam/mrcommons>.
 
 A BibTeX entry for LaTeX users is
 
@@ -53,7 +51,7 @@ A BibTeX entry for LaTeX users is
   title = {mrcommons: MadRat commons Input Data Library},
   author = {Benjamin Leon Bodirsky and Kristine Karstens and Lavinia Baumstark and Isabelle Weindl and Xiaoxi Wang and Abhijeet Mishra and Stephen Wirth and Mishko Stevanovic and Nele Steinmetz and Ulrich Kreidenweis and Renato Rodrigues and Roman Popov and Florian Humpenoeder and Anastasis Giannousakis and Antoine Levesque and David Klein and Ewerton Araujo and Felicitas Beier and Julian Oeser and Michaja Pehl and Debbora Leip and Michael Crawford and Edna {Molina Bacca} and Patrick {von Jeetze} and Eleonora Martinelli and Felix Schreyer and Jan Philipp Dietrich},
   year = {2021},
-  note = {R package version 0.48.2.9001},
+  note = {R package version 0.48.3},
   doi = {10.5281/zenodo.3822009},
   url = {https://github.com/pik-piam/mrcommons},
 }