R/pr_flatten.R

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

#' Generates a flattened 'phenor' data file
#'
#' Uses files generated by pr_fm_*()
#' Flattening the file format allows for substantial speed increases
#' in optimization however limits readability. Using the split functionality
#' between the pr_fm_*() functions and this function allows for easier
#' subsetting of datasets.
#'
#' @param data structure list generated by pr_fm_*() functions
#' @return returns a flat file format structure of the pr_fm_*() input
#' data, this to speed up processing
#' @keywords phenology, model, preprocessing
#' @export

pr_flatten <- function(data){

  if (missing(data)){
    stop('please provide a structured list as generated by pr_fm_*() functions!')
  }

  # check if the element is flat by default
  if ("transition_dates" %in% names(data)){
    return(data)
  }

  # find the doy ranges as stored in the doy slot
  # of the first site
  doy <- data[[1]]$doy

  # bind / calculate the photoperiod (daylength)
  # for all locations with do.call()
  Li <- do.call("cbind",lapply(data,function(x)x$Li))

  # concat sitenames into a vector using a do.call()
  site <- as.character(do.call("c",lapply(data, function(x){
    if(!is.null(x)){
      rep(x$site, ncol(x$Ti))
    }
  })))

  # concat locations data into a matrix with the first row
  # being the latitude and the second longitude
  location <- do.call("cbind",lapply(data,function(x){
    if(!is.null(x)){
      matrix(rep(x$location, ncol(x$Ti)), 2, ncol(x$Ti))
    }
  }))

  # concat all temperature data in one big matrix
  Ti <- do.call("cbind",lapply(data,function(x)x$Ti))
  Tmini <- do.call("cbind",lapply(data,function(x)x$Tmini))
  Tmaxi <- do.call("cbind",lapply(data,function(x)x$Tmaxi))

  # concat all precip data in one big matrix
  Pi <- do.call("cbind",lapply(data,function(x)x$Pi))

  # concat all precip data in one big matrix
  VPDi <- do.call("cbind",lapply(data,function(x)x$VPDi))
                                 
  # concat all SM data in one big matrix
  SM <- do.call("cbind",lapply(data,function(x)x$SM))

  # long term mean
  ltm <- matrix(NA,365,length(site))
  for (i in 1:length(site)){
    ltm[,i] <- data[[which(names(data) == site[i])]]$ltm
  }

  # concat all transition dates for validation into
  # a long vector
  transition_dates <- as.vector(do.call("c",lapply(data,function(x)x$transition_dates)))

  # try to return prior dates (if available, i.e. phenocam for now)
  transition_dates_prior <- try(as.vector(do.call("c",lapply(data,function(x)x$transition_dates_prior))))
  if(inherits(transition_dates_prior,"try-error")){
    transition_dates_prior <- NULL
  }

  # concat all years
  year <- as.vector(do.call("c",lapply(data,function(x)x$year)))

  # recreate the validation data structure (new format)
  # but with concatted data
  flat_data <- list("site" = site,
              "location" = location,
              "doy" = doy,
              "transition_dates" = transition_dates,
              "transition_dates_prior" = transition_dates_prior,
              "year" = year,
              "ltm" = ltm,
              "Ti" = Ti,
              "Tmini" = Tmini,
              "Tmaxi" = Tmaxi,
              "Li" = Li,
              "Pi" = Pi,
              "VPDi" = VPDi,
              "SM" = SM,
              "georeferencing" = NULL
              )

  # assign a class for post-processing
  class(flat_data) <- class(data)

  # return the formatted, faster data format
  return(flat_data)
}