inst/extdata/CodeLibrary/R/snap.R

In NMproject: Script Based 'NONMEM' Model Development

#' metrumrg snap function 
#' 
#' @param x numeric vector to snap
#' @param rule vector of points to snap to
#' @param left direction to snap to 
#' @param ... not used
#' 
#' @export

snap <- function (x, rule = 1, left = TRUE, ...) 
{
  stopifnot(is.numeric(x), is.numeric(rule), is.finite(rule))
  if (!length(x)) 
    return(x)
  rule <- sort(unique(rule))
  if (length(rule) == 1) {
    stopifnot(rule > 0)
    lo <- min(x, na.rm = TRUE)
    hi <- max(x, na.rm = TRUE)
    lo <- (lo%/%rule) * rule - rule
    hi <- (hi%/%rule) * rule + rule
    rule <- seq(from = lo, to = hi, by = rule)
  }
  lt <- findInterval(x, rule)
  rt <- findInterval(x, rule) + 1
  lt[lt == 0] <- 1
  rt[rt > length(rule)] <- length(rule)
  lt <- rule[lt]
  rt <- rule[rt]
  fun <- match.fun(if (left) 
    "<="
    else "<")
  closer <- ifelse(fun(abs(x - lt), abs(rt - x)), lt, rt)
  closer
}