merge branch devel

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: transformeR
 Depends:
-    R(>= 3.5.0)
+    R(>= 3.5.0) 
 Imports:
     abind,
     akima,
@@ -22,8 +22,8 @@ Suggests:
     visualizeR
 Type: Package
 Title: A climate4R package for general climate data manipulation and transformation
-Version: 1.7.1
-Date: 2020-01-31
+Version: 1.7.2
+Date: 2020-02-14
 Authors@R: c(person("Bedia", "Joaquín", email = "[email protected]", role = c("aut","cre","dtc"), comment = c(ORCID = "0000-0001-6219-4312")),
              person("Jorge", "Baño Medina", email = "[email protected]", role = "ctb"),
              person("Ana", "Casanueva", email = "[email protected]", role = "ctb"),

NEWS

@@ -88,3 +88,8 @@ See the [Releases section](https://github.com/SantanderMetGroup/transformeR/rele
  * Allow type = NULL in `dataSplit' function.
  * Add zenodo badge in documentation
  * Other minor documentation issues.
+
+## 1.7.2 (14 Feb 2020)
+ * Update longname attribute in cluster-type grids
+ * Other minor changes
+

R/clusterGrid.R

@@ -86,7 +86,7 @@ clusterGrid <- function(grid,
                         ...) {
 
   type <- match.arg(type, choices = c("kmeans", "hierarchical", "som", "lamb"))
-  #browser()
+
   if (is.null(newdata)){
     #Checking grid dimensions
     if (!is.na(suppressMessages(getShape(grid, "member"))) && getShape(grid, "member") > 1){
@@ -105,9 +105,9 @@ clusterGrid <- function(grid,
         stop("For lamb, only 'psl' variable is required Use subsetGrid to extract it")
       }
       if (!is.null(centers)) {
-        message("Lamb WT was choosen, so the number of clusters will be forced to 27. Arg. 'centers' will be ignored.")
+        message("Lamb WT was choosen, so the number of clusters will be forced to 26. Arg. 'centers' will be ignored.")
       }
-      centers <- 27
+      centers <- 26
       arg.list <- list(...)
       arg.list[["grid"]] <- grid
       lamb.wt <- do.call("lambWT", arg.list)
@@ -158,24 +158,38 @@ clusterGrid <- function(grid,
     if(is.null(attr(grid, "wt.index"))){
       stop("'grid' is not a clustering object.")
     }
-    #Checking grid dimensions for newdata and var.names/n.mem matches with grid
-    if (getShape(newdata, "member") > 1){
+    if (!is.na(suppressMessages(getShape(newdata, "member"))) && getShape(newdata, "member") > 1){
       message("Clustering analysis will be done after Ensemble mean...")
       newdata <- suppressMessages(aggregateGrid(grid = newdata, aggr.mem = list(FUN = "mean", na.rm = TRUE)))
     }
+    #Checking consistency among input grids
     checkVarNames(newdata, grid)
-    checkDim(newdata, grid, dimensions = "var")
+    if (getGridUnits(grid) != getGridUnits(newdata)){
+      stop("Inconsistent variable units among 'grid' and 'newdata'")
+    }
+    checkDim(newdata, grid, dimensions = c("var", "lat", "lon"))
+    checkSeason(grid, newdata)
+    if (getTimeResolution(grid) != getTimeResolution(newdata)){
+      stop("Inconsistent time resolution among 'grid' and 'newdata'")
+    }
     n.var <- suppressMessages(getShape(grid, "var")) 
-    #Pre-processing in order to do clustering to ref CT's: 
     arg.list <- list(...)
     base <- arg.list[["base"]]
     if (!is.null(base)){ 
-      if (getShape(base, "member") > 1){
+      if (!is.na(suppressMessages(getShape(base, "member"))) && getShape(base, "member") > 1){
         base <- suppressMessages(aggregateGrid(grid = base, aggr.mem = list(FUN = "mean", na.rm = TRUE)))
       }
       checkVarNames(newdata, base)
-      checkDim(newdata, base, dimensions = "var")
+      if (getGridUnits(base) != getGridUnits(newdata)){
+        stop("Inconsistent variable units among 'base' and 'newdata'")
+      }
+      checkDim(newdata, base, dimensions = c("var", "lat", "lon"))
+      checkSeason(base, newdata)
+      if (getTimeResolution(base) != getTimeResolution(newdata)){
+        stop("Inconsistent time resolution among 'base' and 'newdata'")
+      }
     }
+    #Pre-processing in order to do clustering to ref CT's: 
     if (n.var != 1){
       mat.newdata <- comb.vars(grid = newdata, base = base, ref = NULL, var.names = getVarNames(newdata))
     } else {
@@ -189,8 +203,8 @@ clusterGrid <- function(grid,
       checkTemporalConsistency(newdata, y)
       out.grid <- y
     }
-    attr(out.grid, "cluster.type") <- type
-    attr(out.grid, "centers") <- centers
+    attr(out.grid, "cluster.type") <- attr(grid, "cluster.type")
+    attr(out.grid, "centers") <- attr(grid, "centers")
     attr(out.grid, "wt.index") <- wt.index
     attr(out.grid, "centroids") <- attr(grid, "centroids")
     if (type == "kmeans") {

R/lambWT.R

@@ -21,7 +21,7 @@
 #' @param center.point A two value vector that must include lon and lat from a location that will work as center point for the Lamb WT.
 #' See details. 
 #' @details According to Trigo and daCamara (2000), Int J Climatol, Lamb WT is only applied on North Atlantic domain. 
-#' The input grid units must be Pa, not hPa/mbar. If it is not in Pa, the units will be converted automatically.
+#' The input grid units must be Pa, not hPa/mbar. If it is not in Pa, the units must be converted.
 #' A center location point must be specified by the user. Then, the function calculates from left to right and from first to 16st 
 #' the rest of the location point from the grid specified by Trigo and daCamara (2000):
 #'  
@@ -33,7 +33,8 @@
 #'     \tab  \tab  \tab    \tab  \tab  \tab 15 \tab  \tab  \tab 16 \tab  \tab  \tab    
 #' }  
 #'
-#' where the north-south distance is 5º and the west-east distance is 10º.
+#' where the north-south distance is 5º and the west-east distance is 10º. 26 different WTs are defined, 10 pure types (NE, E, SE, S, SW, 
+#' W, NW, N, C and A) and 16 hybrid types (8 for each C and A hybrid). 
 #' @return The Lamb WT circulation index (and members, if applicable) with:
 #' \itemize{
 #' \item index: vector with the corresponding weather type from each point of the series, that is defined as follows:
@@ -97,15 +98,8 @@ lambWT <- function(grid, center.point = c(-5, 55)) {
     lon.array <- rep(centerlon, times=16)+c(-5, 5, -15, -5, 5, 15, -15, -5, 5, 15, -15, -5, 5, 15, -5, 5)
     lat.array <- rep(centerlat, times=16)+c(10, 10, 5, 5, 5, 5, 0, 0, 0, 0, -5, -5, -5, -5, -10, 10)
 
-    subgrid <- grid.member
-    l <- lapply(1:16, function(i){
-      subgrid$xyCoords$x <- lon.array[i]
-      subgrid$xyCoords$y <- lat.array[i]
-      grid.inter<-intersectGrid(grid.member, subgrid, type = c("spatial"), which.return = 1)
-      return(grid.inter)
-    }) 
-    list.grid<-bindGrid(l, dimension = "loc")
-    X<-list.grid$Data[1,1, , ]
+    grid.inter <- interpGrid(grid.member, new.coordinates = list(x = lon.array, y = lat.array), method = "nearest")
+    X <- grid.inter$Data
 
     sf.const<-1/cospi(centerlat/180)
     zw.const1<-sinpi(centerlat/180)/sinpi((centerlat-5)/180)
@@ -148,14 +142,20 @@ lambWT <- function(grid, center.point = c(-5, 55)) {
     nind <- which(d > 337.5 | d <= 22.5) #N
     d[neind] = 10; d[eind] = 11; d[seind] = 12; d[soind] = 13
     d[swind] = 14; d[wind] = 15; d[nwind] = 16; d[nind] = 17
+    names(d)[neind] <- "NE"; names(d)[eind] <- "E"; names(d)[seind] <- "SE"; names(d)[soind] <- "S"
+    names(d)[swind] <- "SW"; names(d)[wind] <- "W"; names(d)[nwind] <- "NW"; names(d)[nind] <- "N"
+
 
     #Define discrete wt series, codes similar to http://www.cru.uea.ac.uk/cru/data/hulme/uk/lamb.htm
     pd <- which(abs(z) < f) 
     wtseries[pd] <- d[pd] #purely directional type
+    names(wtseries)[pd] <- names(d)[pd]
     pcyc <- which(abs(z) >= (2*f) & z >= 0) 
     wtseries[pcyc] <- 18 #purely cyclonic type
+    names(wtseries)[pcyc] <- "C"
     pant <- which(abs(z) >= (2*f) & z < 0) 
     wtseries[pant] <- 1 #purely anticyclonic type
+    names(wtseries)[pant] <- "A"
     hyb <- which(abs(z) >= f & abs(z) < (2*f)) #hybrid type
     hybant <- intersect(hyb, which(z < 0)) #anticyclonic
     hybcyc <- intersect(hyb, which(z >= 0)) #cyclonic
@@ -164,11 +164,19 @@ lambWT <- function(grid, center.point = c(-5, 55)) {
       wtseries[intersect(hybant, which(d == i))] <- i-8
       #mixed cyclonic
       wtseries[intersect(hybcyc, which(d == i))] <- i+9
+      if(i == 10){names(wtseries)[intersect(hybant, which(d == i))] <- "ANE"; names(wtseries)[intersect(hybcyc, which(d == i))] <- "CNE"}
+      else if(i == 11){names(wtseries)[intersect(hybant, which(d == i))] <- "AE"; names(wtseries)[intersect(hybcyc, which(d == i))] <- "CE"}
+      else if(i == 12){names(wtseries)[intersect(hybant, which(d == i))] <- "ASE"; names(wtseries)[intersect(hybcyc, which(d == i))] <- "CSE"}
+      else if(i == 13){names(wtseries)[intersect(hybant, which(d == i))] <- "AS"; names(wtseries)[intersect(hybcyc, which(d == i))] <- "CS"}
+      else if(i == 14){names(wtseries)[intersect(hybant, which(d == i))] <- "ASW"; names(wtseries)[intersect(hybcyc, which(d == i))] <- "CSW"}
+      else if(i == 15){names(wtseries)[intersect(hybant, which(d == i))] <- "AW"; names(wtseries)[intersect(hybcyc, which(d == i))] <- "CW"}
+      else if(i == 16){names(wtseries)[intersect(hybant, which(d == i))] <- "ANW"; names(wtseries)[intersect(hybcyc, which(d == i))] <- "CNW"}
+      else {names(wtseries)[intersect(hybant, which(d == i))] <- "AN"; names(wtseries)[intersect(hybcyc, which(d == i))] <- "CN"}
     }
-    #indFlow <- which(abs(z) < 6 & f < 6) 
+    #indFlow <- which(abs(z) < 6 & f < 6)     
     #wtseries[indFlow] <- 27 #indeterminate 
 
-    wtseries.2<-wtseries[1:n[[1]]]
+    wtseries.2 <- wtseries[1:n[[1]]]
 
     lamb.list <- lapply(1:26, function(y){
       lamb.pattern <- which(wtseries.2 == y)

R/subsetGrid.R

@@ -22,7 +22,7 @@
 #' multigrid, as returned by \code{makeMultiGrid}, or other types of multimember grids
 #' (possibly multimember grids) as returned e.g. by \code{loadeR.ECOMS::loadECOMS}.
 #' @param var Character vector indicating the variables(s) to be extracted. (Used for multigrid subsetting). See details.
-#' @param cluster An integer indicating \strong{the cluster} to be subset.
+#' @param cluster An integer vector indicating \strong{the clusters} to be subset.
 #' @param members An integer vector indicating \strong{the position} of the members to be subset.
 #' @param runtime An integer vector indicating \strong{the position} of the runtimes to be subset.
 #' @param years The years to be selected. Note that this can be either a continuous or discontinuous
@@ -225,12 +225,14 @@ subsetCluster <- function(grid, cluster) {
             call. = FALSE)
     return(grid)
   }
-  if (!all(cluster %in% attr(grid, "index"))) {
+  if (!all(cluster %in% attr(grid, "wt.index"))) {
     stop("'cluster' index out of bounds", call. = FALSE)
   }
-  grid <- subsetDimension(grid, dimension = "time", indices = which(attr(grid, "index") == cluster))
-  attr(grid$Variable, "longname") <- paste0(getVarNames(grid), "_cluster", cluster) 
-  grid$Variable$varName <- paste0(getVarNames(grid), "_cluster", cluster)
+  indices = which(!is.na(match(attr(grid, "wt.index"), cluster))) 
+  grid <- subsetDimension(grid, dimension = "time", indices = indices)
+  attr(grid$Variable, "longname") <- paste0(getVarNames(grid), "_cluster", cluster)
+  attr(grid, "wt.index") <- attr(grid, "wt.index")[indices]
+  attr(grid$Variable, "subset") <- "subsetCluster"
   return(grid)
 }
 # End