Merge pull request #55 from tscheypidi/master

extended functionality for getItems and getDim

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: magclass
 Type: Package
 Title: Data Class and Tools for Handling Spatial-Temporal Data
-Version: 5.5.1
-Date: 2019-12-06
+Version: 5.6.0
+Date: 2019-12-09
 Authors@R: c(person("Jan Philipp", "Dietrich", email = "dietrich@pik-potsdam.de", role = c("aut","cre")),
              person("Benjamin Leon", "Bodirsky", email = "bodirsky@pik-potsdam.de", role = "aut"),
              person("Markus", "Bonsch", role = "aut"),
@@ -48,4 +48,4 @@ LazyData: true
 Encoding: UTF-8
 RoxygenNote: 7.0.2
 VignetteBuilder: knitr
-ValidationKey: 10048036
+ValidationKey: 10213840

NAMESPACE

@@ -34,6 +34,7 @@ export(fulldim)
 export(getCPR)
 export(getCells)
 export(getComment)
+export(getDim)
 export(getItems)
 export(getMetadata)
 export(getNames)

R/getDim.R

@@ -6,19 +6,45 @@
 #' @param elems A vector of characters containing the elements that should be
 #' found in the MAgPIE object
 #' @param x MAgPIE object in which elems should be searched for.
-#' @return The name of the dimension in which elems were found.
+#' @param fullmatch If enabled, only dimensions which match exactly the elements
+#' provided will be returned. Otherwise, it is sufficient if elems contains a subset
+#' of the dimension.
+#' @param dimCode If enabled, the dimCode will be returned, otherwise the name
+#' of the dimension.
+#' @return The name or dimCode of the dimensions in which elems were found.
 #' @author Jan Philipp Dietrich
 #' @seealso \code{\link{mcalc}},\code{\link{dimCode}}
 #' @examples
 #' 
 #'  data(population_magpie)
-#'  magclass:::getDim(c("AFR","CPA"),population_magpie)
-#' 
-getDim <- function(elems, x){
-  r <- sapply(elems,grepl,fulldim(x)[[2]],fixed=TRUE)
-  if(any(colSums(r)==0)) stop("An element was not found in the given data set (",paste(colnames(r)[colSums(r)==0],collapse=", "),")!")
-  if(any(colSums(r)>1)) stop("An element was found in more than one dimension in the given data set (",paste(colnames(r)[colSums(r)>1],collapse=", "),"). Please specify the dim to use!")
-  if(!any(rowSums(r)==length(elems))) stop("Used elements belong to different dimensions!")
-  dim <- which(rowSums(r)==length(elems))
-  return(names(fulldim(x)[[2]])[dim])
+#'  getDim(c("AFR","CPA"),population_magpie)
+#'  getDim(c("AFR","CPA"),population_magpie,fullmatch=TRUE)
+#'  getDim(c("AFR","CPA"),population_magpie,dimCode=FALSE)
+#'  
+#' @export
+getDim <- function(elems,x,fullmatch=FALSE,dimCode=TRUE) {
+
+  tmpfun <- function(x,elems) {
+    return(all(elems %in% x)) 
+  }
+  tmpfun2 <- function(x,elems,fullmatch,dimCode) {
+    if(fullmatch) {
+      tmp <- sapply(x,setequal,elems)
+    } else {
+      tmp <- sapply(x,tmpfun,elems)
+    }
+    if(dimCode) names(tmp) <- 1:length(tmp)
+    return(tmp)
+  }
+  tmp <- getItems(x,split=TRUE) 
+  tmp2 <- lapply(tmp,tmpfun2,elems,fullmatch,dimCode)
+  if(dimCode) {
+    names(tmp2) <- 1:length(tmp2)
+    tmp2 <- unlist(tmp2)
+    out <- as.numeric(names(tmp2)[tmp2])
+  } else {
+    tmp2 <- unlist(tmp2)
+    out <- names(tmp2)[tmp2]
+  }
+  return(out)
 }

R/getItems.R

@@ -16,10 +16,23 @@
 #' getItems(population_magpie,"scenario")
 #' getItems(population_magpie,3.1)
 #' @export
-getItems <- function(x,dim,split=FALSE) {
+getItems <- function(x,dim=NULL,split=FALSE) {
+  if(is.null(dim)) {
+    if(!split) return(dimnames(x))
+    out <- list()
+    for(i in 1:3) out[[i]] <- getItems(x,dim=i,split=TRUE)
+    return(out)
+  }
   dim <- dimCode(dim,x, missing = "stop")
   if(dim==round(dim) && !split) return(dimnames(x)[[dim]])
   if(dim==round(dim) && split) {
+    if(is.null(dimnames(x)[[dim]])) {
+      out <- list(NULL)
+      if(!is.null(getSets(x))) {
+        names(out) <- getSets(x,fulldim=FALSE)[dim]
+      }
+      return(out)
+    } 
     tmp <- as.list(as.data.frame(t(matrix(unlist(strsplit(dimnames(x)[[dim]],"\\.")),ncol=dim(x)[dim])),stringsAsFactors=FALSE))
     tmp <- lapply(tmp,unique)
     if(!is.null(getSets(x))) {

R/mcalc.R

@@ -33,7 +33,9 @@ mcalc <- function(x,f,dim=NULL,append=FALSE) {
   f <- as.formula(f)
   vars <- all.vars(f[[3]])
 
-  if(is.null(dim)) dim <- getDim(vars,x)
+  if(is.null(dim)) dim <- getDim(vars,x,fullmatch=FALSE,dimCode=FALSE)
+  if(length(dim)==0) stop("Dimension not provided and automatic detection failed (no match)!")
+  if(length(dim)>1) stop("Dimension not provided and automatic detection failed (multiple matches)!")
 
   for(v in vars) {
     l <- list()

tests/testthat/test-getDim.R

@@ -0,0 +1,11 @@
+context("Dimension detection Test")
+
+data("population_magpie")
+
+test_that("getDim matches whole strings", {
+  expect_identical(getDim(c("AFR","CPA"), population_magpie,dimCode=FALSE),"i")
+  expect_identical(getDim(c("AFR","CPA"), population_magpie,dimCode=TRUE),1.1)
+  expect_identical(getDim(c("AF","CP"),population_magpie),numeric(0))
+})
+
+

tests/testthat/test-getItems.R

@@ -6,4 +6,12 @@ test_that("getItems even works for objects without set names", {
   expect_identical(getItems(x,1),"GLO")
   expect_identical(getItems(x,2),"y1995")
   expect_identical(getItems(x,3),"bla")
+})
+
+
+test_that("getItems works for missing dimnames", {
+  x <- new.magpie("GLO",NULL,NULL)
+  expect_identical(getItems(x,3),NULL)
+  expect_identical(getItems(x,3.1),NULL)
+  expect_identical(getItems(x,3,split=TRUE)[[1]],NULL)
 })