R/scale_breaks.R

In anthonynorth/rdeck: Deck.gl Widget

#' Breaks manual
#'
#' Generate a breaks vector with pre-determined threshold values.
#'
#' @details
#' Wraps `thresholds` in the range of input data (which may be null or non-finite).
#' Thresholds that fall outside the range of input are omitted from the output.
#'
#' @examples
#' breaks_manual(0)(-10:10)
#' breaks_manual(c(-10, 0, 10))(-10:10)
#' breaks_manual(-1:1 * 1e6)(NULL)
#'
#' @name breaks_manual
#' @param thresholds <`numeric`> a numeric vector of _ordered_, finite thresholds.
#'
#' @family breaks
#' @export
breaks_manual <- function(thresholds = 0.5) {
  tidyassert::assert(is.numeric(thresholds) && all_finite(thresholds) && !is.unsorted(thresholds))

  thresholds_default <- thresholds
  function(x, thresholds = thresholds_default) {
    tidyassert::assert(is.numeric(thresholds) && all_finite(thresholds) && !is.unsorted(thresholds))

    # rng can be reversed for infinte input
    rng <- sort(scales::train_continuous(x, c(-Inf, Inf)))

    # drop any thresholds outside or equal to range
    thresholds_clamped <- thresholds[
      thresholds > rng[1] & thresholds < rng[2] &
        !isapprox(thresholds, rng[1]) & !isapprox(thresholds, rng[2])
    ]

    c(rng[1], thresholds_clamped, rng[2])
  }
}


#' @rdname breaks_manual
#' @usage NULL
#' @export
manual_breaks <- breaks_manual


#' Breaks trans
#'
#' Generate a breaks vector of size `n` with evenly spaced breaks in `trans` domain.
#'
#' @details
#' Breaks are generated by transforming the input range to `trans` domain, generating
#' a regular sequence of size `n` for the transformed range, then inverting the transform.
#'
#' The input range must be finite for both the input domain _and_ the `trans` domain. If
#' input is not finite, an empty vector is returned.
#'
#' @examples
#' breaks_trans(trans = scales::identity_trans())(-10:10)
#' breaks_trans(trans = symlog_trans())(-10:10)
#' breaks_trans(trans = power_trans())(-10:10)
#' breaks_manual(c(-10, 0, 10))(-10:10)
#' breaks_manual(-1:1 * 1e6)(NULL)
#'
#' @name breaks_trans
#' @param n <`int`> the size of the output vector. Ouput size will be at least length-2
#' for finite input.
#' @param trans <`scales::trans`> an _invertible_ transformer.
#'
#' @family breaks
#' @export
breaks_trans <- function(n = 10, trans) {
  tidyassert::assert(rlang::is_scalar_integerish(n) && n >= 0)
  tidyassert::assert(scales::is.trans(trans))

  n_default <- n
  breaks_fn <- function(x, n = n_default) {
    tidyassert::assert(rlang::is_scalar_integerish(n) && n >= 0)

    rng <- scales::train_continuous(x, c(-Inf, Inf))
    if (any(!is.finite(rng))) {
      return(numeric())
    }

    trans_rng <- trans$transform(rng)
    trans_breaks <- seq.int(trans_rng[1], trans_rng[2], length.out = n)

    # replace ends with rng
    breaks <- trans$inverse(trans_breaks)
    c(rng[1], breaks[-c(1, n)], rng[2])
  }

  structure(breaks_fn, trans = trans)
}


#' @rdname breaks_trans
#' @usage NULL
#' @export
trans_breaks <- breaks_trans


#' Breaks linear
#'
#' Generate a breaks vector of size `n` with linearly spaced breaks.
#'
#' @details
#' If input range is non-finite, an empty vector is returned.
#'
#' @examples
#' breaks_linear(5)(-10:10)
#' breaks_linear()(-1:1)
#'
#' @name breaks_linear
#' @inheritParams breaks_trans
#'
#' @family breaks
#' @export
breaks_linear <- function(n = 10) {
  breaks_trans(n, scales::identity_trans())
}


#' @rdname breaks_linear
#' @usage NULL
#' @export
linear_breaks <- breaks_linear


#' Breaks power
#'
#' Generate a breaks vector of size `n` with exponentially [power_trans] spaced breaks.
#'
#' @examples
#' breaks_power(5)(-10:10)
#' breaks_power(5, exponent = 1 / 3)(-1:1)
#'
#' @name breaks_power
#' @inherit breaks_linear
#' @inheritParams power_trans
#'
#' @family breaks
#' @export
breaks_power <- function(n = 10, exponent = 0.5) {
  breaks_trans(n, power_trans(exponent))
}


#' @rdname breaks_power
#' @usage NULL
#' @export
power_breaks <- breaks_power


#' Breaks log
#'
#' Generate a breaks vector of size `n` with log [log_trans] spaced breaks.
#'
#' @details
#' Input range must be finite and either be strictly negative or strictly positive;
#' it must not cross, nor include 0.
#'
#' If input range is non-finite, an empty vector is returned.
#'
#' @note
#' This function has a different goal to [scales::breaks_log]: it produces evenly
#' spaced log-breaks for use with d3-scale, it doesn't produce breaks with pretty
#' labels.
#'
#' @examples
#' breaks_log(5)(-10:-1)
#' breaks_log(5)(1:10)
#'
#' @name breaks_log
#' @inherit breaks_linear
#' @inheritParams log_trans
#'
#' @family breaks
#' @export
breaks_log <- function(n = 10, base = exp(1)) {
  breaks_fn <- breaks_trans(n, log_trans(base))
  n_default <- n

  wrapper_fn <- function(x, n = n_default) {
    tidyassert::assert(
      suppressWarnings(min(x, na.rm = TRUE) > 0 | max(x, na.rm = TRUE) < 0),
      "range must not contain, nor cross 0"
    )

    breaks_fn(x, n)
  }

  structure(wrapper_fn, trans = attr(breaks_fn, "trans"))
}


#' @rdname breaks_log
#' @usage NULL
#' @export
log_breaks <- breaks_log


#' Breaks symlog
#'
#' Generate a breaks vector of size `n` with log1p [symlog_trans] spaced breaks.
#'
#' @examples
#' breaks_symlog(5)(-10:10)
#' breaks_symlog(5)(0:10)
#'
#' @name breaks_symlog
#' @inherit breaks_linear
#'
#' @family breaks
#' @export
breaks_symlog <- function(n = 10) {
  breaks_trans(n, symlog_trans())
}


#' @rdname breaks_symlog
#' @usage NULL
#' @export
symlog_breaks <- breaks_symlog


# Generate a breaks vector for the given probs
quantile_breaks <- function(probs) {
  tidyassert::assert(is.numeric(probs) && min(probs) >= 0 && max(probs) <= 1 && !is.unsorted(probs))
  probs <- unique(c(0, probs, 1))

  function(x) {
    if (any(!is.finite(x))) {
      return(numeric())
    }

    stats::quantile(x, probs = probs, names = FALSE)
  }
}


# coerce breaks into a breaks function
as_breaks <- function(breaks) UseMethod("as_breaks")
as_breaks.NULL <- function(breaks) NULL
as_breaks.function <- function(breaks) breaks
as_breaks.integer <- function(breaks) breaks_manual(breaks)
as_breaks.numeric <- function(breaks) breaks_manual(breaks)