diff --git a/DESCRIPTION b/DESCRIPTION index 9b07c60e..2737a376 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,13 +1,14 @@ Package: magclass Type: Package Title: Data Class and Tools for Handling Spatial-Temporal Data -Version: 4.91.0 -Date: 2018-12-13 +Version: 4.90.0 +Date: 2018-12-17 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"), person("Florian", "Humpenoeder", email = "humpenoeder@pik-potsdam.de", role = "aut"), person("Stephen", "Bi", role = "aut"), + person("Kristine", "Karstens", email = "karstens@pik-potsdam.de", role = "aut"), person("Lavinia", "Baumstark", email = "lavinia@pik-potsdam.de", role = "ctb"), person("Christoph", "Bertram", email = "bertram@pik-potsdam.de", role = "ctb"), person("Anastasis", "Giannousakis", email = "giannou@pik-potsdam.de", role = "ctb"), @@ -47,4 +48,4 @@ LazyData: true Encoding: UTF-8 RoxygenNote: 6.1.1 VignetteBuilder: knitr -ValidationKey: 87780980 +ValidationKey: 87621800 diff --git a/NAMESPACE b/NAMESPACE index 5eb88f5f..387c6121 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -51,6 +51,7 @@ export(magpieComp) export(magpieResolution) export(magpie_expand) export(magpiesort) +export(magpply) export(mbind) export(mbind2) export(mcalc) diff --git a/R/dimCode.R b/R/dimCode.R index da5cb5bd..6636f1e3 100644 --- a/R/dimCode.R +++ b/R/dimCode.R @@ -15,7 +15,7 @@ #' represents the main dimensions (1=spatial, 2=temporal, 3=data) or a numeric, #' representing the subdimensions of a dimension (e.g. 3.2 for the second data #' dimension). -#' @author Jan Philipp Dietrich +#' @author Jan Philipp Dietrich, Kristine Karstens #' @seealso \code{\link{mselect}}, \code{\link{getDim}} #' @examples #' diff --git a/R/getMetadata.R b/R/getMetadata.R index 1ac56bb3..74708757 100644 --- a/R/getMetadata.R +++ b/R/getMetadata.R @@ -53,7 +53,7 @@ #' @export getMetadata <- function(x, type=NULL) { - if(!withMetadata()) return(NULL) + if(!withMetadata()) return(NULL) if (Sys.getlocale("LC_CTYPE")!="en_US.UTF-8") tmp <- suppressWarnings(Sys.setlocale("LC_ALL","en_US.UTF-8")) if (!requireNamespace("data.tree", quietly = TRUE)) stop("The package data.tree is required for metadata handling!") units_options(auto_convert_names_to_symbols=FALSE, allow_mixed=TRUE) diff --git a/R/install_magpie_units.R b/R/install_magpie_units.R index 644f72e3..a657f1a7 100644 --- a/R/install_magpie_units.R +++ b/R/install_magpie_units.R @@ -47,13 +47,21 @@ install_magpie_units <- function(x=NULL) { z <- gsub("bn_","billion_",z,ignore.case=TRUE) } if (grepl("1e",substr(z,1,2),ignore.case=TRUE)) { + if (grepl("+",z,fixed=TRUE)) { + z <- gsub("+","",z,fixed=TRUE) + } if (grepl("*",z,fixed=TRUE)) { z <- unlist(strsplit(z,"*",fixed=TRUE)) prefix <- z[1] z <- z[2] }else { z <- gsub("1e","",z,ignore.case=TRUE) - prefix <- paste0("1e",unlist(strsplit(z,"\\D"))[1]) + if (grepl("^-",z)) { + z <- gsub("^-","",z) + prefix <- paste0("1e-",unlist(strsplit(z,"\\D"))[1]) + }else { + prefix <- paste0("1e",unlist(strsplit(z,"\\D"))[1]) + } z <- gsub("^\\d*","",z) } }else { @@ -115,7 +123,7 @@ install_magpie_units <- function(x=NULL) { }else if (tmp!="") z <- tmp } if (grepl("^\\d",z)) { - if (is.installed(gsub("^\\d*","",z))) { + if (is.installed(gsub("^\\d*","",remove_spaces(z)))) { prefix[length(prefix)+1] <- unlist(regmatches(z,gregexpr("^\\d*",z))) z <- gsub("^\\d*","",z) }else { @@ -180,10 +188,11 @@ install_magpie_units <- function(x=NULL) { z <- gsub("_%","_percent",z,fixed=TRUE) z <- gsub("%","percent_",z,fixed=TRUE) } - if (grepl("([.|()\\{}+$?:]|\\[|\\])",z)) { - z <- gsub("([.|()\\{}+$?:]|\\[|\\])","",z) + if (grepl("([.|#!@&~()\\{}+$?:]|\\[|\\])",z)) { warning("Unit entry \"",z,"\" contained invalid special characters which have now been removed. Please revise.") + z <- gsub("([.|#!@&~()\\{}+$?:]|\\[|\\])","",z) } + if (any(paste0(prefix,z)==c("","_","__","-"))) z <- "unknown" z <- prefix_check(prefix,paste0(z,suffix)) return(z) } @@ -304,7 +313,6 @@ install_magpie_units <- function(x=NULL) { input_unit <- function(a) { a <- gsub(" ","_",a) - a <- gsub("-","_",a) if (grepl("_or_",a,fixed=TRUE)) { a <- gsub("_or_",",",a,fixed=TRUE) } diff --git a/R/magpply.R b/R/magpply.R index d3dfedda..86bdb4d0 100644 --- a/R/magpply.R +++ b/R/magpply.R @@ -1,39 +1,41 @@ -#' @title magpply -#' @description apply command for magpieobjects. Very efficient for replacing loops. -#' -#' @param X magpie object -#' @param FUN function that shall be applied X -#' @param MARGIN dimension over which FUN shall be applied (like a loop over that dimension). This dimension will be preserved in the output object -#' @param ... further parameters passed on to FUN -#' @param integrate if TRUE, the output will be filled into an magpie object of the same dimensionality as X -#' -#' @return magpie object -#' @author Benjamin Leon Bodirsky -#' @examples -#' -#' \dontrun{ -#' data("population_magpie") -#' magpply(population_magpie,FUN=sum,MARGIN=2) -#' fourdim<-population_magpie*setNames(population_magpie,c("jkk","lk")) -#' magpply(fourdim,FUN=sum,MARGIN=c(1,3.1)) -#' magpply(fourdim,FUN=function(x){return(x+1)},MARGIN=c(1,3.1),integrate=TRUE) -#' } -#' - -magpply<-function(X,FUN,MARGIN,...,integrate=FALSE){ - if(any(MARGIN>3)){ - for(counter in which(MARGIN>3)){ - MARGIN[counter]=old_dim_convention(MARGIN[counter]) - } - X<-unwrap(X) - } - out<-apply(X = X,FUN = FUN,MARGIN=MARGIN) - if(integrate==TRUE){ - X[,,]<-out - out<-X - } else { - out<-as.magpie(out) - } - out <- updateMetadata(out,X,unit="copy",source="copy",calcHistory="copy",description="copy") - return(out) +#' @title magpply +#' @description apply command for magpieobjects. Very efficient for replacing loops. +#' +#' @param X magpie object +#' @param FUN function that shall be applied X +#' @param MARGIN dimension over which FUN shall be applied (like a loop over that dimension). This dimension will be preserved in the output object +#' @param ... further parameters passed on to FUN +#' @param integrate if TRUE, the output will be filled into an magpie object of the same dimensionality as X +#' +#' @return magpie object +#' @author Benjamin Leon Bodirsky +#' @examples +#' +#' \dontrun{ +#' data("population_magpie") +#' magpply(population_magpie,FUN=sum,MARGIN=2) +#' fourdim<-population_magpie*setNames(population_magpie,c("jkk","lk")) +#' magpply(fourdim,FUN=sum,MARGIN=c(1,3.1)) +#' magpply(fourdim,FUN=function(x){return(x+1)},MARGIN=c(1,3.1),integrate=TRUE) +#' } +#' +#' @export magpply + +magpply<-function(X,FUN,MARGIN,...,integrate=FALSE){ + if(any(MARGIN>3)){ + for(counter in which(MARGIN>3)){ + MARGIN[counter]=old_dim_convention(MARGIN[counter]) + } + X<-unwrap(X) + } + + out<-apply(X = X,FUN = FUN,MARGIN=MARGIN) + if(integrate==TRUE){ + X[,,]<-out + out<-X + } else { + out<-as.magpie(out) + } + out <- updateMetadata(out,X,unit="copy",source="copy",calcHistory="copy",description="copy") + return(out) } \ No newline at end of file diff --git a/R/read.magpie.R b/R/read.magpie.R index 9cc73c8f..dc7e98be 100644 --- a/R/read.magpie.R +++ b/R/read.magpie.R @@ -81,7 +81,7 @@ #' will be treated and counted as a new region (e.g. #' AFR.1,AFR.2,CPA.3,CPA.4,AFR.5 will count AFR twice and nregions will be set #' to 3!). -#' @author Jan Philipp Dietrich, Stephen Bi +#' @author Jan Philipp Dietrich, Stephen Bi, Florian Humpenoeder #' @seealso \code{"\linkS4class{magpie}"}, \code{\link{write.magpie}} #' @examples #' @@ -253,6 +253,20 @@ read.magpie <- function(file_name,file_folder="",file_type=NULL,as.array=FALSE,o } names(metadata[[i]]) <- name } + }else if (field[i]=="unit") { + metadata[[i]] <- unlist(strsplit(tmp2,": ",fixed=TRUE))[2] + if (grepl(",",metadata[[i]])) { + metadata[[i]] <- install_magpie_units("unknown") + #Mixed Units handling in development + + }else if (grepl("^\\d",metadata[[i]])) { + unitChar <- unlist(strsplit(metadata[[i]]," ")) + unitChar[2] <- as.character(units(install_magpie_units(unitChar[2]))) + metadata[[i]] <- as_units(as.numeric(unitChar[1]),unitChar[2]) + }else { + metadata[[i]] <- install_magpie_units(metadata[[i]]) + } + tmp <- readLines(zz,1) }else { metadata[[i]] <- unlist(strsplit(tmp2,": ",fixed=TRUE))[2] tmp <- readLines(zz,1) @@ -412,6 +426,19 @@ read.magpie <- function(file_name,file_folder="",file_type=NULL,as.array=FALSE,o if(is.null(nc_file$dim$time$len)) nc_file$dim$time$len <- 1 if(is.null(nc_file$dim$time$vals)) nc_file$dim$time$vals <- 1995 + if(length(nc_file$groups) == 1) { + var_names <- names(nc_file$var) + } else { + var_names <- NULL + for (i in 1:nc_file$nvars) { + var_name <- nc_file$var[[i]]$longname + group_index <- nc_file$var[[i]]$group_index + group_name <- nc_file$groups[[group_index]]$fqgn + var_names <- c(var_names,paste(group_name,var_name,sep="/")) + var_names <- gsub("/",".",var_names) + } + } + #create a single array of all ncdf variables nc_data <- array(NA,dim=c(nc_file$dim$lon$len,nc_file$dim$lat$len,nc_file$dim$time$len,nc_file$nvars)) for (i in 1:nc_file$nvars) { @@ -426,14 +453,24 @@ read.magpie <- function(file_name,file_folder="",file_type=NULL,as.array=FALSE,o #reorder ncdf array into magpie cellular format (still as array) #create emtpy array in magpie cellular format - mag <- array(NA,dim=c(59199,nc_file$dim$time$len,nc_file$nvars),dimnames=list(paste(magclassdata$half_deg$region,1:59199,sep="."),paste("y",nc_file$dim$time$vals,sep=""),names(nc_file$var))) + mag <- array(NA,dim=c(59199,nc_file$dim$time$len,nc_file$nvars),dimnames=list(paste("GLO",1:59199,sep="."),paste("y",nc_file$dim$time$vals,sep=""),var_names)) #Loop over cells to give mag values taken from nc_data. For each cell in mag, we know the exact coordinates (coord). Hence, we can use coord to map coordinates in nc_data to cells in mag. for (i in 1:ncells(mag)) { mag[i,,] <- nc_data[which(coord[i, 1]==lon), which(coord[i,2]==lat),,] } metadata <- list() - if(ncdf4::ncatt_get(nc_file,varid=0,attname="unit")[[1]]) metadata$unit <- ncdf4::ncatt_get(nc_file,varid=0,attname="unit")[[2]] + if(ncdf4::ncatt_get(nc_file,varid=0,attname="unit")[[1]]) { + unitChar <- ncdf4::ncatt_get(nc_file,varid=0,attname="unit")[[2]] + #Mixed units handling in development + if (grepl("^\\d",unitChar)) { + unitChar <- unlist(strsplit(unitChar," ")) + unitChar[2] <- as.character(units(install_magpie_units(unitChar[2]))) + metadata$unit <- as_units(as.numeric(unitChar[1]),unitChar[2]) + }else { + metadata$unit <- install_magpie_units(unitChar) + } + } if(ncdf4::ncatt_get(nc_file,varid=0,attname="user")[[1]]) metadata$user <- ncdf4::ncatt_get(nc_file,varid=0,attname="user")[[2]] if(ncdf4::ncatt_get(nc_file,varid=0,attname="date")[[1]]) metadata$date <- ncdf4::ncatt_get(nc_file,varid=0,attname="date")[[2]] if(ncdf4::ncatt_get(nc_file,varid=0,attname="description")[[1]]) metadata$description <- ncdf4::ncatt_get(nc_file,varid=0,attname="description")[[2]] @@ -481,7 +518,7 @@ read.magpie <- function(file_name,file_folder="",file_type=NULL,as.array=FALSE,o } #convert array to magpie object - read.magpie <- as.magpie(mag) + read.magpie <- clean_magpie(as.magpie(mag)) getMetadata(read.magpie) <- metadata } else { diff --git a/R/updateMetadata.R b/R/updateMetadata.R index c0461759..9ec5aad2 100644 --- a/R/updateMetadata.R +++ b/R/updateMetadata.R @@ -98,61 +98,53 @@ updateMetadata <- function(x, y=NULL, unit=ifelse(is.null(y),"keep","update"), s tmp[2] <- paste(tmp[-1],collapse="(") } tmp <- gsub(".{1}$","",tmp[2]) - args <- unlist(strsplit(tmp,",",fixed=TRUE)) + arg <- unlist(strsplit(tmp,",",fixed=TRUE)) fchanged <- FALSE - for(i in 1:length(args)){ - if (grepl("(",args[i],fixed=TRUE)) { + for(i in 1:length(arg)){ + if (grepl("(",arg[i],fixed=TRUE)) { j <- i - while (!grepl(")",args[j],fixed=TRUE)) { - if (grepl("(",args[j],fixed=TRUE)) { - if (j>i | length(regmatches(args[j],gregexpr("(",args[j],fixed=TRUE)))>1) { - while (!grepl(")",args[j],fixed=TRUE)) { - args[i] <- paste0(args[i],",",args[j]) - args <- args[-j] - if (j==length(args)) break + while (!grepl(")",arg[j],fixed=TRUE)) { + if (grepl("(",arg[j],fixed=TRUE)) { + if (j>i | length(regmatches(arg[j],gregexpr("(",arg[j],fixed=TRUE)))>1) { + while (!grepl(")",arg[j],fixed=TRUE)) { + arg[i] <- paste0(arg[i],",",arg[j]) + arg <- arg[-j] + if (j>=length(arg)) break else j <- j+1 } } } - if (j>=length(args)) break + if (j>=length(arg)) break else j <- j+1 - args[i] <- paste0(args[i],",",args[j]) - args <- args[-j] + arg[i] <- paste0(arg[i],",",arg[j]) + arg <- arg[-j] } - if (grepl("=",args[i],fixed=TRUE)) { - tmp <- unlist(strsplit(args[i],"=",fixed=TRUE)) - tmp[2] <- eval.parent(parse(text=tmp[2]),n=n+1) - args[i] <- paste0(tmp[1],"= \"",tmp[2],"\"") - }else { - args[i] <- eval.parent(parse(text=args[i]),n=n+1) - args[i] <- paste0("\"",args[i],"\"") + } + if(grepl("=",arg[i],fixed=TRUE)) { + tmp <- trimws(unlist(strsplit(arg[i],"=",fixed=TRUE))) + if (length(tmp)>2) { + tmp[2] <- paste(tmp[-1],collapse=", ") } - fchanged <- TRUE + }else { + tmp <- c(NA,arg[i]) } - if(grepl("=",args[i],fixed=TRUE)) { - tmp <- trimws(unlist(strsplit(args[i],"=",fixed=TRUE))) - if(tmp[1]==tmp[2]) { + if (grepl("(",tmp[2],fixed=TRUE) & !grepl("c(",substr(tmp[2],1,2),fixed=TRUE) & !grepl("list(",tmp[2],fixed=TRUE)) { + tmp[2] <- eval.parent(parse(text=tmp[2]),n=n+1) + fchanged <- TRUE + }else if(!grepl("\u0022",tmp[2]) & grepl("[[:alpha:]]",tmp[2])) { + if (!any(tmp[2]==c("T","F","TRUE","FALSE","NULL"))) { tmp[2] <- get(tmp[2],envir=parent.frame(n+1)) - args[i] <- paste0(tmp[1]," = \"",tmp[2],"\"") - fchanged <- TRUE - }else if(!grepl("\u0022",tmp[2]) & grepl("[[:alpha:]]",tmp[2])) { - if (!any(tmp[2]==c("T","F","TRUE","FALSE"))) { - tmp[2] <- get(tmp[2],envir=parent.frame(n+1)) - if(length(tmp[2])>1) tmp[2] <- paste(tmp[2],collapse=", ") - args[i] <- paste0(tmp[1]," = \"",tmp[2],"\"") - fchanged <- TRUE - } - } - }else if(!grepl("\u0022",args[i]) & grepl("[[:alpha:]]",args[i])) { - if (!any(args[i]==c("T","F","TRUE","FALSE"))) { - tmp <- get(args[i],envir=parent.frame(n+1)) - if(length(tmp)>1) tmp <- paste(tmp,collapse=", ") - args[i] <- paste0("\"",tmp,"\"") + if(length(tmp[2])>1) { tmp[2] <- paste(tmp[2],collapse=", ") } fchanged <- TRUE } } + if (!is.na(tmp[1])) { + arg[i] <- paste0(tmp[1]," = \"",tmp[2],"\"") + }else { + arg[i] <- tmp[2] + } } - if(fchanged==TRUE) f <- paste0(fname,"(",paste(args,collapse=", "),")") + if(fchanged==TRUE) f <- paste0(fname,"(",paste(arg,collapse=", "),")") } if (convert==TRUE) return(data.tree::Node$new(f)) else return(f) diff --git a/R/write.magpie.R b/R/write.magpie.R index 5e9f9e29..d0089601 100644 --- a/R/write.magpie.R +++ b/R/write.magpie.R @@ -143,7 +143,21 @@ write.magpie <- function(x,file_name,file_folder="",file_type=NULL,append=FALSE, #function to write metadata to cs* filetypes .writeMetadata <- function(file,metadata,char,mchar) { if(!is.null(metadata$unit)) { - writeLines(paste(char,paste0(mchar,"unit:"),metadata$unit),file) + if (is(metadata$unit,"units")) { + if (as.numeric(metadata$unit)==1) { + unit <- as.character(units(metadata$unit)) + }else { + unit <- paste(as.character(metadata$unit),as.character(units(metadata$unit))) + } + }else if (is.character(metadata$unit)) { + unit <- metadata$unit + #Mixed units handling in development + #}else if (is(metadata$unit,"units")) { + #unit <- paste(as.character(metadata$unit),as.character(units(metadata$unit)),collapse=", ") + }else { + unit <- "unknown" + } + writeLines(paste(char,paste0(mchar,"unit:"),paste(unit,collapse=", ")),file) writeLines(char,file) } if(!is.null(metadata$user)) { diff --git a/R/write.magpie.ncdf.R b/R/write.magpie.ncdf.R index aa8a47ce..8d5b28ec 100644 --- a/R/write.magpie.ncdf.R +++ b/R/write.magpie.ncdf.R @@ -8,7 +8,7 @@ #' compression) and 9 (most compression), the netCDF file is written in netCDF #' version 4 format. If set to NA, the netCDF file is written in netCDF version #' 3 format. -#' @param comment Vector of comments. Comments are set as global attributes in the netcdf file. Comments have to have the format "indicator: comment" or " indicator:comment" +#' @param comment Vector of comments (also used for setting the unit). Comments are set as global attributes in the netcdf file. Format of comments: "indicator: comment" (e.g. "unit: Share of land area per grid cell") #' @param verbose Boolean deciding about whether function should be verbose or not #' @return netcdf file. Writes one file per year per @@ -37,10 +37,22 @@ write.magpie.ncdf<-function(x,file,nc_compression = 9,comment=NULL, verbose=TRUE indicator <- indicator[-match("source",indicator)] } if(!any(indicator=="unit")) { - units <- "not specified" - }else { + units <- "unknown" + }else if (is.character(commentary$unit)) { units <- commentary$unit + }else if (is(commentary$unit,"units")) { + if (as.numeric(commentary$unit)==1) { + units <- as.character(units(commentary$unit)) + }else { + units <- paste(as.character(commentary$unit),as.character(units(commentary$unit))) + } + #Mixed units handling in development + #}else if is(commentary$unit,"mixed_units") { + #units <- paste(as.character(commentary$unit),as.character(units(commentary$unit)),collapse=", ") + }else { + units <- "unknown" } + commentary$unit <- units #metadata old implementation }else if(!is.null(comment)) { metadata=TRUE diff --git a/data/population_magpie.rda b/data/population_magpie.rda index a5d6e280..4547e80a 100644 Binary files a/data/population_magpie.rda and b/data/population_magpie.rda differ