arkhe coverage - 92.67%

Files
Source

# GENERIC METHODS

# Data preparation =============================================================
## Count -----------------------------------------------------------------------
#' Count Values Using a Predicate
#'
#' Counts values by rows/columns using a predicate function.
#' @param x An \R object (should be a [`matrix`] or a [`data.frame`]).
#' @param f A predicate [`function`].
#' @param margin A length-one [`numeric`] vector giving the subscripts which the
#'  function will be applied over (`1` indicates rows, `2` indicates columns).
#' @param negate A [`logical`] scalar: should the negation of `f` be used
#'  instead of `f`?
#' @param na.rm A [`logical`] scalar: should `NA` values be stripped before the
#'  computation proceeds?
#' @param ... Further arguments to be passed to `f`.
#' @return A [`numeric`] vector.
#' @example inst/examples/ex-count.R
#' @author N. Frerebeau
#' @docType methods
#' @family data preparation tools
#' @aliases count-method
setGeneric(
  name = "count",
  def = function(x, ...) standardGeneric("count")
)

## Detect ----------------------------------------------------------------------
#' Find Rows/Columns Using a Predicate
#'
#' Finds rows/columns in an array-like object using a predicate function.
#' @inheritParams count
#' @param all A [`logical`] scalar. If `TRUE`, only the rows/columns whose
#'  values all meet the condition defined by `f` are considered. If `FALSE`
#'  (the default), only rows/columns where at least one value validates the
#'  condition defined by `f` are considered.
#' @param ... Further arguments to be passed to `f`.
#' @return A [`logical`] vector.
#' @example inst/examples/ex-detect.R
#' @author N. Frerebeau
#' @docType methods
#' @family data preparation tools
#' @aliases detect-method
setGeneric(
  name = "detect",
  def = function(x, ...) standardGeneric("detect")
)

## Keep ------------------------------------------------------------------------
#' Keep Rows/Columns Using a Predicate
#'
#' Keeps rows/columns in an array-like object using a predicate function.
#' @inheritParams detect
#' @param verbose A [`logical`] scalar: should \R report extra information
#'  on progress?
#' @example inst/examples/ex-keep.R
#' @author N. Frerebeau
#' @docType methods
#' @family data preparation tools
#' @aliases keep-method
setGeneric(
  name = "keep",
  def = function(x, ...) standardGeneric("keep")
)

#' @rdname keep
#' @aliases keep_columns-method
setGeneric(
  name = "keep_columns",
  def = function(x, ...) standardGeneric("keep_columns")
)

#' @rdname keep
#' @aliases keep_rows-method
setGeneric(
  name = "keep_rows",
  def = function(x, ...) standardGeneric("keep_rows")
)

## Discard ---------------------------------------------------------------------
#' Remove Rows/Columns Using a Predicate
#'
#' Removes rows/columns in an array-like object using a predicate function.
#' @inheritParams detect
#' @param verbose A [`logical`] scalar: should \R report extra information
#'  on progress?
#' @example inst/examples/ex-discard.R
#' @author N. Frerebeau
#' @docType methods
#' @family data preparation tools
#' @aliases discard-method
setGeneric(
  name = "discard",
  def = function(x, ...) standardGeneric("discard")
)

#' @rdname discard
#' @aliases discard_columns-method
setGeneric(
  name = "discard_columns",
  def = function(x, ...) standardGeneric("discard_columns")
)

#' @rdname discard
#' @aliases discard_rows-method
setGeneric(
  name = "discard_rows",
  def = function(x, ...) standardGeneric("discard_rows")
)

## Compact ---------------------------------------------------------------------
#' Remove Empty Rows/Columns
#'
#' Removes empty rows/columns in an array-like object.
#' @inheritParams detect
#' @param verbose A [`logical`] scalar: should \R report extra information
#'  on progress?
#' @param ... Currently not used.
#' @details
#'  A row/column is empty if it contains only zeros (if of type `numeric`)
#'  or zero length character strings (if of type `character`).
#' @example inst/examples/ex-compact.R
#' @author N. Frerebeau
#' @docType methods
#' @family data preparation tools
#' @aliases compact-method
setGeneric(
  name = "compact",
  def = function(x, ...) standardGeneric("compact")
)

#' @rdname compact
#' @aliases compact_columns-method
setGeneric(
  name = "compact_columns",
  def = function(x, ...) standardGeneric("compact_columns")
)

#' @rdname compact
#' @aliases compact_rows-method
setGeneric(
  name = "compact_rows",
  def = function(x, ...) standardGeneric("compact_rows")
)

## Seek ------------------------------------------------------------------------
#' Search Rows/Columns by Name
#'
#' Searches rows/columns by name in an array-like object.
#' @param x An \R object (should be a [`matrix`] or a [`data.frame`]).
#' @param select A [`function`] to be applied to the row/column names
#'  (e.g. [startsWith()]) that returns an `integer` or `logical` vector.
#' @param names A [`character`] vector of row/column names to look for.
#'  Only used if `select` is `NULL`.
#' @param ... Further arguments to be passed to `select`.
#' @return
#'  An [`integer`] vector or `NULL`.
#' @example inst/examples/ex-seek.R
#' @author N. Frerebeau
#' @docType methods
#' @family data preparation tools
#' @name seek
#' @rdname seek
NULL

#' @rdname seek
#' @aliases seek_columns-method
setGeneric(
  name = "seek_columns",
  def = function(x, ...) standardGeneric("seek_columns")
)

#' @rdname seek
#' @aliases seek_rows-method
setGeneric(
  name = "seek_rows",
  def = function(x, ...) standardGeneric("seek_rows")
)

## Get -------------------------------------------------------------------------
#' Get Rows/Columns by Name
#'
#' Returns rows/columns selected by name in an array-like object.
#' @inheritParams seek
#' @return An object of the same sort as `x`.
#' @example inst/examples/ex-seek.R
#' @author N. Frerebeau
#' @docType methods
#' @family data preparation tools
#' @name get
#' @rdname get
NULL

#' @rdname get
#' @aliases get_columns-method
setGeneric(
  name = "get_columns",
  def = function(x, ...) standardGeneric("get_columns")
)

#' @rdname get
#' @aliases get_rows-method
setGeneric(
  name = "get_rows",
  def = function(x, ...) standardGeneric("get_rows")
)

## Assign ----------------------------------------------------------------------
#' Assign a Specific Row/Column to the Column/Row Names
#'
#' @param x A [`data.frame`].
#' @param row A length-one [`numeric`] vector specifying the row number that is
#'  to become the column names.
#' @param column A length-one [`numeric`] vector specifying the column number
#'  that is to become the row names.
#' @param remove A [`logical`] scalar: should the specified row/column be removed
#'  after making it the column/row names?
#' @param ... Currently not used.
#' @example inst/examples/ex-assign.R
#' @return A [`data.frame`].
#' @author N. Frerebeau
#' @docType methods
#' @family data preparation tools
#' @name assign
#' @rdname assign
NULL

#' @rdname assign
#' @aliases assign_colnames-method
setGeneric(
  name = "assign_colnames",
  def = function(x, ...) standardGeneric("assign_colnames")
)

#' @rdname assign
#' @aliases assign_rownames-method
setGeneric(
  name = "assign_rownames",
  def = function(x, ...) standardGeneric("assign_rownames")
)

## Append ----------------------------------------------------------------------
#' Convert Row Names to an Explicit Column
#'
#' @param x A [`data.frame`].
#' @param after A length-one [`numeric`] vector specifying a subscript,
#'  after which the row names are to be appended.
#' @param var A [`character`] string giving the name of name of the new column.
#' @param remove A [`logical`] scalar: should the row names be removed?
#' @param ... Currently not used.
#' @example inst/examples/ex-assign.R
#' @return A [`data.frame`].
#' @author N. Frerebeau
#' @docType methods
#' @family data preparation tools
#' @aliases append_rownames-method
setGeneric(
  name = "append_rownames",
  def = function(x, ...) standardGeneric("append_rownames")
)

#' Add a (Named) Vector as a Column
#'
#' @param x A [`data.frame`].
#' @param column A (named) `vector`.
#' @param after An [`integer`] specifying a subscript, after which the new
#'  column is to be appended.
#' @param var A [`character`] string giving the name of the new column.
#' @param ... Currently not used.
#' @details
#'  If `column` is named, names will be matched to the row names of `x`. Only
#'  the first match is retained, and elements of `column` without a match are
#'  removed. This allows to add as a column a vector whose length is less than
#'  the number of rows in `x` (`NA`s will be inserted).
#' @example inst/examples/ex-append.R
#' @return A [`data.frame`].
#' @author N. Frerebeau
#' @docType methods
#' @family data preparation tools
#' @aliases append_column-method
setGeneric(
  name = "append_column",
  def = function(x, ...) standardGeneric("append_column")
)

# Data cleaning ================================================================
## NA --------------------------------------------------------------------------
#' Remove Rows/Columns with Missing Values
#'
#' Removes rows/columns that contain [missing values][NA].
#' @inheritParams detect
#' @param verbose A [`logical`] scalar: should \R report extra information
#'  on progress?
#' @param ... Currently not used.
#' @example inst/examples/ex-missing.R
#' @author N. Frerebeau
#' @docType methods
#' @family data cleaning tools
#' @aliases remove_NA-method
#' @aliases missing
setGeneric(
  name = "remove_NA",
  def = function(x, ...) standardGeneric("remove_NA")
)

#' Replace Missing Values
#'
#' Replaces [missing values][NA] values.
#' @inheritParams detect
#' @param value A possible replacement value.
#' @param ... Currently not used.
#' @example inst/examples/ex-missing.R
#' @author N. Frerebeau
#' @docType methods
#' @family data cleaning tools
#' @aliases replace_NA-method
setGeneric(
  name = "replace_NA",
  def = function(x, ...) standardGeneric("replace_NA")
)

## Inf -------------------------------------------------------------------------
#' Remove Rows/Columns with Infinite Values
#'
#' Removes rows/columns that contain [infinite values][is.finite].
#' @inheritParams detect
#' @param verbose A [`logical`] scalar: should \R report extra information
#'  on progress?
#' @param ... Currently not used.
#' @example inst/examples/ex-infinite.R
#' @author N. Frerebeau
#' @docType methods
#' @family data cleaning tools
#' @aliases remove_Inf-method
setGeneric(
  name = "remove_Inf",
  def = function(x, ...) standardGeneric("remove_Inf")
)

#' Replace Infinite Values
#'
#' Replaces [infinite values][is.finite] values.
#' @inheritParams detect
#' @param value A possible replacement value.
#' @param ... Currently not used.
#' @example inst/examples/ex-infinite.R
#' @author N. Frerebeau
#' @docType methods
#' @family data cleaning tools
#' @aliases replace_Inf-method
setGeneric(
  name = "replace_Inf",
  def = function(x, ...) standardGeneric("replace_Inf")
)

## Zeros -----------------------------------------------------------------------
#' Remove Rows/Columns with Zeros
#'
#' Removes rows/columns that contain zeros.
#' @inheritParams detect
#' @param verbose A [`logical`] scalar: should \R report extra information
#'  on progress?
#' @param ... Currently not used.
#' @example inst/examples/ex-zero.R
#' @author N. Frerebeau
#' @docType methods
#' @family data cleaning tools
#' @aliases remove_zero-method
#' @aliases zero
setGeneric(
  name = "remove_zero",
  def = function(x, ...) standardGeneric("remove_zero")
)

#' Replace Zeros
#'
#' Replaces zeros.
#' @inheritParams detect
#' @param value A possible replacement value.
#' @param ... Currently not used.
#' @example inst/examples/ex-zero.R
#' @author N. Frerebeau
#' @docType methods
#' @family data cleaning tools
#' @aliases replace_zero-method
setGeneric(
  name = "replace_zero",
  def = function(x, ...) standardGeneric("replace_zero")
)

## Empty string ----------------------------------------------------------------
#' Remove Rows/Columns with Empty String
#'
#' Removes rows/columns that contain empty strings.
#' @inheritParams detect
#' @param verbose A [`logical`] scalar: should \R report extra information
#'  on progress?
#' @param ... Currently not used.
#' @example inst/examples/ex-empty.R
#' @author N. Frerebeau
#' @docType methods
#' @family data cleaning tools
#' @aliases remove_empty-method
setGeneric(
  name = "remove_empty",
  def = function(x, ...) standardGeneric("remove_empty")
)

#' Replace Empty String
#'
#' Replaces empty strings.
#' @inheritParams detect
#' @param value A possible replacement value.
#' @param ... Currently not used.
#' @example inst/examples/ex-empty.R
#' @author N. Frerebeau
#' @docType methods
#' @family data cleaning tools
#' @aliases replace_empty-method
setGeneric(
  name = "replace_empty",
  def = function(x, ...) standardGeneric("replace_empty")
)

## Constant --------------------------------------------------------------------
#' Remove Constant Columns
#'
#' @param x An \R object (should be a [`matrix`] or a [`data.frame`]).
#' @param na.rm A [`logical`] scalar: should `NA` values be stripped before the
#'  computation proceeds?
#' @param verbose A [`logical`] scalar: should \R report extra information
#'  on progress?
#' @param ... Currently not used.
#' @example inst/examples/ex-constant.R
#' @author N. Frerebeau
#' @docType methods
#' @family data cleaning tools
#' @aliases remove_constant-method
setGeneric(
  name = "remove_constant",
  def = function(x, ...) standardGeneric("remove_constant")
)

## Whitespace ------------------------------------------------------------------
#' Remove Leading/Trailing Whitespace
#'
#' @param x An \R object (should be a [`matrix`] or a [`data.frame`]).
#' @param which A [`character`] string specifying whether to remove `both`
#'  leading and trailing whitespace (default), or only leading ("`left`") or
#'  trailing ("`right`").
#' @param squish A [`logical`] scalar: should all internal whitespace be
#'  replaced with a single space?
#' @param ... Currently not used.
#' @example inst/examples/ex-whitespace.R
#' @seealso [trimws()]
#' @author N. Frerebeau
#' @docType methods
#' @family data cleaning tools
#' @aliases clean_whitespace-method
setGeneric(
  name = "clean_whitespace",
  def = function(x, ...) standardGeneric("clean_whitespace")
)

# Data summary =================================================================
#' Data Description
#'
#' Describes an object.
#' @param x An \R object (should be a [`matrix`] or a [`data.frame`]).
#' @param ... Currently not used.
#' @return
#'  `describe()` is called for its side-effects. Invisibly returns `x`.
#' @example inst/examples/ex-describe.R
#' @author N. Frerebeau
#' @docType methods
#' @family data summaries
#' @aliases describe-method
setGeneric(
  name = "describe",
  def = function(x, ...) standardGeneric("describe")
)

#' Sparsity
#'
#' Computes data sparsity (proportion of zeros).
#' @param x An \R object (should be a [`matrix`] or a [`data.frame`]).
#' @param count A [`logical`] scalar: should a count be returned instead of a
#'  proportion?
#' @param ... Currently not used.
#' @details
#'  If `x` is a `data.frame`, sparsity is computed on `numeric` variables only.
#' @return
#'  A length-one [`numeric`] vector.
#' @example inst/examples/ex-describe.R
#' @author N. Frerebeau
#' @docType methods
#' @family data summaries
#' @aliases sparsity-method
setGeneric(
  name = "sparsity",
  def = function(x, ...) standardGeneric("sparsity")
)

# Mathematics ==================================================================
#' Least Common Multiple
#'
#' Computes the lowest common multiple of the denominators of a set of
#' fractions.
#' @param x,y A [`numeric`] vector.
#' @return A [`numeric`] vector.
#' @author N. Frerebeau
#' @docType methods
#' @family mathematic functions
#' @aliases math_lcm-method
setGeneric(
  name = "math_lcm",
  def = function(x, y) standardGeneric("math_lcm")
)

#' Greatest Common Divisor
#'
#' Computes the greatest common divisor (GCD) of two integer using the Euclidean
#' algorithm.
#' @param x,y A [`numeric`] vector.
#' @return A [`numeric`] vector.
#' @author N. Frerebeau
#' @docType methods
#' @family mathematic functions
#' @aliases math_gcd-method
setGeneric(
  name = "math_gcd",
  def = function(x, y) standardGeneric("math_gcd")
)

# Statistics ===================================================================
## Interval --------------------------------------------------------------------
#' Highest Density Regions
#'
#' @param x A [`numeric`] vector giving the coordinates of the points where
#'  the density is estimated.
#' @param y A [`numeric`] vector giving the estimated density values.
#'  If `y` is missing and `x` is a `numeric` vector, density estimates will be
#'  computed from `x`.
#' @param level A length-one [`numeric`] vector giving the confidence level.
#' @param ... Further arguments to be passed to [stats::density()].
#' @return
#'  A three-columns `numeric` [`matrix`] giving the lower and upper boundaries
#'  of the HPD interval and associated probabilities.
#' @references
#'  Hyndman, R. J. (1996). Computing and graphing highest density regions.
#'  *American Statistician*, 50: 120-126. \doi{10.2307/2684423}.
#' @example inst/examples/ex-interval.R
#' @author N. Frerebeau
#' @family summary statistics
#' @docType methods
#' @aliases interval_hdr-method
setGeneric(
  name = "interval_hdr",
  def = function(x, y, ...) standardGeneric("interval_hdr")
)

#' Bayesian Credible Interval
#'
#' Computes the shortest credible interval within which an unobserved parameter
#' value falls with a particular probability.
#' @param x A [`numeric`] vector.
#' @param level A length-one [`numeric`] vector giving the confidence level.
#' @param ... Currently not used.
#' @return
#'  A three-columns `numeric` [`matrix`] giving the lower and upper boundaries
#'  of the credible interval and associated probability.
#' @example inst/examples/ex-interval.R
#' @author N. Frerebeau
#' @family summary statistics
#' @docType methods
#' @aliases interval_credible-method
setGeneric(
  name = "interval_credible",
  def = function(x, ...) standardGeneric("interval_credible")
)

## Confidence ------------------------------------------------------------------
#' Confidence Interval for a Mean
#'
#' Computes a confidence interval for a mean at a desired level of significance.
#' @param object A [`numeric`] vector.
#' @param level A length-one [`numeric`] vector giving the confidence level.
#'  Must be a single number between \eqn{0} and \eqn{1}.
#' @param type A [`character`] string giving the type of confidence
#'  interval to be returned. It must be one "`student`" (the default) or
#'  "`normal`". Any unambiguous substring can be given.
#' @param ... Currently not used.
#' @return A length-two [`numeric`] vector giving the lower and upper confidence
#'  limits.
#' @example inst/examples/ex-statistics.R
#' @author N. Frerebeau
#' @docType methods
#' @family summary statistics
#' @aliases confidence_mean-method
setGeneric(
  name = "confidence_mean",
  def = function(object, ...) standardGeneric("confidence_mean")
)

#' Confidence Interval for Binomial Proportions
#'
#' Computes Wald interval for a proportion at a desired level of significance.
#' @param object A [`numeric`] vector giving the number of success.
#' @param n A length-one [`numeric`] vector giving the number of trials.
#' @param level A length-one [`numeric`] vector giving the confidence level.
#'  Must be a single number between \eqn{0} and \eqn{1}.
#' @param method A [`character`] string specifying the method to be used.
#'  Any unambiguous substring can be used.
#' @param corrected A [`logical`] scalar: should continuity correction be used?
#'  Only used if `method` is "`wald`".
#' @param ... Currently not used.
#' @return A length-two [`numeric`] vector giving the lower and upper confidence
#'  limits.
#' @example inst/examples/ex-statistics.R
#' @author N. Frerebeau
#' @docType methods
#' @family summary statistics
#' @aliases confidence_binomial-method
setGeneric(
  name = "confidence_binomial",
  def = function(object, ...) standardGeneric("confidence_binomial")
)

#' Confidence Interval for Multinomial Proportions
#'
#' Computes Wald interval for a proportion at a desired level of significance.
#' @param object A [`numeric`] vector of positive integers giving the number of
#'  occurrences of each class.
#' @param level A length-one [`numeric`] vector giving the confidence level.
#'  Must be a single number between \eqn{0} and \eqn{1}.
#' @param method A [`character`] string specifying the method to be used.
#'  Any unambiguous substring can be used.
#' @param corrected A [`logical`] scalar: should continuity correction be used?
#'  Only used if `method` is "`wald`".
#' @param ... Currently not used.
#' @return A two column [`numeric`] `matrix` giving the lower and upper
#'  confidence limits.
#' @example inst/examples/ex-statistics.R
#' @author N. Frerebeau
#' @docType methods
#' @family summary statistics
#' @aliases confidence_multinomial-method
setGeneric(
  name = "confidence_multinomial",
  def = function(object, ...) standardGeneric("confidence_multinomial")
)

#' Nonparametric Bootstrap Confidence Interval
#'
#' Computes equi-tailed two-sided nonparametric confidence interval.
#' @param object A [`numeric`] vector giving the bootstrap replicates of the
#'  statistic of interest.
#' @param level A length-one [`numeric`] vector giving the confidence level.
#'  Must be a single number between \eqn{0} and \eqn{1}.
#' @param type A [`character`] string giving the type of confidence
#'  interval to be returned. It must be one "`basic`" (the default),
#'  "`student`", "`normal`" or "`percentiles`". Any unambiguous substring can be
#'  given.
#' @param t0 A length-one [`numeric`] vector giving the observed value of the
#'  statistic of interest. Must be defined if `type` is "`basic`", "`student`"
#'  or "`normal`".
#' @param var_t0 A length-one [`numeric`] vector giving an estimate of the
#'  variance of the statistic of interest. Must be defined if `type` is
#'  "`student`". If `var_t0` is undefined and `type` is "`normal`, it defaults
#'  to `var(object)`.
#' @param var_t A [`numeric`] vector giving the variances of the bootstrap
#'  replicates of the variable of interest. Must be defined if `type` is
#' "`student`".
#' @param ... Currently not used.
#' @return A length-two [`numeric`] vector giving the lower and upper confidence
#'  limits.
#' @references
#'  Davison, A. C. & Hinkley, D. V. (1997). *Bootstrap Methods and Their
#'  Application*. Cambridge Series on Statistical and Probabilistic Mathematics.
#'  Cambridge: Cambridge University Press.
#' @seealso [bootstrap()]
#' @example inst/examples/ex-bootstrap.R
#' @author N. Frerebeau
#' @docType methods
#' @family summary statistics
#' @aliases confidence_bootstrap-method
setGeneric(
  name = "confidence_bootstrap",
  def = function(object, ...) standardGeneric("confidence_bootstrap")
)

# Resampling ===================================================================
#' Draw Uniform Random Sample
#'
#' Draws a random (sub)sample (with or without replacement).
#' @param object A [`numeric`] vector.
#' @param n A non-negative [`integer`] specifying the number of random vector
#'  to draw.
#' @param size A non-negative [`integer`] specifying the sample size.
#' @param replace A [`logical`] scalar: should sampling be with replacement?
#' @param ... Currently not used.
#' @return
#'  A `numeric` [`matrix`] with `n` rows and `size` columns.
#' @example inst/examples/ex-resample.R
#' @author N. Frerebeau
#' @docType methods
#' @family resampling methods
#' @aliases resample_uniform-method
setGeneric(
  name = "resample_uniform",
  def = function(object, ...) standardGeneric("resample_uniform")
)

#' Draw Multinomial Random Sample
#'
#' Draws a random (sub)sample from a multinomial distribution.
#' @param object A length-\eqn{k} [`integer`] vector, specifying the probability
#'  for the \eqn{k} classes; is internally normalized to sum to 1.
#' @param n A non-negative [`integer`] specifying the number of random vector
#'  to draw.
#' @param size A non-negative [`integer`] specifying the sample size.
#' @param ... Currently not used.
#' @return
#'  A `numeric` [`matrix`] with `n` rows and `k` columns.
#' @seealso [stats::rmultinom()]
#' @example inst/examples/ex-resample.R
#' @author N. Frerebeau
#' @docType methods
#' @family resampling methods
#' @aliases resample_multinomial-method
setGeneric(
  name = "resample_multinomial",
  def = function(object, ...) standardGeneric("resample_multinomial")
)

## Bootstrap -------------------------------------------------------------------
#' Nonparametric Bootstrap Estimation
#'
#' Samples randomly from the elements of `object` with replacement.
#' @param object A [`numeric`] vector.
#' @param do A [`function`] that takes `object` as an argument and returns a
#'  single numeric value.
#' @param n A non-negative [`integer`] giving the number of bootstrap
#'  replications.
#' @param f A [`function`] that takes a single numeric vector (the result of
#'  `do`) as argument.
#' @param level A length-one [`numeric`] vector giving the confidence level.
#'  Must be a single number between \eqn{0} and \eqn{1}. Only used if `f` is
#'  `NULL`.
#' @param interval A [`character`] string giving the type of confidence
#'  interval to be returned. It must be one "`basic`" (the default), "`normal`"
#'  or "`percentiles`" (see [confidence_bootstrap()]). Any unambiguous substring
#'  can be given. Only used if `f` is `NULL`.
#' @param ... Extra arguments to be passed to `do`.
#' @return
#'  If `f` is `NULL` (the default), `bootstrap()` returns a named `numeric`
#'  vector with the following elements:
#'  \describe{
#'   \item{`original`}{The observed value of `do` applied to `object`.}
#'   \item{`mean`}{The bootstrap estimate of mean of `do`.}
#'   \item{`bias`}{The bootstrap estimate of bias of `do`.}
#'   \item{`error`}{The bootstrap estimate of standard error of `do`.}
#'   \item{`lower`}{The lower limit of the bootstrap confidence interval at `level`.}
#'   \item{`upper`}{The upper limit of the bootstrap confidence interval at `level`.}
#'  }
#'
#'  If `f` is a `function`, `bootstrap()` returns the result of `f` applied to
#'  the `n` values of `do`.
#' @references
#'  Davison, A. C. & Hinkley, D. V. (1997). *Bootstrap Methods and Their
#'  Application*. Cambridge Series on Statistical and Probabilistic Mathematics.
#'  Cambridge: Cambridge University Press.
#' @seealso [confidence_bootstrap()]
#' @example inst/examples/ex-bootstrap.R
#' @author N. Frerebeau
#' @docType methods
#' @family resampling methods
#' @aliases bootstrap-method
setGeneric(
  name = "bootstrap",
  def = function(object, ...) standardGeneric("bootstrap")
)

## Jackknife -------------------------------------------------------------------
#' Jackknife Estimation
#'
#' @param object A [`numeric`] vector.
#' @param do A [`function`] that takes `object` as an argument and returns a
#'  single numeric value.
#' @param ... Extra arguments to be passed to `do`.
#' @param f A [`function`] that takes a single numeric vector (the leave-one-out
#'  values of `do`) as argument.
#' @return
#'  If `f` is `NULL` (the default), `jackknife()` returns a named `numeric`
#'  vector with the following elements:
#'  \describe{
#'   \item{`original`}{The observed value of `do` applied to `object`.}
#'   \item{`mean`}{The jackknife estimate of mean of `do`.}
#'   \item{`bias`}{The jackknife estimate of bias of `do`.}
#'   \item{`error`}{The jackknife estimate of standard error of `do`.}
#'  }
#'
#'  If `f` is a `function`, `jackknife()` returns the result of `f` applied to
#'  the leave-one-out values of `do`.
#' @example inst/examples/ex-jackknife.R
#' @author N. Frerebeau
#' @docType methods
#' @family resampling methods
#' @aliases jackknife-method
setGeneric(
  name = "jackknife",
  def = function(object, ...) standardGeneric("jackknife")
)

# STATISTICS
#' @include AllGenerics.R
NULL

# HPDI =========================================================================
#' @export
#' @rdname interval_hdr
#' @aliases interval_hdr,numeric,numeric-method
setMethod(
  f = "interval_hdr",
  signature = c(x = "numeric", y = "numeric"),
  definition = function(x, y, level = 0.954) {
    ## Compute density
    y <- y / sum(y)

    ## Order the sample (faster sorting with radix method)
    sorted <- sort(y, decreasing = TRUE, method = "radix")
    i <- min(which(cumsum(sorted) >= sum(y) * level))
    h <- sorted[[i]]
    idx <- which(y >= h)

    gap <- which(diff(idx) > 1)
    inf <- idx[c(1, gap + 1)]
    sup <- idx[c(gap, length(idx))]

    int <- mapply(FUN = seq, from = inf, to = sup,
                  SIMPLIFY = FALSE, USE.NAMES = FALSE)
    p <- vapply(X = int, FUN = function(i, y) { sum(y[i]) },
                FUN.VALUE = numeric(1), y = y)

    cbind(start = x[inf], end = x[sup], p = round(p, digits = 2))
  }
)

#' @export
#' @rdname interval_hdr
#' @aliases interval_hdr,numeric,missing-method
setMethod(
  f = "interval_hdr",
  signature = c(x = "numeric", y = "missing"),
  definition = function(x, level = 0.954, ...) {
    ## Compute density
    d <- stats::density(x, ...)
    methods::callGeneric(x = d$x, y = d$y, level = level)
  }
)

# Credible interval ============================================================
#' @export
#' @rdname interval_credible
#' @aliases interval_credible,numeric-method
setMethod(
  f = "interval_credible",
  signature = "numeric",
  definition = function(x, level = 0.95) {
    ## Order the sample
    sorted <- sort(x, method = "radix") # Faster sorting with radix method

    ## Sample size
    N <- length(x)

    ## Number of data to be outside of the interval
    outside <- as.integer(N * (1 - level))
    inf <- seq(from = 1L, to = outside + 1L, by = 1L)
    sup <- seq(from = N - outside, to = N, by = 1L)

    ## Look for the shortest interval
    a <- sorted[sup]
    b <- sorted[inf]
    ind <- which.min(a - b)

    cbind(start = b[[ind]], end = a[[ind]], p = level)
  }
)

# Confidence interval ==========================================================
#' @export
#' @rdname confidence_mean
#' @aliases confidence_mean,numeric-method
setMethod(
  f = "confidence_mean",
  signature = c(object = "numeric"),
  definition = function(object, level = 0.95, type = c("student", "normal")) {
    ## Validation
    assert_scalar(level, "numeric")

    z <- zscore(level = level, n = length(object), type = type)
    margin <- z * stats::sd(object) / sqrt(length(object))
    interval <- mean(object) + margin * c(-1, 1)
    names(interval) <- c("lower", "upper")
    interval
  }
)

zscore <- function(level, n, type = c("student", "normal")) {
  ## Validation
  type <- match.arg(type, several.ok = FALSE)

  alpha <- 1 - level
  switch(
    type,
    normal = stats::qnorm(1 - alpha / 2), # Large sample size
    student = stats::qt(1 - alpha / 2, df = n - 1), # Small sample size
  )
}

#' @export
#' @rdname confidence_binomial
#' @aliases confidence_binomial,numeric-method
setMethod(
  f = "confidence_binomial",
  signature = c(object = "numeric"),
  definition = function(object, n, level = 0.95, method = "wald",
                        corrected = FALSE) {
    ## Validation
    assert_scalar(level, "numeric")
    method <- match.arg(method, several.ok = FALSE)

    p <- object / n
    q <- 1 - p
    alpha <- 1 - level

    z <- stats::qnorm(1 - alpha / 2)
    margin <- z * sqrt(p * q / n)
    if (corrected) {
      margin <- margin + 1 / (2 * n) # Wald with continuity correction
    }

    interval <- c(lower = pmax(0, p - margin), upper = pmin(1, p + margin))
    interval
  }
)

#' @export
#' @rdname confidence_multinomial
#' @aliases confidence_multinomial,numeric-method
setMethod(
  f = "confidence_multinomial",
  signature = c(object = "numeric"),
  definition = function(object, level = 0.95, method = "wald",
                        corrected = FALSE) {
    ## Validation
    assert_scalar(level, "numeric")
    method <- match.arg(method, several.ok = FALSE)

    n <- sum(object)
    f <- switch (
      method,
      wald = function(x) confidence_binomial(x, n = n, level = level,
                                             method = "wald",
                                             corrected = corrected)
    )

    interval <- vapply(X = object, FUN = f, FUN.VALUE = numeric(2))
    interval <- t(interval)
    rownames(interval) <- names(object)
    interval
  }
)

#' @export
#' @rdname confidence_bootstrap
#' @aliases confidence_bootstrap,numeric-method
setMethod(
  f = "confidence_bootstrap",
  signature = c(object = "numeric"),
  definition = function(object, level = 0.95,
                        type = c("basic", "normal", "student", "percentiles"),
                        t0 = NULL, var_t0 = NULL, var_t = NULL, ...) {
    ## Validation
    type <- match.arg(type, several.ok = FALSE)
    assert_scalar(level, "numeric")
    if (is.null(var_t)) {
      fin <- which(is.finite(object))
    } else {
      assert_length(var_t, length(object))
      assert_type(var_t, "numeric")
      fin <- which(is.finite(object) & is.finite(var_t))
      var_t <- var_t[fin]
    }
    object <- object[fin]

    if (type == "percentiles" || type == "basic") {
      ## Percentile confidence interval
      # conf <- stats::quantile(object, probs = probs, names = FALSE)
      probs <- (1 + c(-level, level)) / 2
      conf <- qq(object, probs)
    }
    if (type == "basic") {
      ## Basic bootstrap confidence limits (Davison & Hinkley, 1997)
      assert_scalar(t0, "numeric")
      conf <- 2 * t0 - rev(conf)
    }
    if (type == "normal") {
      ## Normal approximation (Davison & Hinkley, 1997)
      assert_scalar(t0, "numeric")
      if (is.null(var_t0)) var_t0 <- stats::var(object)

      bias <- mean(object) - t0
      zscore <- sqrt(var_t0) * stats::qnorm((1 + level) / 2)
      conf <- c(t0 - bias - zscore, t0 - bias + zscore)
    }
    if (type == "student") {
      ## Studentized bootstrap confidence limits (Davison & Hinkley, 1997)
      assert_scalar(t0, "numeric")
      assert_scalar(var_t0, "numeric")

      probs <- (1 + c(level, -level)) / 2
      zscore <- (object - t0) / sqrt(var_t)
      conf <- t0 - sqrt(var_t0) * qq(zscore, probs)
    }

    names(conf) <- c("lower", "upper")
    conf
  }
)

# Copy non-exported from boot
# Davison and Hinkley (1997), eq. 5.8
qq <- function(x, alpha) {
  x <- x[is.finite(x)]
  R <- length(x)
  rk <- (R + 1) * alpha
  if (!all(rk > 1 & rk < R))
    warning(tr_("Extreme order statistics used as endpoints."), call. = FALSE)
  k <- trunc(rk)
  inds <- seq_along(k)
  out <- inds
  kvs <- k[k > 0 & k < R]
  tstar <- sort(x, partial = sort(union(c(1, R), c(kvs, kvs + 1))))
  ints <- (k == rk)
  if (any(ints)) out[inds[ints]] <- tstar[k[inds[ints]]]
  out[k == 0] <- tstar[1L]
  out[k == R] <- tstar[R]
  not <- function(v) xor(rep(TRUE,length(v)), v)
  temp <- inds[not(ints) & k != 0 & k != R]
  temp1 <- stats::qnorm(alpha[temp])
  temp2 <- stats::qnorm(k[temp] / (R + 1))
  temp3 <- stats::qnorm((k[temp] + 1) / (R + 1))
  tk <- tstar[k[temp]]
  tk1 <- tstar[k[temp] + 1L]
  out[temp] <- tk + (temp1 - temp2) / (temp3 - temp2) * (tk1 - tk)
  out
}

# Bootstrap ====================================================================
#' @export
#' @rdname bootstrap
#' @aliases bootstrap,numeric-method
setMethod(
  f = "bootstrap",
  signature = c(object = "numeric"),
  definition = function(object, do, n, ..., f = NULL, level = 0.95,
                        interval = c("basic", "normal", "percentiles")) {
    interval <- match.arg(interval, several.ok = FALSE)

    hat <- do(object, ...)

    spl <- sample(object, size = length(object) * n, replace = TRUE)
    replicates <- t(matrix(spl, nrow = n))
    values <- apply(X = replicates, MARGIN = 2, FUN = do, ...)

    if (is.function(f)) return(f(values))
    summary_bootstrap(values, hat, level = level, interval = interval)
  }
)

summary_bootstrap <- function(x, hat, level = 0.95, interval = "basic") {
  n <- length(x)
  boot_mean <- mean(x)
  boot_bias <- boot_mean - hat
  boot_error <- stats::sd(x)

  ci <- confidence_bootstrap(x, level = level, t0 = hat, type = interval)
  results <- c(hat, boot_mean, boot_bias, boot_error, ci)
  names(results) <- c("original", "mean", "bias", "error", "lower", "upper")
  results
}

# Jaccknife ====================================================================
#' @export
#' @rdname jackknife
#' @aliases jackknife,numeric-method
setMethod(
  f = "jackknife",
  signature = c(object = "numeric"),
  definition = function(object, do, ..., f = NULL) {
    n <- length(object)
    hat <- do(object, ...)

    values <- vapply(
      X = seq_len(n),
      FUN = function(i, x, do, ...) {
        do(x[-i], ...)
      },
      FUN.VALUE = double(1),
      x = object, do = do, ...
    )

    if (is.function(f)) return(f(values))
    summary_jackknife(values, hat)
  }
)

summary_jackknife <- function(x, hat) {
  n <- length(x)
  jack_mean <- mean(x)
  jack_bias <- (n - 1) * (jack_mean - hat)
  jack_error <- sqrt(((n - 1) / n) * sum((x - jack_mean)^2))

  results <- c(hat, jack_mean, jack_bias, jack_error)
  names(results) <- c("original", "mean", "bias", "error")
  results
}

# Resample =====================================================================
#' @export
#' @rdname resample_uniform
#' @aliases resample_uniform,numeric-method
setMethod(
  f = "resample_uniform",
  signature = c(object = "numeric"),
  definition = function(object, n, size = length(object), replace = FALSE, ...) {
    spl <- replicate(
      n = n,
      expr = sample(object, size = size, replace = replace),
      simplify = FALSE
    )
    do.call(rbind, spl)
  }
)

#' @export
#' @rdname resample_multinomial
#' @aliases resample_multinomial,numeric-method
setMethod(
  f = "resample_multinomial",
  signature = c(object = "numeric"),
  definition = function(object, n, size = sum(object), ...) {
    prob <- object / sum(object)
    t(stats::rmultinom(n, size = size, prob = prob))
  }
)

# DATA CLEANING: KEEP
#' @include AllGenerics.R
NULL

# keep =========================================================================
#' @export
#' @rdname keep
#' @aliases keep,ANY-method
setMethod(
  f = "keep",
  signature = c(x = "ANY"),
  definition = function(x, f, margin = 1, negate = FALSE, all = FALSE,
                        na.rm = FALSE, verbose = getOption("arkhe.verbose"),
                        ...) {
    i <- detect(x, f = f, margin = margin, negate = negate, all = all,
                na.rm = na.rm, ...)
    discard_message(x, keep = i, margin = margin, verbose = verbose)
    if (any(margin == 1)) return(x[i, , drop = FALSE])
    if (any(margin == 2)) return(x[, i, drop = FALSE])
    i
  }
)

#' @export
#' @rdname keep
#' @aliases keep_rows,ANY-method
setMethod(
  f = "keep_rows",
  signature = c(x = "ANY"),
  definition = function(x, f, negate = FALSE, all = FALSE, na.rm = FALSE,
                        verbose = getOption("arkhe.verbose"), ...) {
    keep(x, f, margin = 1, negate = negate, all = all, na.rm = na.rm,
         verbose = verbose, ...)
  }
)

#' @export
#' @rdname keep
#' @aliases keep_columns,ANY-method
setMethod(
  f = "keep_columns",
  signature = c(x = "ANY"),
  definition = function(x, f, negate = FALSE, all = FALSE, na.rm = FALSE,
                        verbose = getOption("arkhe.verbose"), ...) {
    keep(x, f, margin = 2, negate = negate, all = all, na.rm = na.rm,
         verbose = verbose, ...)
  }
)

# DATA CLEANING: DETECT
#' @include AllGenerics.R
NULL

# Detect =======================================================================
#' @export
#' @rdname detect
#' @aliases detect,ANY-method
setMethod(
  f = "detect",
  signature = c(x = "ANY"),
  definition = function(x, f, margin = 1, negate = FALSE, all = FALSE,
                        na.rm = FALSE, ...) {
    total <- count(x, f, margin = margin, negate = negate, na.rm = na.rm, ...)

    miss <- rep(0, length(total))
    if (na.rm) miss <- count(x, f = is.na, margin = margin)

    k <- 1
    if (all) {
      if (any(margin == 1)) k <- ncol(x) - miss
      if (any(margin == 2)) k <- nrow(x) - miss
    }
    total >= k
  }
)

# DATA SUMMARY: DESCRIBE
#' @include AllGenerics.R
NULL

#' @export
#' @rdname describe
#' @aliases describe,ANY-method
setMethod(
  f = "describe",
  signature = c(x = "ANY"),
  definition = function(x) {
    ## Variable types
    msg_var <- describe_variables(x)

    ## Missing values
    msg_miss <- describe_missing(x)

    ## Check
    msg_val <- describe_check(x)

    cat(msg_var, msg_miss, msg_val, sep = "\n")

    # tot <- list(
    #   m = m, p = p,
    #   n_numeric = n_num, n_categorial = n_cha, n_binary = n_bin,
    #   row_missing = m_NA, col_missing = p_NA,
    #   zero_values = spa, zero_variance = p_var
    # )

    invisible(x)
  }
)

describe_variables <- function(x) {
  m <- nrow(x)
  p <- ncol(x)

  msg_rows <- sprintf(ngettext(m, "%d observation", "%d observations"), m)
  msg_cols <- sprintf(ngettext(p, "%d variable", "%d variables"), p)
  title <- sprintf("%s, %s:", msg_rows, msg_cols)

  num <- detect(x, f = is.numeric, margin = 2)
  bin <- detect(x, f = is.logical, margin = 2)
  n_num <- sum(num)
  n_bin <- sum(bin)
  n_cha <- sum(!num & !bin)

  msg_num <- sprintf(ngettext(n_num, "%d numeric variable", "%d numeric variables"), n_num)
  msg_bin <- sprintf(ngettext(n_bin, "%d binary variable", "%d binary variables"), n_bin)
  msg_cha <- sprintf(ngettext(n_cha, "%d categorial variable", "%d categorial variables"), n_cha)

  msg <- paste0(sprintf("\n* %s.", c(msg_num, msg_cha, msg_bin)), collapse = "")
  paste0(title, msg, collapse = "")
}
describe_missing <- function(x) {
  m <- nrow(x)
  p <- ncol(x)

  n_NA <- sum(count(x, f = is.na))
  m_NA <- sum(detect(x, f = is.na, margin = 1))
  p_NA <- sum(detect(x, f = is.na, margin = 2))
  pc <- label_percent(c(m_NA / m, p_NA / p), digits = 1, trim = TRUE)

  title <- sprintf(ngettext(n_NA, "%d missing value:", "%d missing values:"), n_NA)

  rows_NA <- ngettext(m_NA, "%d observation (%s) contains missing values",
                      "%d observations (%s) contain missing values")
  msg_row_NA <- sprintf(rows_NA, m_NA, pc[[1]])

  cols_NA <- ngettext(p_NA, "%d variable (%s) contains missing values",
                      "%d variables (%s) contain missing values")
  msg_col_NA <- sprintf(cols_NA, p_NA, pc[[2]])

  msg <- paste0(sprintf("\n* %s.", c(msg_row_NA, msg_col_NA)), collapse = "")
  paste0("\n", title, msg, collapse = "")
}
describe_check <- function(x) {
  title <- tr_("Data checking:")

  ## Constant columns
  p_var <- sum(detect(x, f = function(x) is_unique(x), margin = 2))
  cols_var <- ngettext(p_var, "%d variable with no variance",
                       "%d variables with no variance")
  msg_col_var <- sprintf(cols_var, p_var)

  ## Sparsity
  spa <- sparsity(x, count = FALSE)
  msg_spa <- sprintf(tr_("%s of numeric values are zero"), label_percent(spa, digits = 1))

  msg <- paste0(sprintf("\n* %s.", c(msg_spa, msg_col_var)), collapse = "")
  paste0("\n", title, msg, collapse = "")
}

#' Label Percentages
#'
#' @param x A [`numeric`] vector.
#' @param digits An [`integer`] indicating the number of decimal places.
#'  If `NULL` (the default), breaks will have the minimum number of digits
#'  needed to show the difference between adjacent values.
#' @param trim A [`logical`] scalar. If `FALSE` (the default), values are
#'  right-justified to a common width (see [base::format()]).
#' @return A [`character`] vector.
#' @keywords internal
#' @export
label_percent <- function(x, digits = NULL, trim = FALSE) {
  i <- !is.na(x)
  y <- x[i]
  y <- abs(y) * 100
  y <- format(y, trim = trim, digits = digits)
  y <- paste0(y, "%")
  x[i] <- y
  x
}

# CHECK DATA INPUT
#' @include predicates.R
NULL

#' Validate a Condition
#'
#' @param expr An object to be evaluated.
#' @return
#'  Returns `NULL` on success, otherwise returns the error as a string.
#' @author N. Frerebeau
#' @family validation methods
#' @name validate
#' @rdname validate
#' @export
validate <- function(expr) {
  cnd <- catch_message(eval(expr))
  if (has_length(cnd)) return(cnd)
  NULL
}

# Packages =====================================================================
#' Check the Availability of a Package
#'
#' @param x A [`character`] vector naming the packages to check.
#' @param ask A [`logical`] scalar: should the user be asked to select packages
#'  before they are downloaded and installed?
#' @details
#'  `assert_package()` is designed for use inside other functions in your own
#'  package to check for the availability of a suggested package.
#'
#'  If the required packages are not available and \R is running interactively,
#'  the user will be asked to install the packages.
#' @return Invisibly returns `NULL`.
#' @family checking methods
#' @author N. Frerebeau
#' @export
assert_package <- function(x, ask = interactive()) {
  ok <- vapply(X = x, FUN = requireNamespace, FUN.VALUE = logical(1),
               quietly = TRUE)

  miss <- x[!ok]
  n <- length(miss)

  if (n > 0) {
    err <- sprintf(
      ngettext(n, "Package %s is required.", "Packages %s are required."),
      paste0(sQuote(miss), collapse = ", ")
    )
    install <- FALSE
    if (isTRUE(ask)) {
      msg <- ngettext(n, "Do you want to install it?", "Do you want to install them?")
      install <- utils::askYesNo(
        msg = paste0(c(err, msg), collapse = "\n"),
        default = FALSE,
        prompts = gettext(c("Yes", "No", "Cancel"))
      )
    }
    if (isTRUE(install)) {
      utils::install.packages(miss)
    } else {
      throw_error("error_missing_package", err)
    }
  }
  invisible(NULL)
}

# Attributes ===================================================================
#' Check Object Length(s)
#'
#' @param x An object to be checked.
#' @param expected An appropriate expected value.
#' @param allow_empty A [`logical`] scalar: should [empty][is_empty()] object be
#'  ignored?
#' @param allow_null A [`logical`] scalar: should `NULL` object be ignored?
#' @param empty Deprecated.
#' @return
#'  Throws an error, if any, and returns `x` invisibly otherwise.
#' @author N. Frerebeau
#' @family checking methods
#' @export
assert_length <- function(x, expected, allow_empty = empty, allow_null = FALSE, empty = FALSE) {
  if (is.null(x) && isTRUE(allow_null)) return(invisible(NULL))

  arg <- deparse(substitute(x))
  if (!(allow_empty && is_empty(x)) && !has_length(x, n = expected)) {
    txt <- tr_("%s must be of length %d; not %d.")
    msg <- sprintf(txt, sQuote(arg), expected, length(x))
    throw_error("error_bad_length", msg)
  }
  invisible(x)
}

#' @export
#' @rdname assert_length
assert_lengths <- function(x, expected) {
  arg <- deparse(substitute(x))
  n <- lengths(x)
  if (!all(n == expected)) {
    txt <- tr_("Elements of %s must be of lengths %s; not %s.")
    msg <- sprintf(txt, sQuote(arg), paste0(expected, collapse = ", "),
                   paste0(n, collapse = ", "))
    throw_error("error_bad_length", msg)
  }
  invisible(x)
}

#' Check Object Dimensions
#'
#' @param x An object to be checked.
#' @param expected An appropriate expected value.
#' @return
#'  Throws an error, if any, and returns `x` invisibly otherwise.
#' @author N. Frerebeau
#' @family checking methods
#' @export
assert_dim <- function(x, expected) {
  arg <- deparse(substitute(x))
  n <- dim(x)
  if (!all(n == expected)) {
    txt <- tr_("%s must be of dimension %s; not %s.")
    msg <- sprintf(txt, sQuote(arg), paste0(expected, collapse = " x "),
                   paste0(n, collapse = " x "))
    throw_error("error_bad_dimensions", msg)
  }
  invisible(x)
}

#' @export
#' @rdname assert_dim
assert_nrow <- function(x, expected) {
  arg <- deparse(substitute(x))
  n <- nrow(x)
  if (n != expected) {
    txt <- ngettext(expected, "%s must have %s row; not %s.",
                    "%s must have %s rows; not %s.")
    msg <- sprintf(txt, sQuote(arg), expected, n)
    throw_error("error_bad_dimensions", msg)
  }
  invisible(x)
}

#' @export
#' @rdname assert_dim
assert_ncol <- function(x, expected) {
  arg <- deparse(substitute(x))
  n <- ncol(x)
  if (n != expected) {
    txt <- ngettext(expected, "%s must have %s column; not %s.",
                    "%s must have %s columns; not %s.")
    msg <- sprintf(txt, sQuote(arg), expected, n)
    throw_error("error_bad_dimensions", msg)
  }
  invisible(x)
}

#' Check Object Filling
#'
#' Checks if an object is (not) empty.
#' @param x An object to be checked.
#' @return
#'  Throws an error, if any, and returns `x` invisibly otherwise.
#' @author N. Frerebeau
#' @family checking methods
#' @export
assert_empty <- function(x) {
  arg <- deparse(substitute(x))
  if (!is_empty(x)) {
    msg <- sprintf(tr_("%s must be empty."), sQuote(arg))
    throw_error("error_bad_dimensions", msg)
  }
  invisible(x)
}

#' @export
#' @rdname assert_empty
assert_filled <- function(x) {
  arg <- deparse(substitute(x))
  if (is_empty(x)) {
    msg <- sprintf(tr_("%s must not be empty."), sQuote(arg))
    throw_error("error_bad_dimensions", msg)
  }
  invisible(x)
}

# Names ========================================================================
#' Check Object Names
#'
#' @param x An object to be checked.
#' @param expected An appropriate expected value.
#' @return
#'  Throws an error, if any, and returns `x` invisibly otherwise.
#' @author N. Frerebeau
#' @family checking methods
#' @export
assert_names <- function(x, expected = NULL) {
  arg <- deparse(substitute(x))
  if (!has_names(x, names = expected)) {
    if (is.null(expected)) {
      msg <- sprintf(tr_("%s must have names."), sQuote(arg))
    } else {
      msg <- sprintf(tr_("%s must have the following names: %s."),
                     sQuote(arg), paste0(expected, collapse = ", "))
    }
    throw_error("error_bad_names", msg)
  }
  invisible(x)
}

#' @export
#' @rdname assert_names
assert_rownames <- function(x, expected = NULL) {
  arg <- deparse(substitute(x))
  if (!has_rownames(x, names = expected)) {
    if (is.null(expected)) {
      msg <- sprintf(tr_("%s must have row names."), sQuote(arg))
    } else {
      msg <- sprintf(tr_("%s must have the following row names: %s."),
                     sQuote(arg), paste0(expected, collapse = ", "))
    }
    throw_error("error_bad_names", msg)
  }
  invisible(x)
}

#' @export
#' @rdname assert_names
assert_colnames <- function(x, expected = NULL) {
  arg <- deparse(substitute(x))
  if (!has_colnames(x, names = expected)) {
    if (is.null(expected)) {
      msg <- sprintf(tr_("%s must have column names."), sQuote(arg))
    } else {
      msg <- sprintf(tr_("%s must have the following column names: %s."),
                     sQuote(arg), paste0(expected, collapse = ", "))
    }
    throw_error("error_bad_names", msg)
  }
  invisible(x)
}

# NA/NaN/Inf/duplicates ========================================================
#' Check Missing Values
#'
#' Checks if an object contains any missing (`NA`, `NaN`) values.
#' @param x An object to be checked.
#' @return
#'  Throws an error, if any, and returns `x` invisibly otherwise.
#' @author N. Frerebeau
#' @family checking methods
#' @export
assert_missing <- function(x) {
  arg <- deparse(substitute(x))
  n <- sum(is.na(x))
  if (n > 0) {
    txt <- ngettext(n, "%s must not contain missing values (%d detected).",
                    "%s must not contain missing values (%d detected).")
    msg <- sprintf(txt, sQuote(arg), n)
    throw_error("error_data_missing", msg)
  }
  invisible(x)
}

#' Check Infinite Values
#'
#' Checks if an object contains any infinite (`Inf`) values.
#' @param x An object to be checked.
#' @return
#'  Throws an error, if any, and returns `x` invisibly otherwise.
#' @author N. Frerebeau
#' @family checking methods
#' @export
assert_infinite <- function(x) {
  arg <- deparse(substitute(x))
  n <- sum(is.infinite(x))
  if (n > 0) {
    txt <- ngettext(n, "%s must not contain infinite values (%d detected).",
                    "%s must not contain infinite values (%d detected).")
    msg <- sprintf(txt, sQuote(arg), n)
    throw_error("error_data_infinite", msg)
  }
  invisible(x)
}

#' Check Duplicates
#'
#' Checks if an object contains duplicated elements.
#' @param x An object to be checked.
#' @return
#'  Throws an error, if any, and returns `x` invisibly otherwise.
#' @author N. Frerebeau
#' @family checking methods
#' @export
assert_unique <- function(x) {
  arg <- deparse(substitute(x))
  if (has_duplicates(x)) {
    msg <- sprintf(tr_("Elements of %s must be unique."), sQuote(arg))
    throw_error("error_data_duplicates", msg)
  }
  invisible(x)
}

# Types ========================================================================
#' Check Data Types
#'
#' @param x An object to be checked.
#' @param expected A [`character`] string specifying the expected
#'  type. It must be one of "`list`", "`atomic`", "`vector`", "`numeric`",
#'  "`integer`", "`double`", "`character`" or "`logical`".
#' @param allow_empty A [`logical`] scalar: should [empty][is_empty()] object be
#'  allowed?
#' @param allow_null A [`logical`] scalar: should `NULL` object be ignored?
#' @return
#'  Throws an error, if any, and returns `x` invisibly otherwise.
#' @author N. Frerebeau
#' @family checking methods
#' @export
assert_type <- function(x, expected, allow_empty = TRUE, allow_null = FALSE) {
  if (is.null(x) && isTRUE(allow_null)) return(invisible(NULL))
  if (isFALSE(allow_empty)) assert_filled(x)

  arg <- deparse(substitute(x))
  msg <- sprintf(tr_("Can't find a predicate for this type: %s."), expected)
  predicate <- switch(
    expected,
    list = is_list,
    atomic = is_atomic,
    vector = is_vector,
    numeric = is_numeric,
    integer = is_integer,
    double = is_double,
    character = is_character,
    logical = is_logical,
    stop(msg, call. = FALSE)
  )
  if (!predicate(x)) {
    msg <- sprintf(tr_("%s must be %s; not %s."), sQuote(arg), expected, typeof(x))
    throw_error("error_bad_type", msg)
  }
  invisible(x)
}

#' @export
#' @rdname assert_type
assert_scalar <- function(x, expected) {
  arg <- deparse(substitute(x))
  msg <- sprintf(tr_("Can't find a predicate for this scalar: %s."), expected)
  predicate <- switch(
    expected,
    list = is_scalar_list,
    atomic = is_scalar_atomic,
    vector = is_scalar_vector,
    numeric = is_scalar_numeric,
    integer = is_scalar_integer,
    double = is_scalar_double,
    character = is_scalar_character,
    logical = is_scalar_logical,
    stop(msg, call. = FALSE)
  )
  if (!predicate(x)) {
    msg <- sprintf(tr_("%s must be a scalar (%s)."), sQuote(arg), expected)
    throw_error("error_bad_scalar", msg)
  }
  invisible(x)
}

#' @export
#' @rdname assert_type
assert_function <- function(x) {
  arg <- deparse(substitute(x))
  if (!is.function(x)) {
    msg <- sprintf(tr_("%s must be a function."), sQuote(arg))
    throw_error("error_bad_type", msg)
  }
  invisible(x)
}

# Numeric ======================================================================
#' Check Numeric Values
#'
#' @param x A [`numeric`] object to be checked.
#' @param na.rm A [`logical`] scalar: should missing values (including `NaN`)
#'  be omitted?
#' @param ... Extra parameters to be passed to internal methods.
#' @return
#'  Throws an error, if any, and returns `x` invisibly otherwise.
#' @author N. Frerebeau
#' @family checking methods
#' @name assert_numeric
#' @rdname assert_numeric
NULL

#' @export
#' @rdname assert_numeric
assert_count <- function(x, na.rm = FALSE, ...) {
  arg <- deparse(substitute(x))
  if (!all(is_whole(x, ...), na.rm = na.rm)) {
    msg <- sprintf(tr_("%s must contain integers (counts)."), sQuote(arg))
    throw_error("error_bad_numeric", msg)
  }
  invisible(x)
}

#' @export
#' @rdname assert_numeric
assert_whole <- assert_count

#' @export
#' @rdname assert_numeric
assert_positive <- function(x, na.rm = FALSE, ...) {
  arg <- deparse(substitute(x))
  if (!all(is_positive(x, ...), na.rm = na.rm)) {
    msg <- sprintf(tr_("%s must contain positive numbers."), sQuote(arg))
    throw_error("error_bad_numeric", msg)
  }
  invisible(x)
}

#' @export
#' @rdname assert_numeric
assert_negative <- function(x, na.rm = FALSE, ...) {
  arg <- deparse(substitute(x))
  if (!all(is_negative(x, ...), na.rm = na.rm)) {
    msg <- sprintf(tr_("%s must contain negative numbers."), sQuote(arg))
    throw_error("error_bad_numeric", msg)
  }
  invisible(x)
}

#' @export
#' @rdname assert_numeric
assert_odd <- function(x, na.rm = FALSE, ...) {
  arg <- deparse(substitute(x))
  if (!all(is_odd(x, ...), na.rm = na.rm)) {
    msg <- sprintf(tr_("%s must contain odd numbers."), sQuote(arg))
    throw_error("error_bad_numeric", msg)
  }
  invisible(x)
}

#' @export
#' @rdname assert_numeric
assert_even <- function(x, na.rm = FALSE, ...) {
  arg <- deparse(substitute(x))
  if (!all(is_even(x, ...), na.rm = na.rm)) {
    msg <- sprintf(tr_("%s must contain even numbers."), sQuote(arg))
    throw_error("error_bad_numeric", msg)
  }
  invisible(x)
}

#' Check Numeric Trend
#'
#' @param x A [`numeric`] object to be checked.
#' @param ... Extra parameters to be passed to internal methods.
#' @return
#'  Throws an error, if any, and returns `x` invisibly otherwise.
#' @author N. Frerebeau
#' @family checking methods
#' @export
assert_constant <- function(x, ...) {
  arg <- deparse(substitute(x))
  if (!is_constant(x, ...)) {
    msg <- sprintf(tr_("%s must be constant."), sQuote(arg))
    throw_error("error_bad_numeric", msg)
  }
  invisible(x)
}

#' @export
#' @rdname assert_constant
assert_decreasing <- function(x, ...) {
  arg <- deparse(substitute(x))
  if (!is_decreasing(x, ...)) {
    msg <- sprintf(tr_("%s must be decreasing."), sQuote(arg))
    throw_error("error_bad_numeric", msg)
  }
  invisible(x)
}

#' @export
#' @rdname assert_constant
assert_increasing <- function(x, ...) {
  arg <- deparse(substitute(x))
  if (!is_increasing(x, ...)) {
    msg <- sprintf(tr_("%s must be increasing."), sQuote(arg))
    throw_error("error_bad_numeric", msg)
  }
  invisible(x)
}

#' Check Numeric Relations
#'
#' @param x,y A [`numeric`] object to be checked.
#' @param ... Extra parameters to be passed to internal methods.
#' @return
#'  Throws an error, if any, and returns `x` invisibly otherwise.
#' @author N. Frerebeau
#' @family checking methods
#' @export
assert_lower <- function(x, y, ...) {
  arg_x <- deparse(substitute(x))
  arg_y <- deparse(substitute(y))
  if (!is_lower(x, y, ...)) {
    txt <- tr_("%s must be lower than %s.")
    msg <- sprintf(txt, sQuote(arg_x), sQuote(arg_y))
    throw_error("error_bad_numeric", msg)
  }
  invisible(x)
}

#' @export
#' @rdname assert_lower
assert_greater <- function(x, y, ...) {
  arg_x <- deparse(substitute(x))
  arg_y <- deparse(substitute(y))
  if (!is_greater(x, y, ...)) {
    txt <- tr_("%s must be greater than %s.")
    msg <- sprintf(txt, sQuote(arg_x), sQuote(arg_y))
    throw_error("error_bad_numeric", msg)
  }
  invisible(x)
}

# Matrix =======================================================================
#' Check Matrix
#'
#' @param x A [`matrix`] to be checked.
#' @return Throw an error, if any, and returns `x` invisibly otherwise.
#' @author N. Frerebeau
#' @family checking methods
#' @export
assert_square <- function(x) {
  arg <- deparse(substitute(x))
  if (!is_square(x)) {
    k <- paste0(dim(x), collapse = " x ")
    msg <- sprintf(tr_("%s must be a square matrix, not %s."), sQuote(arg), k)
    throw_error("error_bad_matrix", msg)
  }
  invisible(x)
}

#' @export
#' @rdname assert_square
assert_symmetric <- function(x) {
  arg <- deparse(substitute(x))
  if (!is_symmetric(x)) {
    msg <- sprintf(tr_("%s must be a symmetric matrix."), sQuote(arg))
    throw_error("error_bad_matrix", msg)
  }
  invisible(x)
}

# Check Graph
#
# @param x A [`matrix`] to be checked.
# @param expected An appropriate expected value.
# @return Throw an error, if any.
# @author N. Frerebeau
# @family checking methods
# @keywords internal
# @export
# assert_dag <- function(x) {
#   arg <- deparse(substitute(x))
#   if (!is_dag(x)) {
#     msg <- sprintf(tr_("%s must not contain cycles."), sQuote(arg))
#     throw_error("error_bad_graph", msg)
#   }
#   invisible(x)
# }

# SEEK

cols <- function(...) {
  x <- c(...)
  function(ctx) match(x, names(ctx))
}

seek <- function(x, margin = 2, select = NULL, names = NULL, ...) {
  assert_filled(x)
  assert_length(margin, 1)
  assert_type(names, "character", allow_null = TRUE)

  dm <- dim(x)[[margin]]
  nm <- dimnames(x)[[margin]]
  if (is.null(nm)) return(NULL)

  if (is.null(select)) {
    if (is.null(names)) return(NULL)
    select <- function(i) match(names, i)
  }

  assert_function(select)
  i <- select(nm, ...)

  if (is.logical(i)) i <- which(i)
  if (length(i) == 0 || all(is.na(i))) i <- NULL
  assert_type(i, "integer", allow_null = TRUE)
  i
}

#' @export
#' @rdname seek
#' @aliases seek_rows,data.frame-method
setMethod(
  f = "seek_rows",
  signature = c(x = "data.frame"),
  definition = function(x, select = NULL, names = NULL, ...) {
    seek(x, margin = 1, select = select, names = names, ...)
  }
)

#' @export
#' @rdname seek
#' @aliases seek_rows,matrix-method
setMethod(
  f = "seek_rows",
  signature = c(x = "matrix"),
  definition = function(x, select = NULL, names = NULL, ...) {
    seek(x, margin = 1, select = select, names = names, ...)
  }
)

#' @export
#' @rdname seek
#' @aliases seek_columns,data.frame-method
setMethod(
  f = "seek_columns",
  signature = c(x = "data.frame"),
  definition = function(x, select = NULL, names = NULL, ...) {
    seek(x, margin = 2, select = select, names = names, ...)
  }
)

#' @export
#' @rdname seek
#' @aliases seek_columns,matrix-method
setMethod(
  f = "seek_columns",
  signature = c(x = "matrix"),
  definition = function(x, select = NULL, names = NULL, ...) {
    seek(x, margin = 2, select = select, names = names, ...)
  }
)

# PREDICATES

# Not exported =================================================================
is_zero_numeric <- function(x, tolerance = sqrt(.Machine$double.eps)) {
  if (is.numeric(x)) return(abs(x) <= tolerance)
  rep(FALSE, length(x))
}

# Attributes ===================================================================
#' Attributes Predicates
#'
#' * `has_length()` checks how long is an object.
#' * `is_empty()` checks is an object is empty (any zero-length dimensions).
#' @param x A [`vector`] to be tested.
#' @param n A length-one [`numeric`] vector specifying the length to test `x`
#'  with. If `NULL`, returns `TRUE` if `x` has length greater than zero, and
#'  `FALSE` otherwise.
#' @return A [`logical`] scalar.
#' @family predicates
#' @name predicate-attributes
#' @rdname predicate-attributes
NULL

#' @export
#' @rdname predicate-attributes
has_length <- function(x, n = NULL) {
  if (is.null(n)) length(x) > 0 else length(x) == n
}

#' @export
#' @rdname predicate-attributes
is_empty <- function(x) {
  if (!is.null(dim(x))) nrow(x) == 0 || ncol(x) == 0
  else length(x) == 0
}

# Names ========================================================================
#' Names Predicates
#'
#' Checks if an object is named.
#' @param x A [`vector`] to be tested.
#' @param names A [`character`] vector specifying the names to test `x`
#'  with. If `NULL`, returns `TRUE` if `x` has names, and `FALSE` otherwise.
#' @return A [`logical`] scalar.
#' @family predicates
#' @name predicate-names
#' @rdname predicate-names
NULL

#' @export
#' @rdname predicate-names
has_names <- function(x, names = NULL) {
  if (is.null(names)) {
    has_length(names(x))
  } else {
    identical(names(x), names)
  }
}

#' @export
#' @rdname predicate-names
has_rownames <- function(x, names = NULL) {
  if (is.null(names)) {
    has_length(rownames(x))
  } else {
    identical(rownames(x), names)
  }
}

#' @export
#' @rdname predicate-names
has_colnames <- function(x, names = NULL) {
  if (is.null(names)) {
    has_length(colnames(x))
  } else {
    identical(colnames(x), names)
  }
}

# NA/NaN/Inf/duplicates ========================================================
#' Utility Predicates
#'
#' * `has_missing()` and `has_infinite()` check if an object contains missing
#' or infinite values.
#' * `has_duplicates()` checks if an object has duplicated elements.
#' @param x A [`vector`] to be tested.
#' @param tolerance A [`numeric`] scalar giving the tolerance to check within
#'  (for `numeric` vector).
#' @param na.rm A [`logical`] scalar: should missing values (including `NaN`)
#'  be omitted?
#' @return A [`logical`] scalar.
#' @family predicates
#' @name predicate-data
#' @rdname predicate-data
NULL

#' @export
#' @rdname predicate-data
has_missing <- function(x) {
  anyNA(x)
}

#' @export
#' @rdname predicate-data
has_infinite <- function(x) {
  any(is.infinite(x))
}

#' @export
#' @rdname predicate-data
has_duplicates <- function(x) {
  anyDuplicated(x) > 0
}

is_duplicated <- function(x) {
  duplicated(x, fromLast = FALSE) | duplicated(x, fromLast = TRUE)
}

#' @export
#' @rdname predicate-data
is_unique <- function(x, tolerance = sqrt(.Machine$double.eps), na.rm = FALSE) {
  if (na.rm) x <- stats::na.omit(x)
  if (is.numeric(x)) {
    cte <- is_constant(x, tolerance = tolerance)
    if (is.na(cte)) cte <- FALSE
  } else {
    cte <- length(unique(x)) == 1
  }
  cte
}

# Type =========================================================================
#' Type Predicates
#'
#' @param x An object to be tested.
#' @return A [`logical`] scalar.
#' @family predicates
#' @name predicate-type
#' @rdname predicate-type
NULL

#' @export
#' @rdname predicate-type
is_list <- function(x) {
  typeof(x) == "list"
}
#' @export
#' @rdname predicate-type
is_atomic <- function(x) {
  typeof(x) %in% c("logical", "integer", "double",
                   "complex", "character", "raw")
}
#' @export
#' @rdname predicate-type
is_vector <- function(x) {
  is_atomic(x) || is_list(x)
}
#' @export
#' @rdname predicate-type
is_numeric <- function(x) {
  typeof(x) %in% c("integer", "double")
}
#' @export
#' @rdname predicate-type
is_integer <- function(x) {
  typeof(x) == "integer"
}
#' @export
#' @rdname predicate-type
is_double <- function(x) {
  typeof(x) == "double"
}
#' @export
#' @rdname predicate-type
is_character <- function(x) {
  typeof(x) == "character"
}
#' @export
#' @rdname predicate-type
is_logical <- function(x) {
  typeof(x) == "logical"
}
#' @export
#' @rdname predicate-type
is_error <- function(x) {
  inherits(x, "try-error") || inherits(x, "simpleError") || inherits(x, "error")
}
#' @export
#' @rdname predicate-type
is_warning <- function(x) {
  inherits(x, "simpleWarning") || inherits(x, "warning")
}
#' @export
#' @rdname predicate-type
is_message <- function(x) {
  inherits(x, "simpleMessage") || inherits(x, "message")
}

# Scalar =======================================================================
#' Scalar Type Predicates
#'
#' @param x An object to be tested.
#' @return A [`logical`] scalar.
#' @family predicates
#' @name is_scalar
#' @rdname is_scalar
NULL

#' @export
#' @rdname is_scalar
is_scalar_list <- function(x) {
  is_list(x) && length(x) == 1
}
#' @export
#' @rdname is_scalar
is_scalar_atomic <- function(x) {
  is_atomic(x) && length(x) == 1
}
#' @export
#' @rdname is_scalar
is_scalar_vector <- function(x) {
  is_vector(x) && length(x) == 1
}
#' @export
#' @rdname is_scalar
is_scalar_numeric <- function(x) {
  is_numeric(x) && length(x) == 1
}
#' @export
#' @rdname is_scalar
is_scalar_integer <- function(x) {
  is_integer(x) && length(x) == 1
}
#' @export
#' @rdname is_scalar
is_scalar_double <- function(x) {
  is_double(x) && length(x) == 1
}
#' @export
#' @rdname is_scalar
is_scalar_character <- function(x) {
  is_character(x) && length(x) == 1
}
#' @export
#' @rdname is_scalar
is_scalar_logical <- function(x) {
  is_logical(x) && length(x) == 1
}

# Numeric ======================================================================
#' Numeric Predicates
#'
#' Check numeric objects:
#' * `is_zero()` checks if an object contains only zeros.
#' * `is_odd()` and `is_even()` check if a number is odd or even, respectively.
#' * `is_positive()` and `is_negative` check if an object contains only
#'   (strictly) positive or negative numbers.
#' * `is_whole()` checks if an object only contains whole numbers.
#' @param x A [`numeric`] object to be tested.
#' @param tolerance A [`numeric`] scalar giving the tolerance to check within.
#' @param strict A [`logical`] scalar: should strict inequality be used?
#' @param ... Currently not used.
#' @return A [`logical`] vector.
#' @family predicates
#' @name predicate-numeric
#' @rdname predicate-numeric
NULL

#' @export
#' @rdname predicate-numeric
is_zero <- function(x, tolerance = sqrt(.Machine$double.eps), ...) {
  assert_type(x, "numeric")
  abs(x) <= tolerance
}
#' @export
#' @rdname predicate-numeric
is_odd <- function(x, ...) { # impair
  assert_type(x, "numeric")
  as.logical(x %% 2)
}
#' @export
#' @rdname predicate-numeric
is_even <- function(x, ...) { # pair
  assert_type(x, "numeric")
  !as.logical(x %% 2)
}
#' @export
#' @rdname predicate-numeric
is_positive <- function(x, strict = FALSE, ...) {
  assert_type(x, "numeric")
  if (strict) x > 0 else x >= 0
}
#' @export
#' @rdname predicate-numeric
is_negative <- function(x, strict = FALSE, ...) {
  assert_type(x, "numeric")
  if (strict) x < 0 else x <= 0
}
#' @export
#' @rdname predicate-numeric
is_whole <- function(x, tolerance = sqrt(.Machine$double.eps), ...) {
  assert_type(x, "numeric")
  abs(x - round(x, digits = 0)) <= tolerance
}

#' Numeric Trend Predicates
#'
#' Check numeric objects:
#' * `is_constant()` checks for equality among all elements of a vector.
#' * `is_increasing()` and `is_decreasing()` check if a sequence of numbers
#'   is monotonically increasing or decreasing, respectively.
#' @param x,y A [`numeric`] object to be tested.
#' @param tolerance A [`numeric`] scalar giving the tolerance to check within.
#' @param strict A [`logical`] scalar: should strict inequality be used?
#' @param na.rm A [`logical`] scalar: should missing values (including `NaN`)
#'  be omitted?
#' @return A [`logical`] scalar.
#' @family predicates
#' @name predicate-trend
#' @rdname predicate-trend
NULL

#' @export
#' @rdname predicate-trend
is_constant <- function(x, tolerance = sqrt(.Machine$double.eps), na.rm = FALSE) {
  assert_type(x, "numeric")
  abs(max(x, na.rm = na.rm) - min(x, na.rm = na.rm)) <= tolerance
}
#' @export
#' @rdname predicate-trend
is_increasing <- function(x, na.rm = FALSE) {
  assert_type(x, "numeric")
  if (na.rm) x <- stats::na.omit(x)
  all(x == cummax(x))
}
#' @export
#' @rdname predicate-trend
is_decreasing <- function(x, na.rm = FALSE) {
  assert_type(x, "numeric")
  if (na.rm) x <- stats::na.omit(x)
  all(x == cummin(x))
}
#' @export
#' @rdname predicate-trend
is_greater <- function(x, y, strict = FALSE, na.rm = FALSE) {
  assert_type(x, "numeric")
  assert_type(y, "numeric")
  z <- if (strict) x > y else x >= y
  all(z, na.rm = na.rm)
}
#' @export
#' @rdname predicate-trend
is_lower <- function(x, y, strict = FALSE, na.rm = FALSE) {
  assert_type(x, "numeric")
  assert_type(y, "numeric")
  z <- if (strict) x < y else x <= y
  all(z, na.rm = na.rm)
}

# Matrix =======================================================================
#' Matrix Predicates
#'
#' * `is_square()` checks if a matrix is square.
#' * `is_symmetric()` checks if a matrix is symmetric.
#' @param x A [`matrix`] to be tested.
#' @return A [`logical`] scalar.
#' @family predicates
#' @name predicate-matrix
#' @rdname predicate-matrix
NULL

#' @export
#' @rdname predicate-matrix
is_square <- function(x) {
  if (is.matrix(x)) nrow(x) == ncol(x) else FALSE
}
#' @export
#' @rdname predicate-matrix
is_symmetric <- function(x) {
  if (is.matrix(x)) identical(x, t(x)) else FALSE
}

# Graph ========================================================================
# Graph Predicates
#
# `is_dag()` checks if a graph has a topological ordering (i.e. is a directed
# acyclic graph) using Kahn's algorithm.
# @param x An adjacency [`matrix`] to be tested.
# @return A [`logical`] scalar.
# @references
#  Kahn, A. B. (1962). Topological sorting of large networks. *Communications
#  of the ACM*, 5(11), p. 558-562. \doi{10.1145/368996.369025}.
# @family predicates
# @keywords internal
# @export
# is_dag <- function(x) {
#   # Get edges
#   G <- matrix2edges(x)
#   # Find nodes which have no incoming edges
#   S <- which(colSums(x) == 0)
#   # List that will contain the sorted elements
#   L <- list()
#
#   if (length(S) == 0)
#     return(FALSE)
#
#   k <- 1L
#   while (k == 1 || length(S) != 0) {
#     # Remove a node n from S and add n to tail of L
#     n <- S[[1]]
#     S <- S[-1]
#     L <- append(L, n)
#     # For each node m with an edge e from n to m
#     e <- which(G[, 1] == n)
#     m <- G[e, 2]
#     # Do remove edge e from the graph
#     G <- G[-e, , drop = FALSE]
#     # If m has no other incoming edges then insert m into S
#     if (nrow(G) != 0) {
#       m <- m[!(m %in% G[, 2])]
#       if (length(m) != 0)
#         S <- append(S, m)
#     }
#     k <- k + 1
#   }
#   return(nrow(G) == 0)
# }

# matrix2edges <- function(from) {
#   edges <- matrix(data = NA, nrow = 0, ncol = 2)
#   nodes <- seq_len(nrow(from))
#   for (i in nodes) {
#     to <- which(from[i, ])
#     if (length(to) != 0) {
#       e <- cbind(form = i, to = to)
#       edges <- rbind(edges, e)
#     }
#   }
#
#   edges
# }

# DATA CLEANING: DISCARD
#' @include AllGenerics.R
NULL

# discard ======================================================================
#' @export
#' @rdname discard
#' @aliases discard,ANY-method
setMethod(
  f = "discard",
  signature = c(x = "ANY"),
  definition = function(x, f, margin = 1, negate = FALSE, all = FALSE,
                        na.rm = FALSE, verbose = getOption("arkhe.verbose"),
                        ...) {
    i <- detect(x, f = f, margin = margin, negate = negate, all = all,
                na.rm = na.rm, ...)
    discard_message(x, keep = !i, margin = margin, verbose = verbose)
    if (any(margin == 1)) return(x[!i, , drop = FALSE])
    if (any(margin == 2)) return(x[, !i, drop = FALSE])
    i
  }
)

#' @export
#' @rdname discard
#' @aliases discard_rows,ANY-method
setMethod(
  f = "discard_rows",
  signature = c(x = "ANY"),
  definition = function(x, f, negate = FALSE, all = FALSE, na.rm = FALSE,
                        verbose = getOption("arkhe.verbose"), ...) {
    discard(x, f, margin = 1, negate = negate, all = all, na.rm = na.rm,
            verbose = verbose, ...)
  }
)

#' @export
#' @rdname discard
#' @aliases discard_columns,ANY-method
setMethod(
  f = "discard_columns",
  signature = c(x = "ANY"),
  definition = function(x, f, negate = FALSE, all = FALSE, na.rm = FALSE,
                        verbose = getOption("arkhe.verbose"), ...) {
    discard(x, f, margin = 2, negate = negate, all = all, na.rm = na.rm,
            verbose = verbose, ...)
  }
)

#' Diagnostic Message
#'
#' Generates a diagnostic message describing columns or rows that are being
#' removed.
#' @param x A [`matrix`] or a [`data.frame`].
#' @param margin A length-one [`numeric`] vector giving the subscripts which the
#'  function will be applied over (`1` indicates rows, `2` indicates columns).
#' @param keep A [`logical`] vector of rows or columns to keep (`TRUE`) or
#'  remove (`FALSE`).
#' @param verbose A [`logical`] scalar: should the message be generated?
#' @keywords internal
#' @noRd
discard_message <- function(x, keep, margin,
                            verbose = getOption("arkhe.verbose")) {
  drop <- sum(!keep, na.rm = TRUE)
  what <- ngettext(drop, "element", "elements")
  if (any(margin == 1)) what <- ngettext(drop, "row", "rows")
  if (any(margin == 2)) what <- ngettext(drop, "column", "columns")

  if (drop == 0) {
    msg <- tr_("Nothing to remove.")
  } else {
    pc <- sprintf("%0.3g%%", 100 * drop / length(keep))
    if (margin == 2 && !is.null(colnames(x))) {
      pc <- paste0(colnames(x)[!keep], collapse = ", ")
    }
    msg <- tr_("Removing %g %s out of %g (%s).")
    msg <- sprintf(msg, drop, what, length(keep), pc)
  }

  if (isTRUE(verbose)) message(msg)
  invisible(msg)
}

# DATA CLEANING: ASSIGN
#' @include AllGenerics.R
NULL

#' @export
#' @rdname assign
#' @aliases assign_rownames,data.frame-method
setMethod(
  f = "assign_rownames",
  signature = c(x = "data.frame"),
  definition = function(x, column, remove = TRUE) {
    ## Validation
    assert_length(column, 1)
    if ((column > ncol(x)) || (column < 1)) return(x)

    y <- x
    rownames(y) <- y[, column]
    if (remove) {
      y <- y[, -column, drop = FALSE]
    }
    y
  }
)

#' @export
#' @rdname assign
#' @aliases assign_colnames,data.frame-method
setMethod(
  f = "assign_colnames",
  signature = c(x = "data.frame"),
  definition = function(x, row, remove = TRUE) {
    ## Validation
    assert_length(row, 1)
    if ((row > nrow(x)) || (row < 1)) return(x)

    y <- x
    colnames(y) <- y[row, ]
    if (remove) {
      y <- y[-row, , drop = FALSE]
    }
    y
  }
)

# DATA SUMMARY: SPARCITY
#' @include AllGenerics.R
NULL

#' @export
#' @rdname sparsity
#' @aliases sparsity,matrix-method
setMethod(
  f = "sparsity",
  signature = c(x = "matrix"),
  definition = function(x, count = FALSE) {
    zeros <- sum(count(x, f = is_zero_numeric, margin = 2, na.rm = TRUE))
    if (count) return(zeros)

    ## Proportion
    total <- prod(dim(x))
    zeros / total
  }
)

#' @export
#' @rdname sparsity
#' @aliases sparsity,data.frame-method
setMethod(
  f = "sparsity",
  signature = c(x = "data.frame"),
  definition = function(x, count = FALSE) {
    zeros <- sum(count(x, f = is_zero_numeric, margin = 2, na.rm = TRUE))
    if (count) return(zeros)

    ## Count numeric values only
    num <- vapply(X = x, FUN = is.numeric, FUN.VALUE = logical(1))
    total <- nrow(x) * sum(num)

    ## Proportion
    zeros / total
  }
)

# HELPERS

## https://michaelchirico.github.io/potools/articles/developers.html
tr_ <- function(...) {
  enc2utf8(gettext(paste0(...), domain = "R-arkhe"))
}

## https://stackoverflow.com/questions/56191862/where-do-i-specify-random-seed-for-tests-in-r-package
#' Evaluate an Expression with a Temporarily Seed
#'
#' @param expr An [`expression`] to be evaluated.
#' @param seed A single value to be passed to [set.seed()].
#' @param envir	The [environment][environment()] in which `expr` should be
#'  evaluated.
#' @param rounding A [`logical`] scalar: should the default discrete uniform
#'  generation method in \R versions prior to 3.6.0 be used? Usefull for unit
#'  testing.
#' @param ... Further arguments to be passed to [set.seed()].
#' @return
#'  The results of `expr` evaluated.
#' @seealso [set.seed()]
#' @keywords internal
with_seed <- function(expr, seed, ..., envir = parent.frame(), rounding = TRUE) {
  expr <- substitute(expr)
  ## Save and restore the random number generator (RNG) state
  env <- globalenv()
  old_seed <- env$.Random.seed
  on.exit({
    if (is.null(old_seed)) {
      rm(list = ".Random.seed", envir = env, inherits = FALSE)
    } else {
      assign(".Random.seed", value = old_seed, envir = env, inherits = FALSE)
    }
  })
  ## Keep the results the same for R versions prior to 3.6
  if (isTRUE(rounding) && getRversion() >= "3.6") {
    ## Set sample.kind = "Rounding" to reproduce the old sampling
    ## Suppress warning "non-uniform 'Rounding' sampler used"
    suppressWarnings(set.seed(seed, sample.kind = "Rounding"))
  } else {
    set.seed(seed)
  }
  eval(expr, envir = envir)
}

# DATA TRANSFORMATION
NULL

#' Rescale Continuous Vector (minimum, maximum)
#'
#' Rescales continuous vector to have specified minimum and maximum.
#' @param x A [`numeric`] vector.
#' @param to A length-two [`numeric`] vector specifying the output range.
#' @param from A length-two [`numeric`] vector specifying the input range.
#' @return A [`numeric`] vector.
#' @note For internal use only.
#' @family scales
#' @export
scale_range <- function(x, to = c(0, 1), from = range(x, finite = TRUE)) {
  if (.is_zero(to) || .is_zero(from)) return(ifelse(is.na(x), NA, mean(to)))
  (x - from[1L]) / diff(from) * diff(to) + to[1L]
}

#' Rescale Continuous Vector (minimum, midpoint, maximum)
#'
#' Rescales continuous vector to have specified minimum, midpoint and maximum.
#' @param x A [`numeric`] vector.
#' @param to A length-two [`numeric`] vector specifying the output range.
#' @param from A length-two [`numeric`] vector specifying the input range.
#' @param midpoint A length-one [`numeric`] vector specifying the mid-point of
#'  input range.
#' @return A [`numeric`] vector.
#' @note For internal use only.
#' @family scales
#' @export
scale_midpoint <- function(x, to = c(0, 1), from = range(x, finite = TRUE), midpoint = 0) {
  if (.is_zero(to) || .is_zero(from)) return(ifelse(is.na(x), NA, mean(to)))
  extent <- 2 * max(abs(from - midpoint))
  (x - midpoint) / extent * diff(to) + mean(to)
}

.is_zero <- function(x, tolerance = sqrt(.Machine$double.eps)) {
  diff(range(x)) <= tolerance
}

# DATA CLEANING: COUNT
#' @include AllGenerics.R
NULL

# Count ========================================================================
#' @export
#' @rdname count
#' @aliases count,data.frame-method
setMethod(
  f = "count",
  signature = c(x = "data.frame"),
  definition = function(x, f, margin = 1, negate = FALSE, na.rm = FALSE, ...) {
    assert_function(f)
    if (negate) f <- Negate(f)
    x[] <- lapply(X = x, FUN = f, ...)
    if (any(margin == 1)) return(rowSums(x, na.rm = na.rm))
    if (any(margin == 2)) return(colSums(x, na.rm = na.rm))
    x
  }
)

#' @export
#' @rdname count
#' @aliases count,matrix-method
setMethod(
  f = "count",
  signature = c(x = "matrix"),
  definition = function(x, f, margin = 1, negate = FALSE, na.rm = FALSE, ...) {
    assert_function(f)
    if (negate) f <- Negate(f)
    x <- apply(X = x, MARGIN = margin, FUN = f, ..., simplify = TRUE)
    ## If simplify is TRUE:
    ## apply() returns an array of dimension c(n, dim(X)[MARGIN]) if n > 1
    ## apply() returns a vector if n == 1 and MARGIN has length 1
    if (is.null(dim(x))) x <- matrix(x, nrow = 1)
    colSums(x, na.rm = na.rm)
  }
)

# CLEAN

# Whitespace ===================================================================
#' @export
#' @rdname clean_whitespace
#' @aliases clean_whitespace,data.frame-method
setMethod(
  f = "clean_whitespace",
  signature = c(x = "data.frame"),
  definition = function(x, which = c("both", "left", "right"), squish = TRUE) {
    x[] <- lapply(
      X = x,
      FUN = function(x, which, squish) {
        if (!is.character(x)) return(x)
        trim(x, which = which, squish = squish)
      },
      which = which,
      squish = squish
    )
    x
  }
)

#' @export
#' @rdname clean_whitespace
#' @aliases clean_whitespace,matrix-method
setMethod(
  f = "clean_whitespace",
  signature = c(x = "matrix"),
  definition = function(x, which = c("both", "left", "right"), squish = TRUE) {
    x[] <- trim(x, which = which, squish = squish)
    x
  }
)

trim <- function(x, which = c("both", "left", "right"), squish = TRUE) {
  ## Squish
  if (squish) x <- gsub(pattern = "\\s+", replacement = " ", x = x)
  ## Trim
  x <- trimws(x, which = which, whitespace = "[ \t\r\n]")

  x
}

#' Wrap Character Strings to Format Paragraphs
#'
#' @param x A [`character`] vector of strings.
#' @param width A positive [`integer`] giving the target column width for
#'  wrapping lines in the output.
#' @return A [`character`] vector of strings.
#' @keywords internal
#' @noRd
wrap_strings <- function(x, width, ...) {
  vapply(
    X = x,
    FUN = function(x, ...) {
      paste0(strwrap(x, width = width, ...), collapse = "\n")
    },
    FUN.VALUE = character(1),
    ...
  )
}

# CONDITIONS
#' @include AllGenerics.R
NULL

#' Conditions
#'
#' * `throw_error()` stops execution of the current expression and executes an
#'  error action.
#' * `throw_warning()` generates a warning message.
#' * `catch_conditions()` and `catch_message()` handles unusual conditions.
#' @param expr An expression to be evaluated.
#' @param .subclass A [`character`] string specifying the class of
#'  the message to be returned.
#' @param message A [`character`] string specifying the message to be
#'  returned.
#' @param call The call.
#' @param ... Extra arguments.
#' @author N. Frerebeau
#' @name conditions
#' @rdname conditions
#' @family condition
#' @keywords internal error
NULL

#' @rdname conditions
throw_error <- function(.subclass, message, call = NULL, ...) {
  err <- structure(
    list(
      message = message,
      call = call,
      ...
    ),
    class = c(.subclass, "error", "condition")
  )
  stop(err)
}

#' @rdname conditions
throw_warning <- function(.subclass, message, call = NULL, ...) {
  wrn <- structure(
    list(
      message = message,
      call = call,
      ...
    ),
    class = c(.subclass, "warning", "condition")
  )
  warning(wrn)
}

#' @rdname conditions
catch_message <- function(expr) {
  cnd <- vector(mode = "character")
  add_msg <- function(x) {
    cnd <<- append(cnd, x$message)
    invokeRestart("muffleMessage")
  }
  add_wrn <- function(x) {
    cnd <<- append(cnd, x$message)
    invokeRestart("muffleWarning")
  }
  add_err <- function(x) {
    cnd <<- append(cnd, x$message)
  }

  tryCatch(
    error = add_err,
    withCallingHandlers(
      message = add_msg,
      warning = add_wrn,
      expr
    )
  )
  return(cnd)
}

#' @rdname conditions
catch_conditions <- function(expr) {
  cnd <- vector(mode = "list")
  add_msg <- function(x) {
    cnd <<- append(cnd, list(x))
    invokeRestart("muffleMessage")
  }
  add_wrn <- function(x) {
    cnd <<- append(cnd, list(x))
    invokeRestart("muffleWarning")
  }
  add_err <- function(x) {
    cnd <<- append(cnd, list(x))
  }

  tryCatch(
    error = add_err,
    withCallingHandlers(
      message = add_msg,
      warning = add_wrn,
      expr
    )
  )
  return(cnd)
}

# Diagnostic ===================================================================
#' Class Diagnostic
#'
#' @param object An object to which error messages are related.
#' @param conditions A [`list`] of condition messages.
#' @return
#'  Throw an error if `conditions` is of non-zero length, invisibly returns
#'  `TRUE` if not.
#' @author N. Frerebeau
#' @keywords internal
#' @export
check_class <- function(object, conditions) {
  cnd <- Filter(Negate(is_empty), conditions)
  if (has_length(cnd)) {
    li <- paste0("* ", cnd, collapse = "\n")
    err <- sprintf(tr_("<%s> instance initialization:\n%s"), class(object), li)
    throw_error("arkhe_error_class", err, call = NULL)
  }

  invisible(TRUE)
}

# DATA CLEANING: REPLACE
#' @include AllGenerics.R
NULL

# Replace ======================================================================
## Missing values --------------------------------------------------------------
#' @export
#' @rdname replace_NA
#' @aliases replace_NA,matrix-method
setMethod(
  f = "replace_NA",
  signature = c(x = "matrix"),
  definition = function(x, value = 0) {
    x[is.na(x)] <- value
    x
  }
)

#' @export
#' @rdname replace_NA
#' @aliases replace_NA,data.frame-method
setMethod(
  f = "replace_NA",
  signature = c(x = "data.frame"),
  definition = function(x, value = 0) {
    x[] <- lapply(
      X = x,
      FUN = function(x, value) {
        x[is.na(x)] <- value
        x
      },
      value = value
    )
    x
  }
)

## Infinite values -------------------------------------------------------------
#' @export
#' @rdname replace_Inf
#' @aliases replace_Inf,matrix-method
setMethod(
  f = "replace_Inf",
  signature = c(x = "matrix"),
  definition = function(x, value = 0) {
    x[is.infinite(x)] <- value
    x
  }
)

#' @export
#' @rdname replace_Inf
#' @aliases replace_Inf,data.frame-method
setMethod(
  f = "replace_Inf",
  signature = c(x = "data.frame"),
  definition = function(x, value = 0) {
    x[] <- lapply(
      X = x,
      FUN = function(x, value) {
        x[is.infinite(x)] <- value
        x
      },
      value = value
    )
    x
  }
)

## Zeros -----------------------------------------------------------------------
#' @export
#' @rdname replace_zero
#' @aliases replace_zero,matrix-method
setMethod(
  f = "replace_zero",
  signature = c(x = "matrix"),
  definition = function(x, value) {
    x[is_zero(x)] <- value
    x
  }
)

#' @export
#' @rdname replace_zero
#' @aliases replace_zero,data.frame-method
setMethod(
  f = "replace_zero",
  signature = c(x = "data.frame"),
  definition = function(x, value) {
    num <- vapply(X = x, FUN = is.numeric, FUN.VALUE = logical(1))
    nozero <- lapply(
      X = x[, num, drop = FALSE],
      FUN = function(x, value) {
        x[is_zero(x)] <- value
        x
      },
      value = value
    )
    x[, num] <- nozero
    x
  }
)

## Empty string ----------------------------------------------------------------
#' @export
#' @rdname replace_empty
#' @aliases replace_empty,matrix-method
setMethod(
  f = "replace_empty",
  signature = c(x = "matrix"),
  definition = function(x, value) {
    x[!nzchar(x)] <- value
    x
  }
)

#' @export
#' @rdname replace_empty
#' @aliases replace_empty,data.frame-method
setMethod(
  f = "replace_empty",
  signature = c(x = "data.frame"),
  definition = function(x, value) {
    char <- vapply(X = x, FUN = is.character, FUN.VALUE = logical(1))
    noblank <- lapply(
      X = x[, char, drop = FALSE],
      FUN = function(x, value) {
        x[!nzchar(x)] <- value
        x
      },
      value = value
    )
    x[, char] <- noblank
    x
  }
)

# DATA CLEANING: APPEND
#' @include AllGenerics.R
NULL

#' @export
#' @rdname append_rownames
#' @aliases append_rownames,data.frame-method
setMethod(
  f = "append_rownames",
  signature = c(x = "data.frame"),
  definition = function(x, after = 0, remove = TRUE, var = "rownames") {
    assert_scalar(after, "numeric")
    assert_scalar(remove, "logical")
    assert_scalar(var, "character")

    n <- ncol(x)
    if (after > n) after <- n
    i_before <- seq_len(after)
    i_after <- if (after < n) seq(from = after + 1, to = n, by = 1) else 0

    z <- rownames(x)
    x <- cbind(x[, i_before, drop = FALSE], z, x[, i_after, drop = FALSE])

    colnames(x)[after + 1] <- var
    rownames(x) <- if (remove) NULL else z

    x
  }
)

#' @export
#' @rdname append_column
#' @aliases append_column,data.frame-method
setMethod(
  f = "append_column",
  signature = c(x = "data.frame"),
  definition = function(x, column, after = 0, var = ".col") {
    assert_scalar(after, "numeric")
    assert_scalar(var, "character")
    if (!is_atomic(column)) {
      stop(sprintf("%s must be an atomic vector.", sQuote("x")), call. = FALSE)
    }

    m <- nrow(x)
    if (has_rownames(x) && has_names(column)) {
      i <- match(names(column), rownames(x))

      if (anyNA(i)) {
        column <- column[!is.na(i)]
        i <- i[!is.na(i)]
      }

      old_column <- column
      column <- rep(NA, m)
      column[i] <- old_column
    }

    assert_length(column, m)

    p <- ncol(x)
    if (after > p) after <- p
    i_before <- seq_len(after)
    i_after <- if (after < p) seq(from = after + 1, to = p, by = 1) else 0

    x <- cbind(x[, i_before, drop = FALSE], column, x[, i_after, drop = FALSE])

    colnames(x)[after + 1] <- var
    x
  }
)

# GET

#' @export
#' @rdname get
#' @aliases get_columns,ANY-method
setMethod(
  f = "get_columns",
  signature = c(x = "ANY"),
  definition = function(x, select = NULL, names = NULL, ...) {
    i <- seek_columns(x, select = select, names = names, ...)
    i <- i[which(!is.na(i))]
    x[, i, drop = FALSE]
  }
)

#' @export
#' @rdname get
#' @aliases get_rows,ANY-method
setMethod(
  f = "get_rows",
  signature = c(x = "ANY"),
  definition = function(x, select = NULL, names = NULL, ...) {
    i <- seek_rows(x, select = select, names = names, ...)
    i <- i[which(!is.na(i))]
    x[i, , drop = FALSE]
  }
)

# UTILITIES
#' @include AllGenerics.R
NULL

#' Default value for NULL
#'
#' Replaces `NULL` with a default value.
#' @param x,y An object.
#' @return If `x` is `NULL`, returns `y`; otherwise returns `x`.
#' @family utilities
#' @keywords utilities
#' @name null
#' @rdname null
#' @export
`%||%` <- function(x, y) {
  if (is.null(x)) y else x
}

# Reexport from base on newer versions of R to avoid conflict messages
if (exists("%||%", envir = baseenv())) {
  `%||%` <- get("%||%", envir = baseenv())
}

#' Concatenate
#'
#' Concatenates character vectors.
#' @param x,y A [`character`] vector.
#' @return A [`character`] vector.
#' @family utilities
#' @keywords utilities
#' @name concat
#' @rdname concat
#' @export
`%+%` <- function (x, y) {
  stopifnot(is.character(x), is.character(y))
  stopifnot(length(x) == length(y) || length(x) == 1 || length(y) == 1)

  if (length(x) == 0 && length(y) == 0) paste0(x, y)
  else if (length(x) == 0) x
  else if (length(y) == 0) y
  else paste0(x, y)
}

# DATA CLEANING: COMPACT
#' @include AllGenerics.R
NULL

## compact rows/columns ========================================================
#' @export
#' @rdname compact
#' @aliases compact,ANY-method
setMethod(
  f = "compact",
  signature = c(x = "ANY"),
  definition = function(x, margin = 1, na.rm = FALSE,
                        verbose = getOption("arkhe.verbose")) {
    vide <- function(x) {
      if (is_numeric(x)) x == 0
      else if (is_logical(x)) !x
      else if (is_character(x)) !nzchar(x)
      else rep(FALSE, length(x))
    }
    discard(x, f = vide, margin = margin, all = TRUE,
            na.rm = na.rm, verbose = verbose)
  }
)

#' @export
#' @rdname compact
#' @aliases compact_columns,ANY-method
setMethod(
  f = "compact_columns",
  signature = c(x = "ANY"),
  definition = function(x, na.rm = FALSE, verbose = getOption("arkhe.verbose")) {
    compact(x, margin = 2, na.rm = na.rm, verbose = verbose)
  }
)

#' @export
#' @rdname compact
#' @aliases compact_rows,ANY-method
setMethod(
  f = "compact_rows",
  signature = c(x = "ANY"),
  definition = function(x, na.rm = FALSE, verbose = getOption("arkhe.verbose")) {
    compact(x, margin = 1, na.rm = na.rm, verbose = verbose)
  }
)

# MATHEMATICS
#' @include AllGenerics.R
NULL

#' @export
#' @rdname math_gcd
#' @aliases math_gcd,numeric,numeric-method
setMethod(
  f = "math_gcd",
  signature = c(x = "numeric", y = "numeric"),
  definition = function(x, y) {
    mapply(
      FUN = function(a, b) {
        if (isTRUE(all.equal(b, 0))) return(a)
        math_gcd(b, a %% b)
      },
      a = x,
      b = y
    )
  }
)

#' @export
#' @rdname math_lcm
#' @aliases math_lcm,numeric,numeric-method
setMethod(
  f = "math_lcm",
  signature = c(x = "numeric", y = "numeric"),
  definition = function(x, y) {
    (x * y) / math_gcd(x, y)
  }
)

# DATA CLEANING: REMOVE
#' @include AllGenerics.R
NULL

# Missing values ===============================================================
#' @export
#' @rdname remove_NA
#' @aliases remove_NA,ANY-method
setMethod(
  f = "remove_NA",
  signature = c(x = "ANY"),
  definition = function(x, margin = 1, all = FALSE,
                        verbose = getOption("arkhe.verbose")) {
    discard(x, f = is.na, margin = margin, all = all, verbose = verbose)
  }
)

# Infinite values ==============================================================
#' @export
#' @rdname remove_Inf
#' @aliases remove_Inf,ANY-method
setMethod(
  f = "remove_Inf",
  signature = c(x = "ANY"),
  definition = function(x, margin = 1, all = FALSE,
                        verbose = getOption("arkhe.verbose")) {
    discard(x, f = is.infinite, margin = margin, all = all, verbose = verbose)
  }
)

# Zeros ========================================================================
#' @export
#' @rdname remove_zero
#' @aliases remove_zero,ANY-method
setMethod(
  f = "remove_zero",
  signature = c(x = "ANY"),
  definition = function(x, margin = 1, all = FALSE,
                        verbose = getOption("arkhe.verbose")) {
    discard(x, f = is_zero_numeric, margin = margin,
            all = all, na.rm = TRUE, verbose = verbose)
  }
)

# Empty string =================================================================
#' @export
#' @rdname remove_empty
#' @aliases remove_empty,ANY-method
setMethod(
  f = "remove_empty",
  signature = c(x = "ANY"),
  definition = function(x, margin = 1, all = FALSE,
                        verbose = getOption("arkhe.verbose")) {
    discard(x, f = nzchar, margin = margin, negate = TRUE,
            all = all, na.rm = TRUE, verbose = verbose)
  }
)

# Constant =====================================================================
#' @export
#' @rdname remove_constant
#' @aliases remove_constant,ANY-method
setMethod(
  f = "remove_constant",
  signature = c(x = "ANY"),
  definition = function(x, na.rm = FALSE, verbose = getOption("arkhe.verbose")) {
    discard(x, f = function(x) { is_unique(x, na.rm = na.rm) },
            margin = 2, all = FALSE, verbose = verbose)
  }
)

1		# STATISTICS
2		#' @include AllGenerics.R
3		NULL
4
5		# HPDI =========================================================================
6		#' @export
7		#' @rdname interval_hdr
8		#' @aliases interval_hdr,numeric,numeric-method
9		setMethod(
10		f = "interval_hdr",
11		signature = c(x = "numeric", y = "numeric"),
12		definition = function(x, y, level = 0.954) {
13		## Compute density
14	1x	y <- y / sum(y)
15
16		## Order the sample (faster sorting with radix method)
17	1x	sorted <- sort(y, decreasing = TRUE, method = "radix")
18	1x	i <- min(which(cumsum(sorted) >= sum(y) * level))
19	1x	h <- sorted[[i]]
20	1x	idx <- which(y >= h)
21
22	1x	gap <- which(diff(idx) > 1)
23	1x	inf <- idx[c(1, gap + 1)]
24	1x	sup <- idx[c(gap, length(idx))]
25
26	1x	int <- mapply(FUN = seq, from = inf, to = sup,
27	1x	SIMPLIFY = FALSE, USE.NAMES = FALSE)
28	2x	p <- vapply(X = int, FUN = function(i, y) { sum(y[i]) },
29	1x	FUN.VALUE = numeric(1), y = y)
30
31	1x	cbind(start = x[inf], end = x[sup], p = round(p, digits = 2))
32		}
33		)
34
35		#' @export
36		#' @rdname interval_hdr
37		#' @aliases interval_hdr,numeric,missing-method
38		setMethod(
39		f = "interval_hdr",
40		signature = c(x = "numeric", y = "missing"),
41		definition = function(x, level = 0.954, ...) {
42		## Compute density
43	1x	d <- stats::density(x, ...)
44	1x	methods::callGeneric(x = d$x, y = d$y, level = level)
45		}
46		)
47
48		# Credible interval ============================================================
49		#' @export
50		#' @rdname interval_credible
51		#' @aliases interval_credible,numeric-method
52		setMethod(
53		f = "interval_credible",
54		signature = "numeric",
55		definition = function(x, level = 0.95) {
56		## Order the sample
57	1x	sorted <- sort(x, method = "radix") # Faster sorting with radix method
58
59		## Sample size
60	1x	N <- length(x)
61
62		## Number of data to be outside of the interval
63	1x	outside <- as.integer(N * (1 - level))
64	1x	inf <- seq(from = 1L, to = outside + 1L, by = 1L)
65	1x	sup <- seq(from = N - outside, to = N, by = 1L)
66
67		## Look for the shortest interval
68	1x	a <- sorted[sup]
69	1x	b <- sorted[inf]
70	1x	ind <- which.min(a - b)
71
72	1x	cbind(start = b[[ind]], end = a[[ind]], p = level)
73		}
74		)
75
76		# Confidence interval ==========================================================
77		#' @export
78		#' @rdname confidence_mean
79		#' @aliases confidence_mean,numeric-method
80		setMethod(
81		f = "confidence_mean",
82		signature = c(object = "numeric"),
83		definition = function(object, level = 0.95, type = c("student", "normal")) {
84		## Validation
85	2x	assert_scalar(level, "numeric")
86
87	2x	z <- zscore(level = level, n = length(object), type = type)
88	2x	margin <- z * stats::sd(object) / sqrt(length(object))
89	2x	interval <- mean(object) + margin * c(-1, 1)
90	2x	names(interval) <- c("lower", "upper")
91	2x	interval
92		}
93		)
94
95		zscore <- function(level, n, type = c("student", "normal")) {
96		## Validation
97	2x	type <- match.arg(type, several.ok = FALSE)
98
99	2x	alpha <- 1 - level
100		switch(
101	2x	type,
102	1x	normal = stats::qnorm(1 - alpha / 2), # Large sample size
103	1x	student = stats::qt(1 - alpha / 2, df = n - 1), # Small sample size
104		)
105		}
106
107		#' @export
108		#' @rdname confidence_binomial
109		#' @aliases confidence_binomial,numeric-method
110		setMethod(
111		f = "confidence_binomial",
112		signature = c(object = "numeric"),
113		definition = function(object, n, level = 0.95, method = "wald",
114		corrected = FALSE) {
115		## Validation
116	9x	assert_scalar(level, "numeric")
117	9x	method <- match.arg(method, several.ok = FALSE)
118
119	9x	p <- object / n
120	9x	q <- 1 - p
121	9x	alpha <- 1 - level
122
123	9x	z <- stats::qnorm(1 - alpha / 2)
124	9x	margin <- z * sqrt(p * q / n)
125	9x	if (corrected) {
126	4x	margin <- margin + 1 / (2 * n) # Wald with continuity correction
127		}
128
129	9x	interval <- c(lower = pmax(0, p - margin), upper = pmin(1, p + margin))
130	9x	interval
131		}
132		)
133
134		#' @export
135		#' @rdname confidence_multinomial
136		#' @aliases confidence_multinomial,numeric-method
137		setMethod(
138		f = "confidence_multinomial",
139		signature = c(object = "numeric"),
140		definition = function(object, level = 0.95, method = "wald",
141		corrected = FALSE) {
142		## Validation
143	2x	assert_scalar(level, "numeric")
144	2x	method <- match.arg(method, several.ok = FALSE)
145
146	2x	n <- sum(object)
147	2x	f <- switch (
148	2x	method,
149	2x	wald = function(x) confidence_binomial(x, n = n, level = level,
150	2x	method = "wald",
151	2x	corrected = corrected)
152		)
153
154	2x	interval <- vapply(X = object, FUN = f, FUN.VALUE = numeric(2))
155	2x	interval <- t(interval)
156	2x	rownames(interval) <- names(object)
157	2x	interval
158		}
159		)
160
161		#' @export
162		#' @rdname confidence_bootstrap
163		#' @aliases confidence_bootstrap,numeric-method
164		setMethod(
165		f = "confidence_bootstrap",
166		signature = c(object = "numeric"),
167		definition = function(object, level = 0.95,
168		type = c("basic", "normal", "student", "percentiles"),
169		t0 = NULL, var_t0 = NULL, var_t = NULL, ...) {
170		## Validation
171	5x	type <- match.arg(type, several.ok = FALSE)
172	5x	assert_scalar(level, "numeric")
173	5x	if (is.null(var_t)) {
174	4x	fin <- which(is.finite(object))
175		} else {
176	1x	assert_length(var_t, length(object))
177	1x	assert_type(var_t, "numeric")
178	1x	fin <- which(is.finite(object) & is.finite(var_t))
179	1x	var_t <- var_t[fin]
180		}
181	5x	object <- object[fin]
182
183	5x	if (type == "percentiles" \|\| type == "basic") {
184		## Percentile confidence interval
185		# conf <- stats::quantile(object, probs = probs, names = FALSE)
186	3x	probs <- (1 + c(-level, level)) / 2
187	3x	conf <- qq(object, probs)
188		}
189	5x	if (type == "basic") {
190		## Basic bootstrap confidence limits (Davison & Hinkley, 1997)
191	2x	assert_scalar(t0, "numeric")
192	2x	conf <- 2 * t0 - rev(conf)
193		}
194	5x	if (type == "normal") {
195		## Normal approximation (Davison & Hinkley, 1997)
196	1x	assert_scalar(t0, "numeric")
197	1x	if (is.null(var_t0)) var_t0 <- stats::var(object)
198
199	1x	bias <- mean(object) - t0
200	1x	zscore <- sqrt(var_t0) * stats::qnorm((1 + level) / 2)
201	1x	conf <- c(t0 - bias - zscore, t0 - bias + zscore)
202		}
203	5x	if (type == "student") {
204		## Studentized bootstrap confidence limits (Davison & Hinkley, 1997)
205	1x	assert_scalar(t0, "numeric")
206	1x	assert_scalar(var_t0, "numeric")
207
208	1x	probs <- (1 + c(level, -level)) / 2
209	1x	zscore <- (object - t0) / sqrt(var_t)
210	1x	conf <- t0 - sqrt(var_t0) * qq(zscore, probs)
211		}
212
213	5x	names(conf) <- c("lower", "upper")
214	5x	conf
215		}
216		)
217
218		# Copy non-exported from boot
219		# Davison and Hinkley (1997), eq. 5.8
220		qq <- function(x, alpha) {
221	4x	x <- x[is.finite(x)]
222	4x	R <- length(x)
223	4x	rk <- (R + 1) * alpha
224	4x	if (!all(rk > 1 & rk < R))
225	3x	warning(tr_("Extreme order statistics used as endpoints."), call. = FALSE)
226	4x	k <- trunc(rk)
227	4x	inds <- seq_along(k)
228	4x	out <- inds
229	4x	kvs <- k[k > 0 & k < R]
230	4x	tstar <- sort(x, partial = sort(union(c(1, R), c(kvs, kvs + 1))))
231	4x	ints <- (k == rk)
232	!	if (any(ints)) out[inds[ints]] <- tstar[k[inds[ints]]]
233	4x	out[k == 0] <- tstar[1L]
234	4x	out[k == R] <- tstar[R]
235	4x	not <- function(v) xor(rep(TRUE,length(v)), v)
236	4x	temp <- inds[not(ints) & k != 0 & k != R]
237	4x	temp1 <- stats::qnorm(alpha[temp])
238	4x	temp2 <- stats::qnorm(k[temp] / (R + 1))
239	4x	temp3 <- stats::qnorm((k[temp] + 1) / (R + 1))
240	4x	tk <- tstar[k[temp]]
241	4x	tk1 <- tstar[k[temp] + 1L]
242	4x	out[temp] <- tk + (temp1 - temp2) / (temp3 - temp2) * (tk1 - tk)
243	4x	out
244		}
245
246		# Bootstrap ====================================================================
247		#' @export
248		#' @rdname bootstrap
249		#' @aliases bootstrap,numeric-method
250		setMethod(
251		f = "bootstrap",
252		signature = c(object = "numeric"),
253		definition = function(object, do, n, ..., f = NULL, level = 0.95,
254		interval = c("basic", "normal", "percentiles")) {
255	2x	interval <- match.arg(interval, several.ok = FALSE)
256
257	2x	hat <- do(object, ...)
258
259	2x	spl <- sample(object, size = length(object) * n, replace = TRUE)
260	2x	replicates <- t(matrix(spl, nrow = n))
261	2x	values <- apply(X = replicates, MARGIN = 2, FUN = do, ...)
262
263	1x	if (is.function(f)) return(f(values))
264	1x	summary_bootstrap(values, hat, level = level, interval = interval)
265		}
266		)
267
268		summary_bootstrap <- function(x, hat, level = 0.95, interval = "basic") {
269	1x	n <- length(x)
270	1x	boot_mean <- mean(x)
271	1x	boot_bias <- boot_mean - hat
272	1x	boot_error <- stats::sd(x)
273
274	1x	ci <- confidence_bootstrap(x, level = level, t0 = hat, type = interval)
275	1x	results <- c(hat, boot_mean, boot_bias, boot_error, ci)
276	1x	names(results) <- c("original", "mean", "bias", "error", "lower", "upper")
277	1x	results
278		}
279
280		# Jaccknife ====================================================================
281		#' @export
282		#' @rdname jackknife
283		#' @aliases jackknife,numeric-method
284		setMethod(
285		f = "jackknife",
286		signature = c(object = "numeric"),
287		definition = function(object, do, ..., f = NULL) {
288	2x	n <- length(object)
289	2x	hat <- do(object, ...)
290
291	2x	values <- vapply(
292	2x	X = seq_len(n),
293	2x	FUN = function(i, x, do, ...) {
294	40x	do(x[-i], ...)
295		},
296	2x	FUN.VALUE = double(1),
297	2x	x = object, do = do, ...
298		)
299
300	1x	if (is.function(f)) return(f(values))
301	1x	summary_jackknife(values, hat)
302		}
303		)
304
305		summary_jackknife <- function(x, hat) {
306	1x	n <- length(x)
307	1x	jack_mean <- mean(x)
308	1x	jack_bias <- (n - 1) * (jack_mean - hat)
309	1x	jack_error <- sqrt(((n - 1) / n) * sum((x - jack_mean)^2))
310
311	1x	results <- c(hat, jack_mean, jack_bias, jack_error)
312	1x	names(results) <- c("original", "mean", "bias", "error")
313	1x	results
314		}
315
316		# Resample =====================================================================
317		#' @export
318		#' @rdname resample_uniform
319		#' @aliases resample_uniform,numeric-method
320		setMethod(
321		f = "resample_uniform",
322		signature = c(object = "numeric"),
323		definition = function(object, n, size = length(object), replace = FALSE, ...) {
324	1x	spl <- replicate(
325	1x	n = n,
326	1x	expr = sample(object, size = size, replace = replace),
327	1x	simplify = FALSE
328		)
329	1x	do.call(rbind, spl)
330		}
331		)
332
333		#' @export
334		#' @rdname resample_multinomial
335		#' @aliases resample_multinomial,numeric-method
336		setMethod(
337		f = "resample_multinomial",
338		signature = c(object = "numeric"),
339		definition = function(object, n, size = sum(object), ...) {
340	1x	prob <- object / sum(object)
341	1x	t(stats::rmultinom(n, size = size, prob = prob))
342		}
343		)

1		# DATA CLEANING: KEEP
2		#' @include AllGenerics.R
3		NULL
4
5		# keep =========================================================================
6		#' @export
7		#' @rdname keep
8		#' @aliases keep,ANY-method
9		setMethod(
10		f = "keep",
11		signature = c(x = "ANY"),
12		definition = function(x, f, margin = 1, negate = FALSE, all = FALSE,
13		na.rm = FALSE, verbose = getOption("arkhe.verbose"),
14		...) {
15	10x	i <- detect(x, f = f, margin = margin, negate = negate, all = all,
16	10x	na.rm = na.rm, ...)
17	10x	discard_message(x, keep = i, margin = margin, verbose = verbose)
18	5x	if (any(margin == 1)) return(x[i, , drop = FALSE])
19	5x	if (any(margin == 2)) return(x[, i, drop = FALSE])
20	!	i
21		}
22		)
23
24		#' @export
25		#' @rdname keep
26		#' @aliases keep_rows,ANY-method
27		setMethod(
28		f = "keep_rows",
29		signature = c(x = "ANY"),
30		definition = function(x, f, negate = FALSE, all = FALSE, na.rm = FALSE,
31		verbose = getOption("arkhe.verbose"), ...) {
32	5x	keep(x, f, margin = 1, negate = negate, all = all, na.rm = na.rm,
33	5x	verbose = verbose, ...)
34		}
35		)
36
37		#' @export
38		#' @rdname keep
39		#' @aliases keep_columns,ANY-method
40		setMethod(
41		f = "keep_columns",
42		signature = c(x = "ANY"),
43		definition = function(x, f, negate = FALSE, all = FALSE, na.rm = FALSE,
44		verbose = getOption("arkhe.verbose"), ...) {
45	5x	keep(x, f, margin = 2, negate = negate, all = all, na.rm = na.rm,
46	5x	verbose = verbose, ...)
47		}
48		)

1		# DATA CLEANING: DETECT
2		#' @include AllGenerics.R
3		NULL
4
5		# Detect =======================================================================
6		#' @export
7		#' @rdname detect
8		#' @aliases detect,ANY-method
9		setMethod(
10		f = "detect",
11		signature = c(x = "ANY"),
12		definition = function(x, f, margin = 1, negate = FALSE, all = FALSE,
13		na.rm = FALSE, ...) {
14	59x	total <- count(x, f, margin = margin, negate = negate, na.rm = na.rm, ...)
15
16	59x	miss <- rep(0, length(total))
17	10x	if (na.rm) miss <- count(x, f = is.na, margin = margin)
18
19	59x	k <- 1
20	59x	if (all) {
21	15x	if (any(margin == 1)) k <- ncol(x) - miss
22	18x	if (any(margin == 2)) k <- nrow(x) - miss
23		}
24	59x	total >= k
25		}
26		)

1		# DATA SUMMARY: DESCRIBE
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname describe
7		#' @aliases describe,ANY-method
8		setMethod(
9		f = "describe",
10		signature = c(x = "ANY"),
11		definition = function(x) {
12		## Variable types
13	1x	msg_var <- describe_variables(x)
14
15		## Missing values
16	1x	msg_miss <- describe_missing(x)
17
18		## Check
19	1x	msg_val <- describe_check(x)
20
21	1x	cat(msg_var, msg_miss, msg_val, sep = "\n")
22
23		# tot <- list(
24		# m = m, p = p,
25		# n_numeric = n_num, n_categorial = n_cha, n_binary = n_bin,
26		# row_missing = m_NA, col_missing = p_NA,
27		# zero_values = spa, zero_variance = p_var
28		# )
29
30	1x	invisible(x)
31		}
32		)
33
34		describe_variables <- function(x) {
35	1x	m <- nrow(x)
36	1x	p <- ncol(x)
37
38	1x	msg_rows <- sprintf(ngettext(m, "%d observation", "%d observations"), m)
39	1x	msg_cols <- sprintf(ngettext(p, "%d variable", "%d variables"), p)
40	1x	title <- sprintf("%s, %s:", msg_rows, msg_cols)
41
42	1x	num <- detect(x, f = is.numeric, margin = 2)
43	1x	bin <- detect(x, f = is.logical, margin = 2)
44	1x	n_num <- sum(num)
45	1x	n_bin <- sum(bin)
46	1x	n_cha <- sum(!num & !bin)
47
48	1x	msg_num <- sprintf(ngettext(n_num, "%d numeric variable", "%d numeric variables"), n_num)
49	1x	msg_bin <- sprintf(ngettext(n_bin, "%d binary variable", "%d binary variables"), n_bin)
50	1x	msg_cha <- sprintf(ngettext(n_cha, "%d categorial variable", "%d categorial variables"), n_cha)
51
52	1x	msg <- paste0(sprintf("\n* %s.", c(msg_num, msg_cha, msg_bin)), collapse = "")
53	1x	paste0(title, msg, collapse = "")
54		}
55		describe_missing <- function(x) {
56	1x	m <- nrow(x)
57	1x	p <- ncol(x)
58
59	1x	n_NA <- sum(count(x, f = is.na))
60	1x	m_NA <- sum(detect(x, f = is.na, margin = 1))
61	1x	p_NA <- sum(detect(x, f = is.na, margin = 2))
62	1x	pc <- label_percent(c(m_NA / m, p_NA / p), digits = 1, trim = TRUE)
63
64	1x	title <- sprintf(ngettext(n_NA, "%d missing value:", "%d missing values:"), n_NA)
65
66	1x	rows_NA <- ngettext(m_NA, "%d observation (%s) contains missing values",
67	1x	"%d observations (%s) contain missing values")
68	1x	msg_row_NA <- sprintf(rows_NA, m_NA, pc[[1]])
69
70	1x	cols_NA <- ngettext(p_NA, "%d variable (%s) contains missing values",
71	1x	"%d variables (%s) contain missing values")
72	1x	msg_col_NA <- sprintf(cols_NA, p_NA, pc[[2]])
73
74	1x	msg <- paste0(sprintf("\n* %s.", c(msg_row_NA, msg_col_NA)), collapse = "")
75	1x	paste0("\n", title, msg, collapse = "")
76		}
77		describe_check <- function(x) {
78	1x	title <- tr_("Data checking:")
79
80		## Constant columns
81	1x	p_var <- sum(detect(x, f = function(x) is_unique(x), margin = 2))
82	1x	cols_var <- ngettext(p_var, "%d variable with no variance",
83	1x	"%d variables with no variance")
84	1x	msg_col_var <- sprintf(cols_var, p_var)
85
86		## Sparsity
87	1x	spa <- sparsity(x, count = FALSE)
88	1x	msg_spa <- sprintf(tr_("%s of numeric values are zero"), label_percent(spa, digits = 1))
89
90	1x	msg <- paste0(sprintf("\n* %s.", c(msg_spa, msg_col_var)), collapse = "")
91	1x	paste0("\n", title, msg, collapse = "")
92		}
93
94		#' Label Percentages
95		#'
96		#' @param x A [`numeric`] vector.
97		#' @param digits An [`integer`] indicating the number of decimal places.
98		#' If `NULL` (the default), breaks will have the minimum number of digits
99		#' needed to show the difference between adjacent values.
100		#' @param trim A [`logical`] scalar. If `FALSE` (the default), values are
101		#' right-justified to a common width (see [base::format()]).
102		#' @return A [`character`] vector.
103		#' @keywords internal
104		#' @export
105		label_percent <- function(x, digits = NULL, trim = FALSE) {
106	4x	i <- !is.na(x)
107	4x	y <- x[i]
108	4x	y <- abs(y) * 100
109	4x	y <- format(y, trim = trim, digits = digits)
110	4x	y <- paste0(y, "%")
111	4x	x[i] <- y
112	4x	x
113		}

1		# CHECK DATA INPUT
2		#' @include predicates.R
3		NULL
4
5		#' Validate a Condition
6		#'
7		#' @param expr An object to be evaluated.
8		#' @return
9		#' Returns `NULL` on success, otherwise returns the error as a string.
10		#' @author N. Frerebeau
11		#' @family validation methods
12		#' @name validate
13		#' @rdname validate
14		#' @export
15		validate <- function(expr) {
16	3x	cnd <- catch_message(eval(expr))
17	2x	if (has_length(cnd)) return(cnd)
18	1x	NULL
19		}
20
21		# Packages =====================================================================
22		#' Check the Availability of a Package
23		#'
24		#' @param x A [`character`] vector naming the packages to check.
25		#' @param ask A [`logical`] scalar: should the user be asked to select packages
26		#' before they are downloaded and installed?
27		#' @details
28		#' `assert_package()` is designed for use inside other functions in your own
29		#' package to check for the availability of a suggested package.
30		#'
31		#' If the required packages are not available and \R is running interactively,
32		#' the user will be asked to install the packages.
33		#' @return Invisibly returns `NULL`.
34		#' @family checking methods
35		#' @author N. Frerebeau
36		#' @export
37		assert_package <- function(x, ask = interactive()) {
38	1x	ok <- vapply(X = x, FUN = requireNamespace, FUN.VALUE = logical(1),
39	1x	quietly = TRUE)
40
41	1x	miss <- x[!ok]
42	1x	n <- length(miss)
43
44	1x	if (n > 0) {
45	1x	err <- sprintf(
46	1x	ngettext(n, "Package %s is required.", "Packages %s are required."),
47	1x	paste0(sQuote(miss), collapse = ", ")
48		)
49	1x	install <- FALSE
50	1x	if (isTRUE(ask)) {
51	!	msg <- ngettext(n, "Do you want to install it?", "Do you want to install them?")
52	!	install <- utils::askYesNo(
53	!	msg = paste0(c(err, msg), collapse = "\n"),
54	!	default = FALSE,
55	!	prompts = gettext(c("Yes", "No", "Cancel"))
56		)
57		}
58	1x	if (isTRUE(install)) {
59	!	utils::install.packages(miss)
60		} else {
61	1x	throw_error("error_missing_package", err)
62		}
63		}
64	!	invisible(NULL)
65		}
66
67		# Attributes ===================================================================
68		#' Check Object Length(s)
69		#'
70		#' @param x An object to be checked.
71		#' @param expected An appropriate expected value.
72		#' @param allow_empty A [`logical`] scalar: should [empty][is_empty()] object be
73		#' ignored?
74		#' @param allow_null A [`logical`] scalar: should `NULL` object be ignored?
75		#' @param empty Deprecated.
76		#' @return
77		#' Throws an error, if any, and returns `x` invisibly otherwise.
78		#' @author N. Frerebeau
79		#' @family checking methods
80		#' @export
81		assert_length <- function(x, expected, allow_empty = empty, allow_null = FALSE, empty = FALSE) {
82	1x	if (is.null(x) && isTRUE(allow_null)) return(invisible(NULL))
83
84	27x	arg <- deparse(substitute(x))
85	27x	if (!(allow_empty && is_empty(x)) && !has_length(x, n = expected)) {
86	4x	txt <- tr_("%s must be of length %d; not %d.")
87	4x	msg <- sprintf(txt, sQuote(arg), expected, length(x))
88	4x	throw_error("error_bad_length", msg)
89		}
90	23x	invisible(x)
91		}
92
93		#' @export
94		#' @rdname assert_length
95		assert_lengths <- function(x, expected) {
96	2x	arg <- deparse(substitute(x))
97	2x	n <- lengths(x)
98	2x	if (!all(n == expected)) {
99	1x	txt <- tr_("Elements of %s must be of lengths %s; not %s.")
100	1x	msg <- sprintf(txt, sQuote(arg), paste0(expected, collapse = ", "),
101	1x	paste0(n, collapse = ", "))
102	1x	throw_error("error_bad_length", msg)
103		}
104	1x	invisible(x)
105		}
106
107		#' Check Object Dimensions
108		#'
109		#' @param x An object to be checked.
110		#' @param expected An appropriate expected value.
111		#' @return
112		#' Throws an error, if any, and returns `x` invisibly otherwise.
113		#' @author N. Frerebeau
114		#' @family checking methods
115		#' @export
116		assert_dim <- function(x, expected) {
117	2x	arg <- deparse(substitute(x))
118	2x	n <- dim(x)
119	2x	if (!all(n == expected)) {
120	1x	txt <- tr_("%s must be of dimension %s; not %s.")
121	1x	msg <- sprintf(txt, sQuote(arg), paste0(expected, collapse = " x "),
122	1x	paste0(n, collapse = " x "))
123	1x	throw_error("error_bad_dimensions", msg)
124		}
125	1x	invisible(x)
126		}
127
128		#' @export
129		#' @rdname assert_dim
130		assert_nrow <- function(x, expected) {
131	1x	arg <- deparse(substitute(x))
132	1x	n <- nrow(x)
133	1x	if (n != expected) {
134	1x	txt <- ngettext(expected, "%s must have %s row; not %s.",
135	1x	"%s must have %s rows; not %s.")
136	1x	msg <- sprintf(txt, sQuote(arg), expected, n)
137	1x	throw_error("error_bad_dimensions", msg)
138		}
139	!	invisible(x)
140		}
141
142		#' @export
143		#' @rdname assert_dim
144		assert_ncol <- function(x, expected) {
145	1x	arg <- deparse(substitute(x))
146	1x	n <- ncol(x)
147	1x	if (n != expected) {
148	1x	txt <- ngettext(expected, "%s must have %s column; not %s.",
149	1x	"%s must have %s columns; not %s.")
150	1x	msg <- sprintf(txt, sQuote(arg), expected, n)
151	1x	throw_error("error_bad_dimensions", msg)
152		}
153	!	invisible(x)
154		}
155
156		#' Check Object Filling
157		#'
158		#' Checks if an object is (not) empty.
159		#' @param x An object to be checked.
160		#' @return
161		#' Throws an error, if any, and returns `x` invisibly otherwise.
162		#' @author N. Frerebeau
163		#' @family checking methods
164		#' @export
165		assert_empty <- function(x) {
166	2x	arg <- deparse(substitute(x))
167	2x	if (!is_empty(x)) {
168	1x	msg <- sprintf(tr_("%s must be empty."), sQuote(arg))
169	1x	throw_error("error_bad_dimensions", msg)
170		}
171	1x	invisible(x)
172		}
173
174		#' @export
175		#' @rdname assert_empty
176		assert_filled <- function(x) {
177	18x	arg <- deparse(substitute(x))
178	18x	if (is_empty(x)) {
179	2x	msg <- sprintf(tr_("%s must not be empty."), sQuote(arg))
180	2x	throw_error("error_bad_dimensions", msg)
181		}
182	16x	invisible(x)
183		}
184
185		# Names ========================================================================
186		#' Check Object Names
187		#'
188		#' @param x An object to be checked.
189		#' @param expected An appropriate expected value.
190		#' @return
191		#' Throws an error, if any, and returns `x` invisibly otherwise.
192		#' @author N. Frerebeau
193		#' @family checking methods
194		#' @export
195		assert_names <- function(x, expected = NULL) {
196	4x	arg <- deparse(substitute(x))
197	4x	if (!has_names(x, names = expected)) {
198	3x	if (is.null(expected)) {
199	1x	msg <- sprintf(tr_("%s must have names."), sQuote(arg))
200		} else {
201	2x	msg <- sprintf(tr_("%s must have the following names: %s."),
202	2x	sQuote(arg), paste0(expected, collapse = ", "))
203		}
204	3x	throw_error("error_bad_names", msg)
205		}
206	1x	invisible(x)
207		}
208
209		#' @export
210		#' @rdname assert_names
211		assert_rownames <- function(x, expected = NULL) {
212	3x	arg <- deparse(substitute(x))
213	3x	if (!has_rownames(x, names = expected)) {
214	2x	if (is.null(expected)) {
215	1x	msg <- sprintf(tr_("%s must have row names."), sQuote(arg))
216		} else {
217	1x	msg <- sprintf(tr_("%s must have the following row names: %s."),
218	1x	sQuote(arg), paste0(expected, collapse = ", "))
219		}
220	2x	throw_error("error_bad_names", msg)
221		}
222	1x	invisible(x)
223		}
224
225		#' @export
226		#' @rdname assert_names
227		assert_colnames <- function(x, expected = NULL) {
228	3x	arg <- deparse(substitute(x))
229	3x	if (!has_colnames(x, names = expected)) {
230	2x	if (is.null(expected)) {
231	1x	msg <- sprintf(tr_("%s must have column names."), sQuote(arg))
232		} else {
233	1x	msg <- sprintf(tr_("%s must have the following column names: %s."),
234	1x	sQuote(arg), paste0(expected, collapse = ", "))
235		}
236	2x	throw_error("error_bad_names", msg)
237		}
238	1x	invisible(x)
239		}
240
241		# NA/NaN/Inf/duplicates ========================================================
242		#' Check Missing Values
243		#'
244		#' Checks if an object contains any missing (`NA`, `NaN`) values.
245		#' @param x An object to be checked.
246		#' @return
247		#' Throws an error, if any, and returns `x` invisibly otherwise.
248		#' @author N. Frerebeau
249		#' @family checking methods
250		#' @export
251		assert_missing <- function(x) {
252	3x	arg <- deparse(substitute(x))
253	3x	n <- sum(is.na(x))
254	3x	if (n > 0) {
255	2x	txt <- ngettext(n, "%s must not contain missing values (%d detected).",
256	2x	"%s must not contain missing values (%d detected).")
257	2x	msg <- sprintf(txt, sQuote(arg), n)
258	2x	throw_error("error_data_missing", msg)
259		}
260	1x	invisible(x)
261		}
262
263		#' Check Infinite Values
264		#'
265		#' Checks if an object contains any infinite (`Inf`) values.
266		#' @param x An object to be checked.
267		#' @return
268		#' Throws an error, if any, and returns `x` invisibly otherwise.
269		#' @author N. Frerebeau
270		#' @family checking methods
271		#' @export
272		assert_infinite <- function(x) {
273	2x	arg <- deparse(substitute(x))
274	2x	n <- sum(is.infinite(x))
275	2x	if (n > 0) {
276	1x	txt <- ngettext(n, "%s must not contain infinite values (%d detected).",
277	1x	"%s must not contain infinite values (%d detected).")
278	1x	msg <- sprintf(txt, sQuote(arg), n)
279	1x	throw_error("error_data_infinite", msg)
280		}
281	1x	invisible(x)
282		}
283
284		#' Check Duplicates
285		#'
286		#' Checks if an object contains duplicated elements.
287		#' @param x An object to be checked.
288		#' @return
289		#' Throws an error, if any, and returns `x` invisibly otherwise.
290		#' @author N. Frerebeau
291		#' @family checking methods
292		#' @export
293		assert_unique <- function(x) {
294	2x	arg <- deparse(substitute(x))
295	2x	if (has_duplicates(x)) {
296	1x	msg <- sprintf(tr_("Elements of %s must be unique."), sQuote(arg))
297	1x	throw_error("error_data_duplicates", msg)
298		}
299	1x	invisible(x)
300		}
301
302		# Types ========================================================================
303		#' Check Data Types
304		#'
305		#' @param x An object to be checked.
306		#' @param expected A [`character`] string specifying the expected
307		#' type. It must be one of "`list`", "`atomic`", "`vector`", "`numeric`",
308		#' "`integer`", "`double`", "`character`" or "`logical`".
309		#' @param allow_empty A [`logical`] scalar: should [empty][is_empty()] object be
310		#' allowed?
311		#' @param allow_null A [`logical`] scalar: should `NULL` object be ignored?
312		#' @return
313		#' Throws an error, if any, and returns `x` invisibly otherwise.
314		#' @author N. Frerebeau
315		#' @family checking methods
316		#' @export
317		assert_type <- function(x, expected, allow_empty = TRUE, allow_null = FALSE) {
318	15x	if (is.null(x) && isTRUE(allow_null)) return(invisible(NULL))
319	1x	if (isFALSE(allow_empty)) assert_filled(x)
320
321	174x	arg <- deparse(substitute(x))
322	174x	msg <- sprintf(tr_("Can't find a predicate for this type: %s."), expected)
323	174x	predicate <- switch(
324	174x	expected,
325	174x	list = is_list,
326	174x	atomic = is_atomic,
327	174x	vector = is_vector,
328	174x	numeric = is_numeric,
329	174x	integer = is_integer,
330	174x	double = is_double,
331	174x	character = is_character,
332	174x	logical = is_logical,
333	174x	stop(msg, call. = FALSE)
334		)
335	174x	if (!predicate(x)) {
336	12x	msg <- sprintf(tr_("%s must be %s; not %s."), sQuote(arg), expected, typeof(x))
337	12x	throw_error("error_bad_type", msg)
338		}
339	162x	invisible(x)
340		}
341
342		#' @export
343		#' @rdname assert_type
344		assert_scalar <- function(x, expected) {
345	35x	arg <- deparse(substitute(x))
346	35x	msg <- sprintf(tr_("Can't find a predicate for this scalar: %s."), expected)
347	35x	predicate <- switch(
348	35x	expected,
349	35x	list = is_scalar_list,
350	35x	atomic = is_scalar_atomic,
351	35x	vector = is_scalar_vector,
352	35x	numeric = is_scalar_numeric,
353	35x	integer = is_scalar_integer,
354	35x	double = is_scalar_double,
355	35x	character = is_scalar_character,
356	35x	logical = is_scalar_logical,
357	35x	stop(msg, call. = FALSE)
358		)
359	35x	if (!predicate(x)) {
360	2x	msg <- sprintf(tr_("%s must be a scalar (%s)."), sQuote(arg), expected)
361	2x	throw_error("error_bad_scalar", msg)
362		}
363	33x	invisible(x)
364		}
365
366		#' @export
367		#' @rdname assert_type
368		assert_function <- function(x) {
369	92x	arg <- deparse(substitute(x))
370	92x	if (!is.function(x)) {
371	1x	msg <- sprintf(tr_("%s must be a function."), sQuote(arg))
372	1x	throw_error("error_bad_type", msg)
373		}
374	91x	invisible(x)
375		}
376
377		# Numeric ======================================================================
378		#' Check Numeric Values
379		#'
380		#' @param x A [`numeric`] object to be checked.
381		#' @param na.rm A [`logical`] scalar: should missing values (including `NaN`)
382		#' be omitted?
383		#' @param ... Extra parameters to be passed to internal methods.
384		#' @return
385		#' Throws an error, if any, and returns `x` invisibly otherwise.
386		#' @author N. Frerebeau
387		#' @family checking methods
388		#' @name assert_numeric
389		#' @rdname assert_numeric
390		NULL
391
392		#' @export
393		#' @rdname assert_numeric
394		assert_count <- function(x, na.rm = FALSE, ...) {
395	4x	arg <- deparse(substitute(x))
396	4x	if (!all(is_whole(x, ...), na.rm = na.rm)) {
397	3x	msg <- sprintf(tr_("%s must contain integers (counts)."), sQuote(arg))
398	3x	throw_error("error_bad_numeric", msg)
399		}
400	1x	invisible(x)
401		}
402
403		#' @export
404		#' @rdname assert_numeric
405		assert_whole <- assert_count
406
407		#' @export
408		#' @rdname assert_numeric
409		assert_positive <- function(x, na.rm = FALSE, ...) {
410	3x	arg <- deparse(substitute(x))
411	3x	if (!all(is_positive(x, ...), na.rm = na.rm)) {
412	2x	msg <- sprintf(tr_("%s must contain positive numbers."), sQuote(arg))
413	2x	throw_error("error_bad_numeric", msg)
414		}
415	1x	invisible(x)
416		}
417
418		#' @export
419		#' @rdname assert_numeric
420		assert_negative <- function(x, na.rm = FALSE, ...) {
421	!	arg <- deparse(substitute(x))
422	!	if (!all(is_negative(x, ...), na.rm = na.rm)) {
423	!	msg <- sprintf(tr_("%s must contain negative numbers."), sQuote(arg))
424	!	throw_error("error_bad_numeric", msg)
425		}
426	!	invisible(x)
427		}
428
429		#' @export
430		#' @rdname assert_numeric
431		assert_odd <- function(x, na.rm = FALSE, ...) {
432	1x	arg <- deparse(substitute(x))
433	1x	if (!all(is_odd(x, ...), na.rm = na.rm)) {
434	1x	msg <- sprintf(tr_("%s must contain odd numbers."), sQuote(arg))
435	1x	throw_error("error_bad_numeric", msg)
436		}
437	!	invisible(x)
438		}
439
440		#' @export
441		#' @rdname assert_numeric
442		assert_even <- function(x, na.rm = FALSE, ...) {
443	1x	arg <- deparse(substitute(x))
444	1x	if (!all(is_even(x, ...), na.rm = na.rm)) {
445	1x	msg <- sprintf(tr_("%s must contain even numbers."), sQuote(arg))
446	1x	throw_error("error_bad_numeric", msg)
447		}
448	!	invisible(x)
449		}
450
451		#' Check Numeric Trend
452		#'
453		#' @param x A [`numeric`] object to be checked.
454		#' @param ... Extra parameters to be passed to internal methods.
455		#' @return
456		#' Throws an error, if any, and returns `x` invisibly otherwise.
457		#' @author N. Frerebeau
458		#' @family checking methods
459		#' @export
460		assert_constant <- function(x, ...) {
461	1x	arg <- deparse(substitute(x))
462	1x	if (!is_constant(x, ...)) {
463	1x	msg <- sprintf(tr_("%s must be constant."), sQuote(arg))
464	1x	throw_error("error_bad_numeric", msg)
465		}
466	!	invisible(x)
467		}
468
469		#' @export
470		#' @rdname assert_constant
471		assert_decreasing <- function(x, ...) {
472	1x	arg <- deparse(substitute(x))
473	1x	if (!is_decreasing(x, ...)) {
474	1x	msg <- sprintf(tr_("%s must be decreasing."), sQuote(arg))
475	1x	throw_error("error_bad_numeric", msg)
476		}
477	!	invisible(x)
478		}
479
480		#' @export
481		#' @rdname assert_constant
482		assert_increasing <- function(x, ...) {
483	2x	arg <- deparse(substitute(x))
484	2x	if (!is_increasing(x, ...)) {
485	1x	msg <- sprintf(tr_("%s must be increasing."), sQuote(arg))
486	1x	throw_error("error_bad_numeric", msg)
487		}
488	1x	invisible(x)
489		}
490
491		#' Check Numeric Relations
492		#'
493		#' @param x,y A [`numeric`] object to be checked.
494		#' @param ... Extra parameters to be passed to internal methods.
495		#' @return
496		#' Throws an error, if any, and returns `x` invisibly otherwise.
497		#' @author N. Frerebeau
498		#' @family checking methods
499		#' @export
500		assert_lower <- function(x, y, ...) {
501	2x	arg_x <- deparse(substitute(x))
502	2x	arg_y <- deparse(substitute(y))
503	2x	if (!is_lower(x, y, ...)) {
504	1x	txt <- tr_("%s must be lower than %s.")
505	1x	msg <- sprintf(txt, sQuote(arg_x), sQuote(arg_y))
506	1x	throw_error("error_bad_numeric", msg)
507		}
508	1x	invisible(x)
509		}
510
511		#' @export
512		#' @rdname assert_lower
513		assert_greater <- function(x, y, ...) {
514	1x	arg_x <- deparse(substitute(x))
515	1x	arg_y <- deparse(substitute(y))
516	1x	if (!is_greater(x, y, ...)) {
517	1x	txt <- tr_("%s must be greater than %s.")
518	1x	msg <- sprintf(txt, sQuote(arg_x), sQuote(arg_y))
519	1x	throw_error("error_bad_numeric", msg)
520		}
521	!	invisible(x)
522		}
523
524		# Matrix =======================================================================
525		#' Check Matrix
526		#'
527		#' @param x A [`matrix`] to be checked.
528		#' @return Throw an error, if any, and returns `x` invisibly otherwise.
529		#' @author N. Frerebeau
530		#' @family checking methods
531		#' @export
532		assert_square <- function(x) {
533	2x	arg <- deparse(substitute(x))
534	2x	if (!is_square(x)) {
535	1x	k <- paste0(dim(x), collapse = " x ")
536	1x	msg <- sprintf(tr_("%s must be a square matrix, not %s."), sQuote(arg), k)
537	1x	throw_error("error_bad_matrix", msg)
538		}
539	1x	invisible(x)
540		}
541
542		#' @export
543		#' @rdname assert_square
544		assert_symmetric <- function(x) {
545	1x	arg <- deparse(substitute(x))
546	1x	if (!is_symmetric(x)) {
547	1x	msg <- sprintf(tr_("%s must be a symmetric matrix."), sQuote(arg))
548	1x	throw_error("error_bad_matrix", msg)
549		}
550	!	invisible(x)
551		}
552
553		# Check Graph
554		#
555		# @param x A [`matrix`] to be checked.
556		# @param expected An appropriate expected value.
557		# @return Throw an error, if any.
558		# @author N. Frerebeau
559		# @family checking methods
560		# @keywords internal
561		# @export
562		# assert_dag <- function(x) {
563		# arg <- deparse(substitute(x))
564		# if (!is_dag(x)) {
565		# msg <- sprintf(tr_("%s must not contain cycles."), sQuote(arg))
566		# throw_error("error_bad_graph", msg)
567		# }
568		# invisible(x)
569		# }

1		# SEEK
2
3		cols <- function(...) {
4	!	x <- c(...)
5	!	function(ctx) match(x, names(ctx))
6		}
7
8		seek <- function(x, margin = 2, select = NULL, names = NULL, ...) {
9	16x	assert_filled(x)
10	16x	assert_length(margin, 1)
11	16x	assert_type(names, "character", allow_null = TRUE)
12
13	14x	dm <- dim(x)[[margin]]
14	14x	nm <- dimnames(x)[[margin]]
15	!	if (is.null(nm)) return(NULL)
16
17	14x	if (is.null(select)) {
18	2x	if (is.null(names)) return(NULL)
19	4x	select <- function(i) match(names, i)
20		}
21
22	12x	assert_function(select)
23	12x	i <- select(nm, ...)
24
25	8x	if (is.logical(i)) i <- which(i)
26	4x	if (length(i) == 0 \|\| all(is.na(i))) i <- NULL
27	12x	assert_type(i, "integer", allow_null = TRUE)
28	12x	i
29		}
30
31		#' @export
32		#' @rdname seek
33		#' @aliases seek_rows,data.frame-method
34		setMethod(
35		f = "seek_rows",
36		signature = c(x = "data.frame"),
37		definition = function(x, select = NULL, names = NULL, ...) {
38	7x	seek(x, margin = 1, select = select, names = names, ...)
39		}
40		)
41
42		#' @export
43		#' @rdname seek
44		#' @aliases seek_rows,matrix-method
45		setMethod(
46		f = "seek_rows",
47		signature = c(x = "matrix"),
48		definition = function(x, select = NULL, names = NULL, ...) {
49	1x	seek(x, margin = 1, select = select, names = names, ...)
50		}
51		)
52
53		#' @export
54		#' @rdname seek
55		#' @aliases seek_columns,data.frame-method
56		setMethod(
57		f = "seek_columns",
58		signature = c(x = "data.frame"),
59		definition = function(x, select = NULL, names = NULL, ...) {
60	7x	seek(x, margin = 2, select = select, names = names, ...)
61		}
62		)
63
64		#' @export
65		#' @rdname seek
66		#' @aliases seek_columns,matrix-method
67		setMethod(
68		f = "seek_columns",
69		signature = c(x = "matrix"),
70		definition = function(x, select = NULL, names = NULL, ...) {
71	1x	seek(x, margin = 2, select = select, names = names, ...)
72		}
73		)

1		# PREDICATES
2
3		# Not exported =================================================================
4		is_zero_numeric <- function(x, tolerance = sqrt(.Machine$double.eps)) {
5	35x	if (is.numeric(x)) return(abs(x) <= tolerance)
6	14x	rep(FALSE, length(x))
7		}
8
9		# Attributes ===================================================================
10		#' Attributes Predicates
11		#'
12		#' * `has_length()` checks how long is an object.
13		#' * `is_empty()` checks is an object is empty (any zero-length dimensions).
14		#' @param x A [`vector`] to be tested.
15		#' @param n A length-one [`numeric`] vector specifying the length to test `x`
16		#' with. If `NULL`, returns `TRUE` if `x` has length greater than zero, and
17		#' `FALSE` otherwise.
18		#' @return A [`logical`] scalar.
19		#' @family predicates
20		#' @name predicate-attributes
21		#' @rdname predicate-attributes
22		NULL
23
24		#' @export
25		#' @rdname predicate-attributes
26		has_length <- function(x, n = NULL) {
27	16x	if (is.null(n)) length(x) > 0 else length(x) == n
28		}
29
30		#' @export
31		#' @rdname predicate-attributes
32		is_empty <- function(x) {
33	17x	if (!is.null(dim(x))) nrow(x) == 0 \|\| ncol(x) == 0
34	8x	else length(x) == 0
35		}
36
37		# Names ========================================================================
38		#' Names Predicates
39		#'
40		#' Checks if an object is named.
41		#' @param x A [`vector`] to be tested.
42		#' @param names A [`character`] vector specifying the names to test `x`
43		#' with. If `NULL`, returns `TRUE` if `x` has names, and `FALSE` otherwise.
44		#' @return A [`logical`] scalar.
45		#' @family predicates
46		#' @name predicate-names
47		#' @rdname predicate-names
48		NULL
49
50		#' @export
51		#' @rdname predicate-names
52		has_names <- function(x, names = NULL) {
53	9x	if (is.null(names)) {
54	6x	has_length(names(x))
55		} else {
56	3x	identical(names(x), names)
57		}
58		}
59
60		#' @export
61		#' @rdname predicate-names
62		has_rownames <- function(x, names = NULL) {
63	6x	if (is.null(names)) {
64	4x	has_length(rownames(x))
65		} else {
66	2x	identical(rownames(x), names)
67		}
68		}
69
70		#' @export
71		#' @rdname predicate-names
72		has_colnames <- function(x, names = NULL) {
73	3x	if (is.null(names)) {
74	1x	has_length(colnames(x))
75		} else {
76	2x	identical(colnames(x), names)
77		}
78		}
79
80		# NA/NaN/Inf/duplicates ========================================================
81		#' Utility Predicates
82		#'
83		#' * `has_missing()` and `has_infinite()` check if an object contains missing
84		#' or infinite values.
85		#' * `has_duplicates()` checks if an object has duplicated elements.
86		#' @param x A [`vector`] to be tested.
87		#' @param tolerance A [`numeric`] scalar giving the tolerance to check within
88		#' (for `numeric` vector).
89		#' @param na.rm A [`logical`] scalar: should missing values (including `NaN`)
90		#' be omitted?
91		#' @return A [`logical`] scalar.
92		#' @family predicates
93		#' @name predicate-data
94		#' @rdname predicate-data
95		NULL
96
97		#' @export
98		#' @rdname predicate-data
99		has_missing <- function(x) {
100	3x	anyNA(x)
101		}
102
103		#' @export
104		#' @rdname predicate-data
105		has_infinite <- function(x) {
106	3x	any(is.infinite(x))
107		}
108
109		#' @export
110		#' @rdname predicate-data
111		has_duplicates <- function(x) {
112	4x	anyDuplicated(x) > 0
113		}
114
115		is_duplicated <- function(x) {
116	!	duplicated(x, fromLast = FALSE) \| duplicated(x, fromLast = TRUE)
117		}
118
119		#' @export
120		#' @rdname predicate-data
121		is_unique <- function(x, tolerance = sqrt(.Machine$double.eps), na.rm = FALSE) {
122	2x	if (na.rm) x <- stats::na.omit(x)
123	13x	if (is.numeric(x)) {
124	11x	cte <- is_constant(x, tolerance = tolerance)
125	3x	if (is.na(cte)) cte <- FALSE
126		} else {
127	2x	cte <- length(unique(x)) == 1
128		}
129	13x	cte
130		}
131
132		# Type =========================================================================
133		#' Type Predicates
134		#'
135		#' @param x An object to be tested.
136		#' @return A [`logical`] scalar.
137		#' @family predicates
138		#' @name predicate-type
139		#' @rdname predicate-type
140		NULL
141
142		#' @export
143		#' @rdname predicate-type
144		is_list <- function(x) {
145	7x	typeof(x) == "list"
146		}
147		#' @export
148		#' @rdname predicate-type
149		is_atomic <- function(x) {
150	14x	typeof(x) %in% c("logical", "integer", "double",
151	14x	"complex", "character", "raw")
152		}
153		#' @export
154		#' @rdname predicate-type
155		is_vector <- function(x) {
156	6x	is_atomic(x) \|\| is_list(x)
157		}
158		#' @export
159		#' @rdname predicate-type
160		is_numeric <- function(x) {
161	243x	typeof(x) %in% c("integer", "double")
162		}
163		#' @export
164		#' @rdname predicate-type
165		is_integer <- function(x) {
166	13x	typeof(x) == "integer"
167		}
168		#' @export
169		#' @rdname predicate-type
170		is_double <- function(x) {
171	5x	typeof(x) == "double"
172		}
173		#' @export
174		#' @rdname predicate-type
175		is_character <- function(x) {
176	31x	typeof(x) == "character"
177		}
178		#' @export
179		#' @rdname predicate-type
180		is_logical <- function(x) {
181	43x	typeof(x) == "logical"
182		}
183		#' @export
184		#' @rdname predicate-type
185		is_error <- function(x) {
186	2x	inherits(x, "try-error") \|\| inherits(x, "simpleError") \|\| inherits(x, "error")
187		}
188		#' @export
189		#' @rdname predicate-type
190		is_warning <- function(x) {
191	1x	inherits(x, "simpleWarning") \|\| inherits(x, "warning")
192		}
193		#' @export
194		#' @rdname predicate-type
195		is_message <- function(x) {
196	1x	inherits(x, "simpleMessage") \|\| inherits(x, "message")
197		}
198
199		# Scalar =======================================================================
200		#' Scalar Type Predicates
201		#'
202		#' @param x An object to be tested.
203		#' @return A [`logical`] scalar.
204		#' @family predicates
205		#' @name is_scalar
206		#' @rdname is_scalar
207		NULL
208
209		#' @export
210		#' @rdname is_scalar
211		is_scalar_list <- function(x) {
212	3x	is_list(x) && length(x) == 1
213		}
214		#' @export
215		#' @rdname is_scalar
216		is_scalar_atomic <- function(x) {
217	3x	is_atomic(x) && length(x) == 1
218		}
219		#' @export
220		#' @rdname is_scalar
221		is_scalar_vector <- function(x) {
222	3x	is_vector(x) && length(x) == 1
223		}
224		#' @export
225		#' @rdname is_scalar
226		is_scalar_numeric <- function(x) {
227	31x	is_numeric(x) && length(x) == 1
228		}
229		#' @export
230		#' @rdname is_scalar
231		is_scalar_integer <- function(x) {
232	3x	is_integer(x) && length(x) == 1
233		}
234		#' @export
235		#' @rdname is_scalar
236		is_scalar_double <- function(x) {
237	3x	is_double(x) && length(x) == 1
238		}
239		#' @export
240		#' @rdname is_scalar
241		is_scalar_character <- function(x) {
242	9x	is_character(x) && length(x) == 1
243		}
244		#' @export
245		#' @rdname is_scalar
246		is_scalar_logical <- function(x) {
247	4x	is_logical(x) && length(x) == 1
248		}
249
250		# Numeric ======================================================================
251		#' Numeric Predicates
252		#'
253		#' Check numeric objects:
254		#' * `is_zero()` checks if an object contains only zeros.
255		#' * `is_odd()` and `is_even()` check if a number is odd or even, respectively.
256		#' * `is_positive()` and `is_negative` check if an object contains only
257		#' (strictly) positive or negative numbers.
258		#' * `is_whole()` checks if an object only contains whole numbers.
259		#' @param x A [`numeric`] object to be tested.
260		#' @param tolerance A [`numeric`] scalar giving the tolerance to check within.
261		#' @param strict A [`logical`] scalar: should strict inequality be used?
262		#' @param ... Currently not used.
263		#' @return A [`logical`] vector.
264		#' @family predicates
265		#' @name predicate-numeric
266		#' @rdname predicate-numeric
267		NULL
268
269		#' @export
270		#' @rdname predicate-numeric
271		is_zero <- function(x, tolerance = sqrt(.Machine$double.eps), ...) {
272	77x	assert_type(x, "numeric")
273	77x	abs(x) <= tolerance
274		}
275		#' @export
276		#' @rdname predicate-numeric
277		is_odd <- function(x, ...) { # impair
278	3x	assert_type(x, "numeric")
279	3x	as.logical(x %% 2)
280		}
281		#' @export
282		#' @rdname predicate-numeric
283		is_even <- function(x, ...) { # pair
284	2x	assert_type(x, "numeric")
285	2x	!as.logical(x %% 2)
286		}
287		#' @export
288		#' @rdname predicate-numeric
289		is_positive <- function(x, strict = FALSE, ...) {
290	7x	assert_type(x, "numeric")
291	2x	if (strict) x > 0 else x >= 0
292		}
293		#' @export
294		#' @rdname predicate-numeric
295		is_negative <- function(x, strict = FALSE, ...) {
296	4x	assert_type(x, "numeric")
297	1x	if (strict) x < 0 else x <= 0
298		}
299		#' @export
300		#' @rdname predicate-numeric
301		is_whole <- function(x, tolerance = sqrt(.Machine$double.eps), ...) {
302	9x	assert_type(x, "numeric")
303	8x	abs(x - round(x, digits = 0)) <= tolerance
304		}
305
306		#' Numeric Trend Predicates
307		#'
308		#' Check numeric objects:
309		#' * `is_constant()` checks for equality among all elements of a vector.
310		#' * `is_increasing()` and `is_decreasing()` check if a sequence of numbers
311		#' is monotonically increasing or decreasing, respectively.
312		#' @param x,y A [`numeric`] object to be tested.
313		#' @param tolerance A [`numeric`] scalar giving the tolerance to check within.
314		#' @param strict A [`logical`] scalar: should strict inequality be used?
315		#' @param na.rm A [`logical`] scalar: should missing values (including `NaN`)
316		#' be omitted?
317		#' @return A [`logical`] scalar.
318		#' @family predicates
319		#' @name predicate-trend
320		#' @rdname predicate-trend
321		NULL
322
323		#' @export
324		#' @rdname predicate-trend
325		is_constant <- function(x, tolerance = sqrt(.Machine$double.eps), na.rm = FALSE) {
326	18x	assert_type(x, "numeric")
327	17x	abs(max(x, na.rm = na.rm) - min(x, na.rm = na.rm)) <= tolerance
328		}
329		#' @export
330		#' @rdname predicate-trend
331		is_increasing <- function(x, na.rm = FALSE) {
332	8x	assert_type(x, "numeric")
333	1x	if (na.rm) x <- stats::na.omit(x)
334	7x	all(x == cummax(x))
335		}
336		#' @export
337		#' @rdname predicate-trend
338		is_decreasing <- function(x, na.rm = FALSE) {
339	7x	assert_type(x, "numeric")
340	1x	if (na.rm) x <- stats::na.omit(x)
341	6x	all(x == cummin(x))
342		}
343		#' @export
344		#' @rdname predicate-trend
345		is_greater <- function(x, y, strict = FALSE, na.rm = FALSE) {
346	4x	assert_type(x, "numeric")
347	4x	assert_type(y, "numeric")
348	4x	z <- if (strict) x > y else x >= y
349	4x	all(z, na.rm = na.rm)
350		}
351		#' @export
352		#' @rdname predicate-trend
353		is_lower <- function(x, y, strict = FALSE, na.rm = FALSE) {
354	7x	assert_type(x, "numeric")
355	6x	assert_type(y, "numeric")
356	5x	z <- if (strict) x < y else x <= y
357	5x	all(z, na.rm = na.rm)
358		}
359
360		# Matrix =======================================================================
361		#' Matrix Predicates
362		#'
363		#' * `is_square()` checks if a matrix is square.
364		#' * `is_symmetric()` checks if a matrix is symmetric.
365		#' @param x A [`matrix`] to be tested.
366		#' @return A [`logical`] scalar.
367		#' @family predicates
368		#' @name predicate-matrix
369		#' @rdname predicate-matrix
370		NULL
371
372		#' @export
373		#' @rdname predicate-matrix
374		is_square <- function(x) {
375	1x	if (is.matrix(x)) nrow(x) == ncol(x) else FALSE
376		}
377		#' @export
378		#' @rdname predicate-matrix
379		is_symmetric <- function(x) {
380	1x	if (is.matrix(x)) identical(x, t(x)) else FALSE
381		}
382
383		# Graph ========================================================================
384		# Graph Predicates
385		#
386		# `is_dag()` checks if a graph has a topological ordering (i.e. is a directed
387		# acyclic graph) using Kahn's algorithm.
388		# @param x An adjacency [`matrix`] to be tested.
389		# @return A [`logical`] scalar.
390		# @references
391		# Kahn, A. B. (1962). Topological sorting of large networks. *Communications
392		# of the ACM*, 5(11), p. 558-562. \doi{10.1145/368996.369025}.
393		# @family predicates
394		# @keywords internal
395		# @export
396		# is_dag <- function(x) {
397		# # Get edges
398		# G <- matrix2edges(x)
399		# # Find nodes which have no incoming edges
400		# S <- which(colSums(x) == 0)
401		# # List that will contain the sorted elements
402		# L <- list()
403		#
404		# if (length(S) == 0)
405		# return(FALSE)
406		#
407		# k <- 1L
408		# while (k == 1 \|\| length(S) != 0) {
409		# # Remove a node n from S and add n to tail of L
410		# n <- S[[1]]
411		# S <- S[-1]
412		# L <- append(L, n)
413		# # For each node m with an edge e from n to m
414		# e <- which(G[, 1] == n)
415		# m <- G[e, 2]
416		# # Do remove edge e from the graph
417		# G <- G[-e, , drop = FALSE]
418		# # If m has no other incoming edges then insert m into S
419		# if (nrow(G) != 0) {
420		# m <- m[!(m %in% G[, 2])]
421		# if (length(m) != 0)
422		# S <- append(S, m)
423		# }
424		# k <- k + 1
425		# }
426		# return(nrow(G) == 0)
427		# }
428
429		# matrix2edges <- function(from) {
430		# edges <- matrix(data = NA, nrow = 0, ncol = 2)
431		# nodes <- seq_len(nrow(from))
432		# for (i in nodes) {
433		# to <- which(from[i, ])
434		# if (length(to) != 0) {
435		# e <- cbind(form = i, to = to)
436		# edges <- rbind(edges, e)
437		# }
438		# }
439		#
440		# edges
441		# }

1		# DATA CLEANING: DISCARD
2		#' @include AllGenerics.R
3		NULL
4
5		# discard ======================================================================
6		#' @export
7		#' @rdname discard
8		#' @aliases discard,ANY-method
9		setMethod(
10		f = "discard",
11		signature = c(x = "ANY"),
12		definition = function(x, f, margin = 1, negate = FALSE, all = FALSE,
13		na.rm = FALSE, verbose = getOption("arkhe.verbose"),
14		...) {
15	39x	i <- detect(x, f = f, margin = margin, negate = negate, all = all,
16	39x	na.rm = na.rm, ...)
17	39x	discard_message(x, keep = !i, margin = margin, verbose = verbose)
18	19x	if (any(margin == 1)) return(x[!i, , drop = FALSE])
19	20x	if (any(margin == 2)) return(x[, !i, drop = FALSE])
20	!	i
21		}
22		)
23
24		#' @export
25		#' @rdname discard
26		#' @aliases discard_rows,ANY-method
27		setMethod(
28		f = "discard_rows",
29		signature = c(x = "ANY"),
30		definition = function(x, f, negate = FALSE, all = FALSE, na.rm = FALSE,
31		verbose = getOption("arkhe.verbose"), ...) {
32	4x	discard(x, f, margin = 1, negate = negate, all = all, na.rm = na.rm,
33	4x	verbose = verbose, ...)
34		}
35		)
36
37		#' @export
38		#' @rdname discard
39		#' @aliases discard_columns,ANY-method
40		setMethod(
41		f = "discard_columns",
42		signature = c(x = "ANY"),
43		definition = function(x, f, negate = FALSE, all = FALSE, na.rm = FALSE,
44		verbose = getOption("arkhe.verbose"), ...) {
45	4x	discard(x, f, margin = 2, negate = negate, all = all, na.rm = na.rm,
46	4x	verbose = verbose, ...)
47		}
48		)
49
50		#' Diagnostic Message
51		#'
52		#' Generates a diagnostic message describing columns or rows that are being
53		#' removed.
54		#' @param x A [`matrix`] or a [`data.frame`].
55		#' @param margin A length-one [`numeric`] vector giving the subscripts which the
56		#' function will be applied over (`1` indicates rows, `2` indicates columns).
57		#' @param keep A [`logical`] vector of rows or columns to keep (`TRUE`) or
58		#' remove (`FALSE`).
59		#' @param verbose A [`logical`] scalar: should the message be generated?
60		#' @keywords internal
61		#' @noRd
62		discard_message <- function(x, keep, margin,
63		verbose = getOption("arkhe.verbose")) {
64	49x	drop <- sum(!keep, na.rm = TRUE)
65	49x	what <- ngettext(drop, "element", "elements")
66	24x	if (any(margin == 1)) what <- ngettext(drop, "row", "rows")
67	25x	if (any(margin == 2)) what <- ngettext(drop, "column", "columns")
68
69	49x	if (drop == 0) {
70	21x	msg <- tr_("Nothing to remove.")
71		} else {
72	28x	pc <- sprintf("%0.3g%%", 100 * drop / length(keep))
73	28x	if (margin == 2 && !is.null(colnames(x))) {
74	6x	pc <- paste0(colnames(x)[!keep], collapse = ", ")
75		}
76	28x	msg <- tr_("Removing %g %s out of %g (%s).")
77	28x	msg <- sprintf(msg, drop, what, length(keep), pc)
78		}
79
80	8x	if (isTRUE(verbose)) message(msg)
81	49x	invisible(msg)
82		}

1		# DATA CLEANING: ASSIGN
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname assign
7		#' @aliases assign_rownames,data.frame-method
8		setMethod(
9		f = "assign_rownames",
10		signature = c(x = "data.frame"),
11		definition = function(x, column, remove = TRUE) {
12		## Validation
13	1x	assert_length(column, 1)
14	!	if ((column > ncol(x)) \|\| (column < 1)) return(x)
15
16	1x	y <- x
17	1x	rownames(y) <- y[, column]
18	1x	if (remove) {
19	1x	y <- y[, -column, drop = FALSE]
20		}
21	1x	y
22		}
23		)
24
25		#' @export
26		#' @rdname assign
27		#' @aliases assign_colnames,data.frame-method
28		setMethod(
29		f = "assign_colnames",
30		signature = c(x = "data.frame"),
31		definition = function(x, row, remove = TRUE) {
32		## Validation
33	1x	assert_length(row, 1)
34	!	if ((row > nrow(x)) \|\| (row < 1)) return(x)
35
36	1x	y <- x
37	1x	colnames(y) <- y[row, ]
38	1x	if (remove) {
39	1x	y <- y[-row, , drop = FALSE]
40		}
41	1x	y
42		}
43		)

1		# DATA SUMMARY: SPARCITY
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname sparsity
7		#' @aliases sparsity,matrix-method
8		setMethod(
9		f = "sparsity",
10		signature = c(x = "matrix"),
11		definition = function(x, count = FALSE) {
12	!	zeros <- sum(count(x, f = is_zero_numeric, margin = 2, na.rm = TRUE))
13	!	if (count) return(zeros)
14
15		## Proportion
16	!	total <- prod(dim(x))
17	!	zeros / total
18		}
19		)
20
21		#' @export
22		#' @rdname sparsity
23		#' @aliases sparsity,data.frame-method
24		setMethod(
25		f = "sparsity",
26		signature = c(x = "data.frame"),
27		definition = function(x, count = FALSE) {
28	3x	zeros <- sum(count(x, f = is_zero_numeric, margin = 2, na.rm = TRUE))
29	1x	if (count) return(zeros)
30
31		## Count numeric values only
32	2x	num <- vapply(X = x, FUN = is.numeric, FUN.VALUE = logical(1))
33	2x	total <- nrow(x) * sum(num)
34
35		## Proportion
36	2x	zeros / total
37		}
38		)

1		# HELPERS
2
3		## https://michaelchirico.github.io/potools/articles/developers.html
4		tr_ <- function(...) {
5	309x	enc2utf8(gettext(paste0(...), domain = "R-arkhe"))
6		}
7
8		## https://stackoverflow.com/questions/56191862/where-do-i-specify-random-seed-for-tests-in-r-package
9		#' Evaluate an Expression with a Temporarily Seed
10		#'
11		#' @param expr An [`expression`] to be evaluated.
12		#' @param seed A single value to be passed to [set.seed()].
13		#' @param envir The [environment][environment()] in which `expr` should be
14		#' evaluated.
15		#' @param rounding A [`logical`] scalar: should the default discrete uniform
16		#' generation method in \R versions prior to 3.6.0 be used? Usefull for unit
17		#' testing.
18		#' @param ... Further arguments to be passed to [set.seed()].
19		#' @return
20		#' The results of `expr` evaluated.
21		#' @seealso [set.seed()]
22		#' @keywords internal
23		with_seed <- function(expr, seed, ..., envir = parent.frame(), rounding = TRUE) {
24	3x	expr <- substitute(expr)
25		## Save and restore the random number generator (RNG) state
26	3x	env <- globalenv()
27	3x	old_seed <- env$.Random.seed
28	3x	on.exit({
29	3x	if (is.null(old_seed)) {
30	!	rm(list = ".Random.seed", envir = env, inherits = FALSE)
31		} else {
32	3x	assign(".Random.seed", value = old_seed, envir = env, inherits = FALSE)
33		}
34		})
35		## Keep the results the same for R versions prior to 3.6
36	3x	if (isTRUE(rounding) && getRversion() >= "3.6") {
37		## Set sample.kind = "Rounding" to reproduce the old sampling
38		## Suppress warning "non-uniform 'Rounding' sampler used"
39	3x	suppressWarnings(set.seed(seed, sample.kind = "Rounding"))
40		} else {
41	!	set.seed(seed)
42		}
43	3x	eval(expr, envir = envir)
44		}

1		# DATA TRANSFORMATION
2		NULL
3
4		#' Rescale Continuous Vector (minimum, maximum)
5		#'
6		#' Rescales continuous vector to have specified minimum and maximum.
7		#' @param x A [`numeric`] vector.
8		#' @param to A length-two [`numeric`] vector specifying the output range.
9		#' @param from A length-two [`numeric`] vector specifying the input range.
10		#' @return A [`numeric`] vector.
11		#' @note For internal use only.
12		#' @family scales
13		#' @export
14		scale_range <- function(x, to = c(0, 1), from = range(x, finite = TRUE)) {
15	!	if (.is_zero(to) \|\| .is_zero(from)) return(ifelse(is.na(x), NA, mean(to)))
16	1x	(x - from[1L]) / diff(from) * diff(to) + to[1L]
17		}
18
19		#' Rescale Continuous Vector (minimum, midpoint, maximum)
20		#'
21		#' Rescales continuous vector to have specified minimum, midpoint and maximum.
22		#' @param x A [`numeric`] vector.
23		#' @param to A length-two [`numeric`] vector specifying the output range.
24		#' @param from A length-two [`numeric`] vector specifying the input range.
25		#' @param midpoint A length-one [`numeric`] vector specifying the mid-point of
26		#' input range.
27		#' @return A [`numeric`] vector.
28		#' @note For internal use only.
29		#' @family scales
30		#' @export
31		scale_midpoint <- function(x, to = c(0, 1), from = range(x, finite = TRUE), midpoint = 0) {
32	!	if (.is_zero(to) \|\| .is_zero(from)) return(ifelse(is.na(x), NA, mean(to)))
33	1x	extent <- 2 * max(abs(from - midpoint))
34	1x	(x - midpoint) / extent * diff(to) + mean(to)
35		}
36
37		.is_zero <- function(x, tolerance = sqrt(.Machine$double.eps)) {
38	4x	diff(range(x)) <= tolerance
39		}

1		# DATA CLEANING: COUNT
2		#' @include AllGenerics.R
3		NULL
4
5		# Count ========================================================================
6		#' @export
7		#' @rdname count
8		#' @aliases count,data.frame-method
9		setMethod(
10		f = "count",
11		signature = c(x = "data.frame"),
12		definition = function(x, f, margin = 1, negate = FALSE, na.rm = FALSE, ...) {
13	42x	assert_function(f)
14	6x	if (negate) f <- Negate(f)
15	42x	x[] <- lapply(X = x, FUN = f, ...)
16	16x	if (any(margin == 1)) return(rowSums(x, na.rm = na.rm))
17	25x	if (any(margin == 2)) return(colSums(x, na.rm = na.rm))
18	1x	x
19		}
20		)
21
22		#' @export
23		#' @rdname count
24		#' @aliases count,matrix-method
25		setMethod(
26		f = "count",
27		signature = c(x = "matrix"),
28		definition = function(x, f, margin = 1, negate = FALSE, na.rm = FALSE, ...) {
29	36x	assert_function(f)
30	2x	if (negate) f <- Negate(f)
31	36x	x <- apply(X = x, MARGIN = margin, FUN = f, ..., simplify = TRUE)
32		## If simplify is TRUE:
33		## apply() returns an array of dimension c(n, dim(X)[MARGIN]) if n > 1
34		## apply() returns a vector if n == 1 and MARGIN has length 1
35	!	if (is.null(dim(x))) x <- matrix(x, nrow = 1)
36	36x	colSums(x, na.rm = na.rm)
37		}
38		)

1		# CLEAN
2
3		# Whitespace ===================================================================
4		#' @export
5		#' @rdname clean_whitespace
6		#' @aliases clean_whitespace,data.frame-method
7		setMethod(
8		f = "clean_whitespace",
9		signature = c(x = "data.frame"),
10		definition = function(x, which = c("both", "left", "right"), squish = TRUE) {
11	4x	x[] <- lapply(
12	4x	X = x,
13	4x	FUN = function(x, which, squish) {
14	4x	if (!is.character(x)) return(x)
15	4x	trim(x, which = which, squish = squish)
16		},
17	4x	which = which,
18	4x	squish = squish
19		)
20	4x	x
21		}
22		)
23
24		#' @export
25		#' @rdname clean_whitespace
26		#' @aliases clean_whitespace,matrix-method
27		setMethod(
28		f = "clean_whitespace",
29		signature = c(x = "matrix"),
30		definition = function(x, which = c("both", "left", "right"), squish = TRUE) {
31	1x	x[] <- trim(x, which = which, squish = squish)
32	1x	x
33		}
34		)
35
36		trim <- function(x, which = c("both", "left", "right"), squish = TRUE) {
37		## Squish
38	2x	if (squish) x <- gsub(pattern = "\\s+", replacement = " ", x = x)
39		## Trim
40	5x	x <- trimws(x, which = which, whitespace = "[ \t\r\n]")
41
42	5x	x
43		}
44
45		#' Wrap Character Strings to Format Paragraphs
46		#'
47		#' @param x A [`character`] vector of strings.
48		#' @param width A positive [`integer`] giving the target column width for
49		#' wrapping lines in the output.
50		#' @return A [`character`] vector of strings.
51		#' @keywords internal
52		#' @noRd
53		wrap_strings <- function(x, width, ...) {
54	!	vapply(
55	!	X = x,
56	!	FUN = function(x, ...) {
57	!	paste0(strwrap(x, width = width, ...), collapse = "\n")
58		},
59	!	FUN.VALUE = character(1),
60		...
61		)
62		}

1		# CONDITIONS
2		#' @include AllGenerics.R
3		NULL
4
5		#' Conditions
6		#'
7		#' * `throw_error()` stops execution of the current expression and executes an
8		#' error action.
9		#' * `throw_warning()` generates a warning message.
10		#' * `catch_conditions()` and `catch_message()` handles unusual conditions.
11		#' @param expr An expression to be evaluated.
12		#' @param .subclass A [`character`] string specifying the class of
13		#' the message to be returned.
14		#' @param message A [`character`] string specifying the message to be
15		#' returned.
16		#' @param call The call.
17		#' @param ... Extra arguments.
18		#' @author N. Frerebeau
19		#' @name conditions
20		#' @rdname conditions
21		#' @family condition
22		#' @keywords internal error
23		NULL
24
25		#' @rdname conditions
26		throw_error <- function(.subclass, message, call = NULL, ...) {
27	52x	err <- structure(
28	52x	list(
29	52x	message = message,
30	52x	call = call,
31		...
32		),
33	52x	class = c(.subclass, "error", "condition")
34		)
35	52x	stop(err)
36		}
37
38		#' @rdname conditions
39		throw_warning <- function(.subclass, message, call = NULL, ...) {
40	!	wrn <- structure(
41	!	list(
42	!	message = message,
43	!	call = call,
44		...
45		),
46	!	class = c(.subclass, "warning", "condition")
47		)
48	!	warning(wrn)
49		}
50
51		#' @rdname conditions
52		catch_message <- function(expr) {
53	6x	cnd <- vector(mode = "character")
54	6x	add_msg <- function(x) {
55	1x	cnd <<- append(cnd, x$message)
56	1x	invokeRestart("muffleMessage")
57		}
58	6x	add_wrn <- function(x) {
59	3x	cnd <<- append(cnd, x$message)
60	3x	invokeRestart("muffleWarning")
61		}
62	6x	add_err <- function(x) {
63	1x	cnd <<- append(cnd, x$message)
64		}
65
66	6x	tryCatch(
67	6x	error = add_err,
68	6x	withCallingHandlers(
69	6x	message = add_msg,
70	6x	warning = add_wrn,
71	6x	expr
72		)
73		)
74	6x	return(cnd)
75		}
76
77		#' @rdname conditions
78		catch_conditions <- function(expr) {
79	46x	cnd <- vector(mode = "list")
80	46x	add_msg <- function(x) {
81	2x	cnd <<- append(cnd, list(x))
82	2x	invokeRestart("muffleMessage")
83		}
84	46x	add_wrn <- function(x) {
85	1x	cnd <<- append(cnd, list(x))
86	1x	invokeRestart("muffleWarning")
87		}
88	46x	add_err <- function(x) {
89	43x	cnd <<- append(cnd, list(x))
90		}
91
92	46x	tryCatch(
93	46x	error = add_err,
94	46x	withCallingHandlers(
95	46x	message = add_msg,
96	46x	warning = add_wrn,
97	46x	expr
98		)
99		)
100	46x	return(cnd)
101		}
102
103		# Diagnostic ===================================================================
104		#' Class Diagnostic
105		#'
106		#' @param object An object to which error messages are related.
107		#' @param conditions A [`list`] of condition messages.
108		#' @return
109		#' Throw an error if `conditions` is of non-zero length, invisibly returns
110		#' `TRUE` if not.
111		#' @author N. Frerebeau
112		#' @keywords internal
113		#' @export
114		check_class <- function(object, conditions) {
115	!	cnd <- Filter(Negate(is_empty), conditions)
116	!	if (has_length(cnd)) {
117	!	li <- paste0("* ", cnd, collapse = "\n")
118	!	err <- sprintf(tr_("<%s> instance initialization:\n%s"), class(object), li)
119	!	throw_error("arkhe_error_class", err, call = NULL)
120		}
121
122	!	invisible(TRUE)
123		}

1		# DATA CLEANING: REPLACE
2		#' @include AllGenerics.R
3		NULL
4
5		# Replace ======================================================================
6		## Missing values --------------------------------------------------------------
7		#' @export
8		#' @rdname replace_NA
9		#' @aliases replace_NA,matrix-method
10		setMethod(
11		f = "replace_NA",
12		signature = c(x = "matrix"),
13		definition = function(x, value = 0) {
14	1x	x[is.na(x)] <- value
15	1x	x
16		}
17		)
18
19		#' @export
20		#' @rdname replace_NA
21		#' @aliases replace_NA,data.frame-method
22		setMethod(
23		f = "replace_NA",
24		signature = c(x = "data.frame"),
25		definition = function(x, value = 0) {
26	1x	x[] <- lapply(
27	1x	X = x,
28	1x	FUN = function(x, value) {
29	3x	x[is.na(x)] <- value
30	3x	x
31		},
32	1x	value = value
33		)
34	1x	x
35		}
36		)
37
38		## Infinite values -------------------------------------------------------------
39		#' @export
40		#' @rdname replace_Inf
41		#' @aliases replace_Inf,matrix-method
42		setMethod(
43		f = "replace_Inf",
44		signature = c(x = "matrix"),
45		definition = function(x, value = 0) {
46	1x	x[is.infinite(x)] <- value
47	1x	x
48		}
49		)
50
51		#' @export
52		#' @rdname replace_Inf
53		#' @aliases replace_Inf,data.frame-method
54		setMethod(
55		f = "replace_Inf",
56		signature = c(x = "data.frame"),
57		definition = function(x, value = 0) {
58	1x	x[] <- lapply(
59	1x	X = x,
60	1x	FUN = function(x, value) {
61	3x	x[is.infinite(x)] <- value
62	3x	x
63		},
64	1x	value = value
65		)
66	1x	x
67		}
68		)
69
70		## Zeros -----------------------------------------------------------------------
71		#' @export
72		#' @rdname replace_zero
73		#' @aliases replace_zero,matrix-method
74		setMethod(
75		f = "replace_zero",
76		signature = c(x = "matrix"),
77		definition = function(x, value) {
78	1x	x[is_zero(x)] <- value
79	1x	x
80		}
81		)
82
83		#' @export
84		#' @rdname replace_zero
85		#' @aliases replace_zero,data.frame-method
86		setMethod(
87		f = "replace_zero",
88		signature = c(x = "data.frame"),
89		definition = function(x, value) {
90	1x	num <- vapply(X = x, FUN = is.numeric, FUN.VALUE = logical(1))
91	1x	nozero <- lapply(
92	1x	X = x[, num, drop = FALSE],
93	1x	FUN = function(x, value) {
94	2x	x[is_zero(x)] <- value
95	2x	x
96		},
97	1x	value = value
98		)
99	1x	x[, num] <- nozero
100	1x	x
101		}
102		)
103
104		## Empty string ----------------------------------------------------------------
105		#' @export
106		#' @rdname replace_empty
107		#' @aliases replace_empty,matrix-method
108		setMethod(
109		f = "replace_empty",
110		signature = c(x = "matrix"),
111		definition = function(x, value) {
112	1x	x[!nzchar(x)] <- value
113	1x	x
114		}
115		)
116
117		#' @export
118		#' @rdname replace_empty
119		#' @aliases replace_empty,data.frame-method
120		setMethod(
121		f = "replace_empty",
122		signature = c(x = "data.frame"),
123		definition = function(x, value) {
124	1x	char <- vapply(X = x, FUN = is.character, FUN.VALUE = logical(1))
125	1x	noblank <- lapply(
126	1x	X = x[, char, drop = FALSE],
127	1x	FUN = function(x, value) {
128	1x	x[!nzchar(x)] <- value
129	1x	x
130		},
131	1x	value = value
132		)
133	1x	x[, char] <- noblank
134	1x	x
135		}
136		)

1		# DATA CLEANING: APPEND
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname append_rownames
7		#' @aliases append_rownames,data.frame-method
8		setMethod(
9		f = "append_rownames",
10		signature = c(x = "data.frame"),
11		definition = function(x, after = 0, remove = TRUE, var = "rownames") {
12	1x	assert_scalar(after, "numeric")
13	1x	assert_scalar(remove, "logical")
14	1x	assert_scalar(var, "character")
15
16	1x	n <- ncol(x)
17	1x	if (after > n) after <- n
18	1x	i_before <- seq_len(after)
19	1x	i_after <- if (after < n) seq(from = after + 1, to = n, by = 1) else 0
20
21	1x	z <- rownames(x)
22	1x	x <- cbind(x[, i_before, drop = FALSE], z, x[, i_after, drop = FALSE])
23
24	1x	colnames(x)[after + 1] <- var
25	1x	rownames(x) <- if (remove) NULL else z
26
27	1x	x
28		}
29		)
30
31		#' @export
32		#' @rdname append_column
33		#' @aliases append_column,data.frame-method
34		setMethod(
35		f = "append_column",
36		signature = c(x = "data.frame"),
37		definition = function(x, column, after = 0, var = ".col") {
38	3x	assert_scalar(after, "numeric")
39	3x	assert_scalar(var, "character")
40	3x	if (!is_atomic(column)) {
41	!	stop(sprintf("%s must be an atomic vector.", sQuote("x")), call. = FALSE)
42		}
43
44	3x	m <- nrow(x)
45	3x	if (has_rownames(x) && has_names(column)) {
46	2x	i <- match(names(column), rownames(x))
47
48	2x	if (anyNA(i)) {
49	1x	column <- column[!is.na(i)]
50	1x	i <- i[!is.na(i)]
51		}
52
53	2x	old_column <- column
54	2x	column <- rep(NA, m)
55	2x	column[i] <- old_column
56		}
57
58	3x	assert_length(column, m)
59
60	2x	p <- ncol(x)
61	2x	if (after > p) after <- p
62	2x	i_before <- seq_len(after)
63	2x	i_after <- if (after < p) seq(from = after + 1, to = p, by = 1) else 0
64
65	2x	x <- cbind(x[, i_before, drop = FALSE], column, x[, i_after, drop = FALSE])
66
67	2x	colnames(x)[after + 1] <- var
68	2x	x
69		}
70		)

1		# GET
2
3		#' @export
4		#' @rdname get
5		#' @aliases get_columns,ANY-method
6		setMethod(
7		f = "get_columns",
8		signature = c(x = "ANY"),
9		definition = function(x, select = NULL, names = NULL, ...) {
10	1x	i <- seek_columns(x, select = select, names = names, ...)
11	1x	i <- i[which(!is.na(i))]
12	1x	x[, i, drop = FALSE]
13		}
14		)
15
16		#' @export
17		#' @rdname get
18		#' @aliases get_rows,ANY-method
19		setMethod(
20		f = "get_rows",
21		signature = c(x = "ANY"),
22		definition = function(x, select = NULL, names = NULL, ...) {
23	1x	i <- seek_rows(x, select = select, names = names, ...)
24	1x	i <- i[which(!is.na(i))]
25	1x	x[i, , drop = FALSE]
26		}
27		)

1		# UTILITIES
2		#' @include AllGenerics.R
3		NULL
4
5		#' Default value for NULL
6		#'
7		#' Replaces `NULL` with a default value.
8		#' @param x,y An object.
9		#' @return If `x` is `NULL`, returns `y`; otherwise returns `x`.
10		#' @family utilities
11		#' @keywords utilities
12		#' @name null
13		#' @rdname null
14		#' @export
15		`%\|\|%` <- function(x, y) {
16		if (is.null(x)) y else x
17		}
18
19		# Reexport from base on newer versions of R to avoid conflict messages
20		if (exists("%\|\|%", envir = baseenv())) {
21		`%\|\|%` <- get("%\|\|%", envir = baseenv())
22		}
23
24		#' Concatenate
25		#'
26		#' Concatenates character vectors.
27		#' @param x,y A [`character`] vector.
28		#' @return A [`character`] vector.
29		#' @family utilities
30		#' @keywords utilities
31		#' @name concat
32		#' @rdname concat
33		#' @export
34		`%+%` <- function (x, y) {
35	4x	stopifnot(is.character(x), is.character(y))
36	4x	stopifnot(length(x) == length(y) \|\| length(x) == 1 \|\| length(y) == 1)
37
38	1x	if (length(x) == 0 && length(y) == 0) paste0(x, y)
39	1x	else if (length(x) == 0) x
40	1x	else if (length(y) == 0) y
41	1x	else paste0(x, y)
42		}

1		# DATA CLEANING: COMPACT
2		#' @include AllGenerics.R
3		NULL
4
5		## compact rows/columns ========================================================
6		#' @export
7		#' @rdname compact
8		#' @aliases compact,ANY-method
9		setMethod(
10		f = "compact",
11		signature = c(x = "ANY"),
12		definition = function(x, margin = 1, na.rm = FALSE,
13		verbose = getOption("arkhe.verbose")) {
14	12x	vide <- function(x) {
15	13x	if (is_numeric(x)) x == 0
16	24x	else if (is_logical(x)) !x
17	13x	else if (is_character(x)) !nzchar(x)
18	!	else rep(FALSE, length(x))
19		}
20	12x	discard(x, f = vide, margin = margin, all = TRUE,
21	12x	na.rm = na.rm, verbose = verbose)
22		}
23		)
24
25		#' @export
26		#' @rdname compact
27		#' @aliases compact_columns,ANY-method
28		setMethod(
29		f = "compact_columns",
30		signature = c(x = "ANY"),
31		definition = function(x, na.rm = FALSE, verbose = getOption("arkhe.verbose")) {
32	5x	compact(x, margin = 2, na.rm = na.rm, verbose = verbose)
33		}
34		)
35
36		#' @export
37		#' @rdname compact
38		#' @aliases compact_rows,ANY-method
39		setMethod(
40		f = "compact_rows",
41		signature = c(x = "ANY"),
42		definition = function(x, na.rm = FALSE, verbose = getOption("arkhe.verbose")) {
43	7x	compact(x, margin = 1, na.rm = na.rm, verbose = verbose)
44		}
45		)

1		# MATHEMATICS
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname math_gcd
7		#' @aliases math_gcd,numeric,numeric-method
8		setMethod(
9		f = "math_gcd",
10		signature = c(x = "numeric", y = "numeric"),
11		definition = function(x, y) {
12	12x	mapply(
13	12x	FUN = function(a, b) {
14	4x	if (isTRUE(all.equal(b, 0))) return(a)
15	10x	math_gcd(b, a %% b)
16		},
17	12x	a = x,
18	12x	b = y
19		)
20		}
21		)
22
23		#' @export
24		#' @rdname math_lcm
25		#' @aliases math_lcm,numeric,numeric-method
26		setMethod(
27		f = "math_lcm",
28		signature = c(x = "numeric", y = "numeric"),
29		definition = function(x, y) {
30	1x	(x * y) / math_gcd(x, y)
31		}
32		)

1		# DATA CLEANING: REMOVE
2		#' @include AllGenerics.R
3		NULL
4
5		# Missing values ===============================================================
6		#' @export
7		#' @rdname remove_NA
8		#' @aliases remove_NA,ANY-method
9		setMethod(
10		f = "remove_NA",
11		signature = c(x = "ANY"),
12		definition = function(x, margin = 1, all = FALSE,
13		verbose = getOption("arkhe.verbose")) {
14	4x	discard(x, f = is.na, margin = margin, all = all, verbose = verbose)
15		}
16		)
17
18		# Infinite values ==============================================================
19		#' @export
20		#' @rdname remove_Inf
21		#' @aliases remove_Inf,ANY-method
22		setMethod(
23		f = "remove_Inf",
24		signature = c(x = "ANY"),
25		definition = function(x, margin = 1, all = FALSE,
26		verbose = getOption("arkhe.verbose")) {
27	4x	discard(x, f = is.infinite, margin = margin, all = all, verbose = verbose)
28		}
29		)
30
31		# Zeros ========================================================================
32		#' @export
33		#' @rdname remove_zero
34		#' @aliases remove_zero,ANY-method
35		setMethod(
36		f = "remove_zero",
37		signature = c(x = "ANY"),
38		definition = function(x, margin = 1, all = FALSE,
39		verbose = getOption("arkhe.verbose")) {
40	4x	discard(x, f = is_zero_numeric, margin = margin,
41	4x	all = all, na.rm = TRUE, verbose = verbose)
42		}
43		)
44
45		# Empty string =================================================================
46		#' @export
47		#' @rdname remove_empty
48		#' @aliases remove_empty,ANY-method
49		setMethod(
50		f = "remove_empty",
51		signature = c(x = "ANY"),
52		definition = function(x, margin = 1, all = FALSE,
53		verbose = getOption("arkhe.verbose")) {
54	4x	discard(x, f = nzchar, margin = margin, negate = TRUE,
55	4x	all = all, na.rm = TRUE, verbose = verbose)
56		}
57		)
58
59		# Constant =====================================================================
60		#' @export
61		#' @rdname remove_constant
62		#' @aliases remove_constant,ANY-method
63		setMethod(
64		f = "remove_constant",
65		signature = c(x = "ANY"),
66		definition = function(x, na.rm = FALSE, verbose = getOption("arkhe.verbose")) {
67	6x	discard(x, f = function(x) { is_unique(x, na.rm = na.rm) },
68	3x	margin = 2, all = FALSE, verbose = verbose)
69		}
70		)