R/resample_sim.R

In USGS-R/glmtools: Tools for working with the General Lake Model (GLM)

#'@title get subset of time from a generic timeseries data.frame
#'@description 
#'resamples the input data.frame to only have rows corresponding to matches between 
#'df$DateTime and t_out. Both df$DateTime and t_out are of type POSIXct, and the 
#'precision of the match is passed in through the \code{precision} argument. 
#'\emph{The order of t_out}, not df$DateTime is retained.
#'
#'@param df a data.frame with DateTime and potentially other columns
#'@param t_out a vector of POSIXct dates (or character array that can be coerced into POSIXct) 
#'for matching to df$DateTime
#'@param method 'match' for exact match or 'interp' for temporal interpolation
#'@param precision matching precision (must be 'secs', 'mins','hours', 'days', or 'exact'). 
#'@return a data.frame with DateTime other original columns, resampled according to t_out
#'@keywords methods
#'@seealso \link{get_temp}, \link{get_wind}, \link{get_surface_height}, \link{get_evaporation}, \link{get_ice}
#'@author
#'Jordan S. Read
#'@examples 
#'sim_folder <- run_example_sim(verbose = FALSE)
#'nc_file <- file.path(sim_folder, 'output/output.nc')
#'temp_surf <- get_temp(nc_file, reference = 'surface', z_out = c(0,1,2))
#'t_out <- as.POSIXct(c("2011-04-01", "2011-06-14", "2011-04-05", "2011-07-28"))
#'temp_out <- resample_sim(df = temp_surf, t_out = t_out)
#'
#'t_out <- c("2011-04-01 10:00", "2011-04-05 08:15", 
#'       "2011-06-14 10:30", "2011-04-05 10:21", 
#'       "2011-07-28 10:00")
#'temp_out <- resample_sim(df = temp_surf, t_out = t_out, precision = 'days')
#'
#'temp_out <- resample_sim(df = temp_surf, t_out = t_out, method = 'interp', precision = 'hours')
#'@export
resample_sim <- function(df, t_out, method = 'match', precision = 'days'){
  
  if (missing(t_out)){
    t_out = NULL
  }
  
  if (is.null(t_out)){
    return(df)
  } 
  
  if (length(unique(t_out)) != length(t_out)){stop('t_out values must be unique')}
  
  
  t_out <- coerce_date(t_out)
  
  if (!(method %in% c("match", "interp"))){
    stop(paste0('method ', method, ' not currently supported'))
  }
  
  # wish this could be vectorized, but we need to retain the order of *t_out*, not df
  if (precision != 'exact'){
    time <- time_precision(t_out, precision)
  } else {
    time <- t_out
  }
  
  
  if (method == 'interp'){
    df <- df_interp(df, time)
    time_compr <- df$DateTime
  } else {
    time_compr <- time_precision(df$DateTime, precision)
  }
  
  idx_out <- vector(length = length(time))
  for (j in seq_len(length(time))){
    m_i <- which(time[j] - time_compr == 0) #funny, match doesn't work (lt vs ct types)
    idx_out[j] = ifelse(length(m_i)==0,NA,m_i)
  }
  
  idx_out <- idx_out[!is.na(idx_out)]
  
  df_out <- df[idx_out, ]
  
  if (nrow(df_out) == 0){
    add_msg = ''
    if (method == 'match'){
      add_msg = ". Try method = 'interp'"
    }
    warning(paste0("no matches found using method = '",method,"' at ",precision,' precision',add_msg))
  }
  
  return(df_out)
  
}