misc/d3_method.R

In Kinekenneth48/rdailychange: Daily Change Method for Spatial Data

# HELPER FUNCTION 1 #####
# This function will take a vector x of raw snow observations. It will then
# split the vector across n or more m's into a list of vectors.
# > x <- c(1, 2, 0, 0, 0, 4, 5, 0, 3, 0, 0, 2, 1, 3)
# > split_across_n_m(x)
# $`0`
# [1] 1 2
# $`1`
# [1] 4 5 0 3
# $`2`
# [1] 2 1 3
split_across_n_m <- function(x, n = 2, m = 0) {
  r <- rle(x == m)
  r$values <- cumsum(r$values & r$lengths > n - 1)
  result <- lapply(split(x, inverse.rle(r)), function(r) r[cummax(r) > m])
  return(result)
}

# HELPER FUNCTION 2 #####
# Because of HELPER FUNCTION 1, the HELPER FUNCTION 2 assumes to work with
# d3_cands and dx which is derived from raw observations with no consecutive 0's.

# This function will take the TRUE d3_cands, sum up three consecutive days for
# the D3 Method. If that sum is positive, it will add it to the result, and
# falsify the three days used. If that sum is not positive it will do nothing.
# Looping through it will return the result.
Rcpp::cppFunction('NumericVector calc_d3_method(LogicalVector d3_cands,
                                                NumericVector dx) {
  int n = 3;
  NumericVector result;
  for (int i = 0; i < d3_cands.size(); i++) {
    if (d3_cands[i] == true) {
      int sum = 0;
      for (int j = i; j < i + n; j++) {
        sum += dx[j];
      }
      if (sum > 0) {
        result.push_back(sum);
        for (int j = i + 1; j < i + n; j++) {
          d3_cands[j] = false;
        }
      }
    }
  }
  return result;
}')

# HELPER FUNCTION 3 #####
# Because of HELPER FUNCTION 1, the HELPER FUNCTION 3 assumes to work with
# raw observations with no consecutive 0's.

# This function will take raw observations, make sure there is enough data to
# perform the D3 Method (if not, it will return NULL), and then calculate
# the D3 Method.
d3_method_from_vector <- function(x) {
  n <- 3
  if (length(x) < n + 1) {
    return(NULL)
  }
  dx <- x[-1] - x[-length(x)]
  d3_cands <- dx[1:(length(dx) - (n - 1))] > 0 & dx[n:length(dx)] > 0
  result <- calc_d3_method(d3_cands, dx)
  return(result)
}

#' Calculate D3 Method for Snow Loads
#'
#' @description Given a dataframe, a column of which includes snow observations,
#'   this function will calculate the D3 Method.
#'
#' @param df The dataframe containing snow observations.
#' @param col_name Character string of the column name containing the
#'   snow observations.
#'
#' @return A list of numeric vectors containing the observations
#'   for the D3 Method (list split across 2 or more raw observations of 0).
#'
#' @export
d3_method <- function(df, col_name = "SWE") {
  x <- df[[col_name]]
  split_observations <- split_across_n_m(x)
  result <- lapply(split_observations, d3_method_from_vector)
  return(result)
}