R/pr_fm_subset.R

In bluegreen-labs/phenor: An R phenology Modelling Framework

#' Subset formatted phenor data
#'
#' Function to subset data formatted using the phenor package
#'
#' @param data structured data of type/class 'phenor', generated by the phenor
#' pr_fm_...() functions
#' @param selection vector of columns to select (logical) of the same length
#' as the number of site years in the dataset
#' @return Returns a subset of the original data, for cross validation
#' experiments.
#' @keywords phenology, model, preprocessing, climate data
#' @export
#' @examples
#'
#' \dontrun{
#' # subset phenor formatted data
#' subset <- pr_fm_subset(data = phenocam_DB,
#'                         selection = 1:10)
#'}

pr_fm_subset <- function(
  data,
  selection
  ){

  # check missing parameters
  if (missing(data) | missing(selection)){
    stop("Missing parameters...",
         call. = FALSE)
  }

  # no remaining data to output
  if(!any(selection)){
    stop("No data remains in selection...",
         call. = FALSE)
  }

  # check the class of the data
  # if(class(data) != "phenor_time_series_data"){
  #   stop("The provided data is not of class 'phenor_timeseries_data'.",
  #        call. = FALSE)
  # }

  # check if the selection matches the length of the data
  if(length(selection) != length(data$year)){
    stop("The selection vector doesn't match the size of the data",
         call. = FALSE)
  }

  # loop over all nested list elements and
  # subset according to the data type
  subset <- lapply(data,
                   function(x) {

                     # if there is nothing in the
                     # list element return nothing as well
                     if (is.null(x)) {
                       return(NULL)
                     }

                     # if the data is a matrix, subset
                     # as a matrix
                     if (is.matrix(x)) {
                       return(x[, selection])
                     }

                     # if a vector, subset the vector
                     if (is.vector(x)) {
                       return(x[selection])
                     }

                     # if a list, return the
                     # original element (georeferencing)
                     if (is.list(x)) {
                       return(x)
                     }
                   })

  # override the doy subset (should remain invariant)
  subset$doy <- data$doy
  subset$ltm <- data$ltm

  # return subset data
  return(subset)
}