R/subset.R

In babaknaimi/rts: Raster Time Series Analysis

# Author: Babak Naimi, naimi.b@gmail.com
# Date :  July 2015
# Last Update :  Feb. 2024
# Version 1.3
# Licence GPL v3
#--------------

setMethod("[[", c("RasterStackBrickTS","ANY","ANY"),
          function(x,i,drop=TRUE, ...) {
            if ( missing(i)) { stop('you must provide an index') }
            if (!inherits(try(i <- x@time[i],T), "try-error")) {
              if (length(i) > 1) {
                rts(raster::subset(x@raster,as.vector(i),drop=drop,...),index(i))
              } else {
                if (length(i) == 1) {
                  x <- raster::subset(x@raster,as.vector(i),drop=drop,...)
                  names(x) <- as.character(index(i))
                  x
                } else stop("There is no data for specified time range!")
              }
            } else {
              stop("There is no data for specified time range, or subscript out of bounds")
            }
          })
#----
setMethod("[[", c("SpatRasterTS","ANY","ANY"),
          function(x,i, ...) {
            if ( missing(i)) { stop('you must provide an index') }
            if (!inherits(try(i <- x@time[i],T), "try-error")) {
              if (length(i) > 1) {
                rts(subset(x@raster,as.vector(i),...),index(i))
              } else {
                if (length(i) == 1) {
                  x <- subset(x@raster,as.vector(i),...)
                  names(x) <- as.character(index(i))
                  x
                } else stop("There is no data for specified time range!")
              }
            } else {
              stop("There is no data for specified time range, or subscript out of bounds")
            }
          })
#-----------
setMethod("[[", c("stcube","ANY","ANY"),
          function(x,i,n,...) {
            if (missing(i) & missing(n)) stop('you must provide either an index (i=time) or name of variable (n)')
            
            if (missing(n)) {
              if (!inherits(try(i <- x@time[i],TRUE), "try-error")) {
                if (x@format == 'tseq') {
                  .x <- new('stcube',format='tseq',time=i)
                  .xd <- sds()
                  for (k in 1:length(x@cube)) .xd <- c(.xd,sds(x@cube[k][[as.vector(i)]]))
                  .x@cube <- .xd
                  .x
                } else {
                  .x <- new('stcube',format='vseq',time=i)
                  .x@cube <- x@cube[as.vector(i)]
                  .x
                }
              } else if (is.character(i) && all(i %in% names(x))) {
                if (x@format == 'tseq') {
                  if (length(i) == 1) {
                    .x <- x@cube[i]
                    new('SpatRasterTS',raster=.x,time=x@time)
                  } else {
                    .x <- new('stcube',format='tseq',time=i)
                    .x@cube <- x@cube[i]
                    .x
                  }
                } else {
                  if (length(i) == 1) {
                    .x <- x@cube
                    for (k in 1:length(.x)) .x[k] <- .x[k][[i]]
                    .x <- rast(.x)
                    new('SpatRasterTS',raster=.x,time=x@time)
                  } else {
                    .x <- new('stcube',format='vseq',time=x@time)
                    
                    .xd <- sds()
                    for (k in 1:length(x@cube)) .xd <- c(.xd,sds(x@cube[k][[i]]))
                    .x@cube <- .xd
                    .x
                  }
                }
                
              } else stop('i is not a time index or variable name!')
            } else {
              if (!is.character(n)) stop('n should be a character with variable names to subset!')
              
              if (missing(i)) {
                
                if (all(n %in% names(x))) {
                  if (x@format == 'tseq') {
                    if (length(n) == 1) {
                      .x <- x@cube[n]
                      new('SpatRasterTS',raster=.x,time=x@time)
                    } else {
                      .x <- new('stcube',format='tseq',time=x@time)
                      .x@cube <- x@cube[n]
                      .x
                    }
                  } else {
                    if (length(n) == 1) {
                      .x <- x@cube
                      for (k in 1:length(.x)) .x[k] <- .x[k][[n]]
                      .x <- rast(.x)
                      new('SpatRasterTS',raster=.x,time=x@time)
                    } else {
                      .x <- new('stcube',format='vseq',time=x@time)
                      .xd <- sds()
                      for (k in 1:length(x@cube)) .xd <- c(.xd,sds(x@cube[k][[n]]))
                      .x@cube <- .xd
                      .x
                    }
                  }
                } else stop('some (or all) of n are not the name of variable in the stcube!')
              } else {
                
                if (!inherits(try(i <- x@time[i],TRUE), "try-error")) {
                  if (!all(n %in% names(x))) stop('some (or all) of n are not the name of variable in the stcube!')
                  
                  if (x@format == 'tseq') {
                    .xd <- sds()
                    for (k in n) .xd <- c(.xd,sds(x@cube[k][[as.vector(i)]]))
                    if (length(n) == 1) {
                      new('SpatRasterTS',raster=rast(.xd),time=i)
                    } else {
                      new('stcube',format='tseq',time=i,cube=.xd)
                    }
                  } else {
                    .x <- sds()
                    for (k in as.vector(i)) .x <- c(.x,sds(x@cube[k][[n]]))
                    
                    if (length(n) == 1) {
                      .x <- rast(.x)
                      new('SpatRasterTS',raster=.x,time=i)
                    } else {
                      new('stcube',format='vseq',time=i,cube=.x)
                    }
                  }
                } else stop('problem in the specified time index (i)!')
              }
              
              
            }
          })




if (!isGeneric("subset")) {
  setGeneric("subset", function(x, ...)
    standardGeneric("subset"))
}

setMethod("subset","RasterStackBrickTS",
          function(x, subset, drop=TRUE, ...) {
            if ( missing(subset)) { stop('subset is missing; you must provide an index') }
            x[[subset,drop=drop,...]]
          })
#----

setMethod("subset","SpatRasterTS",
          function(x, subset,  ...) {
            if ( missing(subset)) { stop('subset is missing; you must provide an index') }
            x[[subset,...]]
          })
#-----
setMethod("subset","stcube",
          function(x, subset, n, ...) {
            if ( missing(subset)) { stop('subset is missing; you must provide an index') }
            x[[subset,n=n,...]]
          })