dimensio coverage - 79.47%

Files
Source

# PLOT CONVEX HULL
#' @include AllGenerics.R
NULL

#' @export
#' @rdname viz_hull
#' @aliases viz_hull,numeric,numeric-method
setMethod(
  f = "viz_hull",
  signature = c(x = "numeric", y = "numeric"),
  definition = function(x, y, ..., group = NULL,
                        color = NULL, fill = FALSE, symbol = FALSE) {
    hull <- wrap_hull(x, y, group = group)
    .viz_hull(hull, color = color, fill = fill, symbol = symbol, ...)
    invisible(list(x = x, y = y))
  }
)

#' @export
#' @rdname viz_hull
#' @aliases viz_hull,MultivariateAnalysis,missing-method
setMethod(
  f = "viz_hull",
  signature = c(x = "MultivariateAnalysis", y = "missing"),
  definition = function(x, ..., group = NULL,
                        color = NULL, fill = FALSE, symbol = FALSE) {
    hull <- wrap_hull(x, margin = get_margin(), axes = get_axes(),
                      group = group, principal = get_principal())
    .viz_hull(hull, color = color, fill = fill, symbol = symbol, ...)
    invisible(x)
  }
)

#' @export
#' @rdname viz_hull
#' @aliases viz_hull,MultivariateBootstrap,missing-method
setMethod(
  f = "viz_hull",
  signature = c(x = "MultivariateBootstrap", y = "missing"),
  definition = function(x, ..., color = FALSE, fill = FALSE, symbol = FALSE) {
    hull <- wrap_hull(x, margin = get_margin(), axes = get_axes(),
                      group = NULL, principal = get_principal())
    .viz_hull(hull, color = color, fill = fill, symbol = symbol, ...)
    invisible(x)
  }
)

#' @export
#' @rdname viz_hull
#' @aliases viz_hull,PCOA,missing-method
setMethod(
  f = "viz_hull",
  signature = c(x = "PCOA", y = "missing"),
  definition = function(x, ..., group = NULL,
                        color = FALSE, fill = FALSE, symbol = FALSE) {
    hull <- wrap_hull(x, axes = get_axes(), group = group)
    .viz_hull(hull, color = color, fill = fill, symbol = symbol, ...)
    invisible(x)
  }
)

#' @param x A `list` of `matrix` returned by [wrap_hull()].
#' @noRd
.viz_hull <- function(x, ..., color = NULL, fill = FALSE, symbol = FALSE) {
  n <- length(x)

  ## Recycle graphical parameters if of length one
  dots <- list(...)
  col <- recycle(dots$border %||% graphics::par("fg"), n)
  bg <- recycle(dots$col %||% NA, n)
  lty <- recycle(dots$lty %||% graphics::par("lty"), n)
  lwd <- recycle(dots$lwd %||% graphics::par("lwd"), n)

  if (n > 1) {
    ## Discrete scales
    extra_quali <- names(x)
    if (is.null(dots$border) && !isFALSE(color))
      col <- khroma::palette_color_discrete(color)(extra_quali)
    if (is.null(dots$col) && !isFALSE(fill))
      bg <- khroma::palette_color_discrete(fill)(extra_quali)
    if (is.null(dots$lty) && !isFALSE(symbol))
      lty <- khroma::palette_line(symbol)(extra_quali)
  }

  for (i in seq_along(x)) {
    graphics::polygon(
      x = x[[i]],
      border = col[i],
      col = bg[i],
      lty = lty[i],
      lwd = lwd[i]
    )
  }
}

# REPELLING LABELS

# Text =========================================================================
#' Non-Overlapping Text Labels
#'
#' Optimize the location of text labels to minimize overplotting text.
#' @param x,y A [`numeric`] vector giving the x and y coordinates of a set of
#'  points. If `y` is `NULL`, an attempt is made to interpret `x` in a suitable
#'  way (see [grDevices::xy.coords()]).
#' @param labels A [`character`] vector or [`expression`] specifying the text
#'  to be written.
#' @param type A [`character`] string specifying the shape of the field.
#'  It must be one of "`text`", "`shadow`" or "`box`". Any unambiguous substring
#'  can be given.
#' @param ... Further arguments to be passed to [graphics::text()],
#'  particularly, character expansion, `cex` and color, `col`.
#' @return
#'  `label()` is called it for its side-effects: it results in a graphic
#'  being displayed.
#' @seealso [graphics::text()]
#' @source
#'  This function is modeled after [car::pointLabel()] (originally from the
#'  \pkg{maptools} package).
#' @author N. Frerebeau
#' @family annotations
#' @keywords internal
#' @export
label <- function(x, y = NULL, labels = seq_along(x$x),
                  type = c("text", "shadow", "box"), ...) {
  ## Validation
  type <- match.arg(type, several.ok = FALSE)
  x <- grDevices::xy.coords(x = x, y = y)

  labels <- grDevices::as.graphicsAnnot(labels)
  if (length(labels) < length(x$x)) labels <- rep(labels, length(x$x))

  ## Compute label positions
  labs <- compute_labels(x = x$x, y = x$y, labels = labels)

  ## Draw labels
  fun <- switch(
    type,
    text = graphics::text,
    shadow = text_shadow,
    box = text_box
  )
  fun(labs, labels = labels, ...)

  invisible(labs)
}

# Adapted from car::pointLabel()
compute_labels <- function(x, y, labels, ..., iter = 50,
                           cex = graphics::par("cex"),
                           font = NULL, vfont = NULL) {
  ## Coordinates
  bound <- graphics::par("usr")
  ratio <- graphics::par("pin")[1] / graphics::par("pin")[2] # x/y ratio

  to_unity <- function(x, y) {
    list(x = (x - bound[1]) / (bound[2] - bound[1]) * ratio,
         y = (y - bound[3]) / (bound[4] - bound[3]) / ratio)
  }
  to_usr <- function(x, y) {
    list(x = bound[1] + x / ratio * (bound[2] - bound[1]),
         y = bound[3] + y * ratio * (bound[4] - bound[3]))
  }

  xy <- to_unity(x = x, y = y)
  x <- xy$x
  y <- xy$y
  n <- length(x)

  ## 8 positions: corners and side mid-points of the rectangle
  ## Position 7 (top right) is the most preferred
  width <- graphics::strwidth(labels, units = "figure", cex = cex,
                              font = font, vfont = vfont)
  height <- graphics::strheight(labels, units = "figure", cex = cex,
                                font = font, vfont = vfont)
  width <- (width + 0.02) * ratio
  height <- (height + 0.02) / ratio

  makeoff <- function(pos) {
    c(-1, -1, -1, 0, 0, 1, 1, 1)[pos] * (width / 2) +
      1i * c(-1, 0, 1, -1, 1, -1, 0, 1)[pos] * (height / 2)
  }

  ## Find intersection area of two rectangles
  overlap <- function(xy1, off1, xy2, off2) {
    w <- pmin(Re(xy1 + off1 / 2), Re(xy2 + off2 / 2)) -
      pmax(Re(xy1 - off1 / 2), Re(xy2 - off2 / 2))
    h <- pmin(Im(xy1 + off1 / 2), Im(xy2 + off2 / 2)) -
      pmax(Im(xy1 - off1 / 2), Im(xy2 - off2 / 2))
    w[w <= 0] <- 0
    h[h <= 0] <- 0
    w * h
  }

  objective <- function(gene) {
    offset <- makeoff(gene)

    if (!is.null(rectidx1)) {
      area <- sum(overlap(xy[rectidx1] + offset[rectidx1], rectv[rectidx1],
                          xy[rectidx2] + offset[rectidx2], rectv[rectidx2]))
    } else {
      area <- 0
    }

    ## Penalize labels which go outside the image area
    ## Count points outside of the image
    a <- Re(xy + offset - rectv / 2) < 0 | Re(xy + offset + rectv / 2) > ratio
    b <- Im(xy + offset - rectv / 2) < 0 | Im(xy + offset + rectv / 2) > 1 / ratio
    outside <- sum(a | b)
    res <- 1000 * area + outside
    res
  }

  # Make a list of label rectangles in their reference positions,
  # centered over the map feature; the real labels are displaced
  # from these positions so as not to overlap
  # Note that some labels can be bigger than others
  xy <- x + 1i * y
  rectv <- width + 1i * height

  rectidx1 <- rectidx2 <- array(0, (length(x)^2 - length(x)) / 2)
  k <- 0
  for (i in seq_along(x))
    for (j in seq_len(i - 1)) {
      k <- k + 1
      rectidx1[k] <- i
      rectidx2[k] <- j
    }
  maylap <- overlap(xy[rectidx1], 2 * rectv[rectidx1],
                    xy[rectidx2], 2 * rectv[rectidx2]) > 0
  rectidx1 <- rectidx1[maylap]
  rectidx2 <- rectidx2[maylap]

  ## Simulated annealing
  ## Initial state
  gene <- rep(8, n)
  score <- objective(gene)
  ## Initial "best" solution
  bestgene <- gene
  bestscore <- score
  iter <- seq_len(iter)
  temp <- 2.5
  for (i in iter) {
    k <- 1 # Energy evaluation count
    for (j in iter) {
      newgene <- gene
      newgene[sample(n, 1)] <- sample(8, 1)
      newscore <- objective(newgene)
      if (newscore <= score || stats::runif(1) < exp((score - newscore) / temp)) {
        ## keep the new set if it has the same or better score or
        ## if it's worse randomly based on the annealing criteria
        k <- k + 1
        score <- newscore
        gene <- newgene
      }
      if (score <= bestscore) {
        bestscore <- score
        bestgene <- gene
      }
      if (bestscore == 0 || k == 10) break
    }
    if (bestscore == 0) break
    temp <- 0.9 * temp
  }

  nx <- Re(xy + makeoff(bestgene))
  ny <- Im(xy + makeoff(bestgene))

  xy <- to_usr(x = nx, y = ny)
  xy$labels <- labels
  xy
}

#' Shadow Text
#'
#' @param x,y A [`numeric`] vector. If `y` is `NULL`, an attempt is made to
#'  interpret `x` in a suitable way (see [grDevices::xy.coords()]).
#' @param labels A [`character`] vector specifying the text to be written.
#' @param width Thickness of the shadow, as a fraction of the plotting size.
#' @param theta Angles for plotting the background.
#' @param cex A [`numeric`] character expansion factor.
#' @param col The color to be used for the text.
#' @param bg The color to be used for the shadow.
#' @param font,vfont The font to be used (see [graphics::text()]).
#' @param ... Further parameters to be passed to [graphics::text()].
#' @return
#'  `text_shadow()` is called it for its side-effects: it results in a graphic
#'  being displayed.
#' @author N. Frerebeau
#' @family geometries
#' @keywords internal
#' @noRd
text_shadow <- function(x, y = NULL, labels = seq_along(x$x),
                        width = 1/10, theta = seq(0, 2 * pi, length.out = 50),
                        cex = graphics::par("cex"), col = graphics::par("fg"),
                        bg = graphics::par("bg"), font = NULL, vfont = NULL, ...) {

  x <- grDevices::xy.coords(x = x, y = y)

  xo <- width * graphics::strwidth("M", units = "user", cex = cex, font = font, vfont = vfont)
  yo <- width * graphics::strheight("X", units = "user", cex = cex, font = font, vfont = vfont)

  for (i in theta) {
    graphics::text(x = x$x + cos(i) * xo, y = x$y + sin(i) * yo, labels = labels,
                   col = bg, cex = cex, font = font, vfont = vfont, ...)
  }

  graphics::text(x = x$x, y = x$y, labels = labels, col = col, cex = cex,
                 font = font, vfont = vfont, ...)

  invisible(NULL)
}

#' Text with Halo Underneath
#'
#' @param x,y A [`numeric`] vector. If `y` is `NULL`, an attempt is made to
#'  interpret `x` in a suitable way (see [grDevices::xy.coords()]).
#' @param labels A [`character`] vector specifying the text to be written.
#' @param padding A length-one [`numeric`] vector giving the amount of padding
#'  around label.
#' @param rounding A length-one [`numeric`] vector giving the rounding of the
#'  angles (see [rounded()]).
#' @param vertices A length-on [`integer`] vector specifying the number of
#'  vertices to draw (see [rounded()]).
#' @param cex A numeric character expansion factor.
#' @param col The color to be used for the text.
#' @param bg The color to be used for the background.
#' @param font,vfont The font to be used (see [graphics::text()]).
#' @param ... Further parameters to be passed to [graphics::text()] (see details).
#' @details
#'  Specifying `pos` and `offset` will currently change the position of the
#'  text, but not of the field.
#' @return
#'  `text_box()` is called it for its side-effects: it results in a graphic
#'  being displayed.
#' @author N. Frerebeau
#' @family geometries
#' @keywords internal
#' @noRd
text_box <- function(x, y = NULL, labels = seq_along(x$x), padding = 1/3,
                     rounding = 0.2, vertices = 100,
                     cex = graphics::par("cex"), col = graphics::par("fg"),
                     bg = graphics::par("bg"), font = NULL, vfont = NULL, ...) {

  x <- grDevices::xy.coords(x = x, y = y)
  srt <- list(...)$srt %||% graphics::par("srt")

  em <- graphics::strwidth("M", units = "user", cex = cex, font = font, vfont = vfont)
  ex <- graphics::strheight("X", units = "user", cex = cex, font = font, vfont = vfont)

  xo <- padding * em
  yo <- padding * ex

  width <- graphics::strwidth(labels, units = "user", cex = cex, font = font, vfont = vfont)
  height <- graphics::strheight(labels, units = "user", cex = cex, font = font, vfont = vfont)

  .mapply(
    FUN = function(x, y, w, h, r, n, col, border, rotate) {
      rounded(
        x0 = x - w - xo,
        y0 = y - h - yo,
        x1 = x + w + xo,
        y1 = y + h + yo,
        r = r,
        n = n,
        col = col,
        border = border,
        rotate = rotate,
        aspect = TRUE
      )
    },
    dots = list(x = x$x, y = x$y, w = width * 0.5, h = height * 0.5,
                col = bg, border = col, rotate = srt),
    MoreArgs = list(r = rounding, n = vertices)
  )
  graphics::text(x = x$x, y = x$y, labels = labels, col = col, cex = cex,
                 font = font, vfont = vfont, ...)

  invisible(NULL)
}

# Shapes =======================================================================
#' Circle
#'
#' Draws a circle.
#' @param x,y A length-one [`numeric`] vector giving the coordinates of the
#'  center of the circle.
#' @param radius A length-one [`numeric`] vector giving the radius of the
#'  circle.
#' @param n A length-on [`integer`] vector specifying the number of vertices to
#'  draw the circle.
#' @param ... Further parameters to be passed to [graphics::polygon()].
#' @return
#'  `circle()` is called it for its side-effects: it results in a graphic
#'  being displayed.
#' @author N. Frerebeau
#' @family shapes
#' @keywords internal
#' @noRd
circle <- function(x, y, radius, ..., n = 100) {
  angle.inc <- 2 * pi / n
  angles <- seq(0, 2 * pi - angle.inc, by = angle.inc)

  xv <- cos(angles) * radius + x
  yv <- sin(angles) * radius + y
  graphics::polygon(xv, yv, ...)
}

#' Rounded Rectangle
#'
#' Draws a rectangular box with rounded left and right edges.
#' @param x0,y0 A length-one [`numeric`] vector giving the coordinates of the
#'  bottom left angle.
#' @param x1,y1 A length-one [`numeric`] vector giving the coordinates of the
#'  top right angle.
#' @param r A length-one [`numeric`] vector giving the rounding of the edges.
#' @param n A length-on [`integer`] vector specifying the number of vertices to
#'  draw.
#' @param rotate A [`numeric`] vector giving the angle of rotation, in degrees.
#' @param aspect A [`logical`] scalar: should the aspect ratio be kept during
#'  rotation?
#' @param ... Further parameters to be passed to [graphics::polygon()].
#' @return
#'  `rounded()` is called it for its side-effects: it results in a graphic
#'  being displayed.
#' @author N. Frerebeau
#' @family shapes
#' @keywords internal
#' @noRd
rounded <- function(x0, y0, x1, y1, ..., r = 0.2, n = 100,
                    rotate = NULL, aspect = FALSE) {

  XD <- YD <- min(c(x1 - x0, y1 - y0))
  xi <- r * XD
  yi <- r * YD

  ## Elliptic corners function
  elx <- function(from, to) xi * cos(seq(from, to, length.out = n / 4))
  ely <- function(from, to) yi * sin(seq(from, to, length.out = n / 4))

  ## Coordinates
  x <- c(x1 - xi + elx(0, pi / 2),
         x0 + xi + elx(pi / 2, pi),
         x0 + xi + elx(pi, 3 * pi / 2),
         x1 - xi + elx(3 * pi / 2, 2 * pi))
  y <- c(y1 - yi + ely(0, pi / 2),
         y1 - yi + ely(pi / 2, pi),
         y0 + yi + ely(pi, 3 * pi / 2),
         y0 + yi + ely(3 * pi / 2, 2 * pi))

  ## Rotate
  xy <- list(x = x, y = y)
  if (!is.null(rotate)) xy <- rotate(xy$x, xy$y, angle = rotate, aspect = aspect)

  graphics::polygon(x = xy$x, y = xy$y, ...)
}

# Helpers ======================================================================
#' Rotation in Euclidean Space
#'
#' Rotates points in the `xy` plane counterclockwise.
#' @param x,y A [`numeric`] vector. If `y` is `NULL`, an attempt is made to
#'  interpret `x` in a suitable way (see [grDevices::xy.coords()]).
#' @param angle A [`numeric`] vector giving the angle of rotation, in degrees.
#' @param center A length-two [`numeric`] vector giving the coordinates of the
#'  rotation point. If `NULL`, defaults to centroid.
#' @param aspect A [`logical`] scalar: should aspect ratio be kept?
#' @return
#'  Returns a [`list`] with two components `x` and `y`.
#' @example inst/examples/ex-rotate.R
#' @keywords internal
#' @noRd
rotate <- function(x, y = NULL, angle = 0, center = NULL, aspect = FALSE) {

  xy <- grDevices::xy.coords(x = x, y = y)
  if (is.null(center)) center <- c(mean(xy$x), mean(xy$y))

  theta <- angle / 180 * pi
  cos_theta  <- cos(theta)
  sin_theta  <- sin(theta)

  dx <- xy$x - center[[1L]]
  dy <- xy$y - center[[2L]]

  ex <- center[[1L]] + cos_theta * dx - sin_theta * dy
  ey <- center[[2L]] + sin_theta * dx + cos_theta * dy

  if (aspect) {
    usr <- graphics::par("usr")
    pin  <- graphics::par("pin")
    sy   <- usr[[4L]] - usr[[3L]]
    sx   <- usr[[2L]] - usr[[1L]]
    ey   <- center[[2L]] + (ey - center[[2L]]) * sy / sx * pin[[1L]] / pin[[2L]]
  }

  list(x = ex, y = ey)
}

# EXPORT
#' @include AllGenerics.R
NULL

# The -r9X flags specify that the zip command should recursively search
# sub-directories, use maximum compression, and remove depreciated file fields.
# The -j flag allows the file names to be stored rather than the full file path.

#' @export
#' @rdname export
#' @aliases export,MultivariateAnalysis-method
setMethod(
  f = "export",
  signature = c(object = "MultivariateAnalysis"),
  definition = function(object, file, flags = "-r9Xj", ...) {
    ## Create temporary directory
    dir_path <- tempfile(pattern = "export_")
    dir.create(path = dir_path)
    on.exit(unlink(x = dir_path))

    ## Write results
    utils::write.csv(
      x = get_data(object),
      file = make_file_name(dir_path, "data")
    )
    utils::write.csv(
      x = get_eigenvalues(object),
      file = make_file_name(dir_path, "eigenvalues")
    )
    export_results(object, path = dir_path, margin = 1)
    export_results(object, path = dir_path, margin = 2)

    ## Zip
    status <- utils::zip(zipfile = file, files = dir_path, flags = flags, ...)
    invisible(status)
  }
)

#' @export
#' @rdname export
#' @aliases export,PCOA-method
setMethod(
  f = "export",
  signature = c(object = "PCOA"),
  definition = function(object, file, flags = "-r9Xj", ...) {
    ## Create temporary directory
    dir_path <- tempfile(pattern = "export_")
    dir.create(path = dir_path)
    on.exit(unlink(x = dir_path))

    ## Write results
    utils::write.csv(
      x = get_coordinates(object),
      file = make_file_name(dir_path, "coordinates")
    )
    utils::write.csv(
      x = get_eigenvalues(object),
      file = make_file_name(dir_path, "eigenvalues")
    )

    ## Zip
    status <- utils::zip(zipfile = file, files = dir_path, flags = flags, ...)
    invisible(status)
  }
)

export_results <- function(object, path, margin, sup_name = ".sup") {
  ## Coordinates
  coords <- get_coordinates(
    x = object,
    margin = margin,
    principal = TRUE,
    sup_name = sup_name
  )

  ## Contributions
  contrib <- get_contributions(
    x = object,
    margin = margin
  )

  ## cos2
  cos2 <- get_cos2(
    x = object,
    margin = margin,
    sup_name = sup_name
  )

  ## Write
  utils::write.csv(x = coords, file = make_file_name(path, "coordinates", margin))
  utils::write.csv(x = contrib, file = make_file_name(path, "contributions", margin))
  utils::write.csv(x = cos2, file = make_file_name(path, "cos2", margin))

  invisible(NULL)
}

make_file_name <- function(path, name, margin = NULL) {
  prefix <- ""
  if (!is.null(margin) && margin == 1) prefix <- "row_"
  if (!is.null(margin) && margin == 2) prefix <- "col_"

  file_name <- paste0(prefix, name, ".csv")
  file_path <- file.path(path, file_name)

  file_path
}

# ELLIPSES
#' @include AllGenerics.R
NULL

# Confidence ===================================================================
#' @export
#' @rdname viz_confidence
#' @aliases wrap_confidence,numeric,numeric-method
setMethod(
  f = "wrap_confidence",
  signature = c(x = "numeric", y = "numeric"),
  definition = function(x, y, group = NULL, level = 0.95) {
    ## Validation
    n <- length(x)
    arkhe::assert_length(y, n)
    arkhe::assert_type(level, "numeric")

    ## Add groups, if any
    if (is.null(group)) group <- rep("", n)
    group <- as.character(group)
    arkhe::assert_length(group, n)

    ## Clean
    ok <- !is.na(x) & !is.na(y) & !is.na(group)
    x <- x[ok]
    y <- y[ok]
    group <- group[ok]

    ## Compute ellipse
    index <- split(seq_along(group), f = group)
    lapply(
      X = index,
      FUN = function(i) {
        xi <- x[i]
        yi <- y[i]
        if (length(xi) < 3) return(NULL)

        df1 <- 1
        df2 <- length(xi) - 2
        radius <- sqrt(stats::qf(p = level, df1, df2) * df1 / df2)
        wrap_ellipse(xi, yi, radius = radius)
      }
    )
  }
)

#' @export
#' @rdname viz_confidence
#' @aliases wrap_confidence,MultivariateAnalysis,missing-method
setMethod(
  f = "wrap_confidence",
  signature = c(x = "MultivariateAnalysis", y = "missing"),
  definition = function(x, margin = 1, axes = c(1, 2), group = NULL,
                        level = 0.95, principal = TRUE) {
    ## Validation
    arkhe::assert_scalar(margin, "numeric")
    arkhe::assert_type(axes, "numeric")
    arkhe::assert_length(axes, 2)

    ## Get coordinates
    data <- get_coordinates(x, margin = margin, principal = principal)
    data <- data[, axes]

    ## Add groups, if any
    if (length(group) > 1) {
      group <- group[get_order(x, margin = margin)]
    } else if (length(group) == 1) {
      group <- get_extra(x)[[group]]
    } else if (has_groups(x, margin = margin)) {
      group <- get_groups(x, margin = margin)
    }

    ## Compute ellipse
    methods::callGeneric(x = data[, 1], y = data[, 2],
                         group = group, level = level)
  }
)

#' @export
#' @rdname viz_confidence
#' @aliases wrap_confidence,PCOA,missing-method
setMethod(
  f = "wrap_confidence",
  signature = c(x = "PCOA", y = "missing"),
  definition = function(x, axes = c(1, 2), group = NULL, level = 0.95) {
    ## Validation
    arkhe::assert_type(axes, "numeric")
    arkhe::assert_length(axes, 2)

    ## Get coordinates
    data <- get_coordinates(x)
    data <- data[, axes]

    ## Compute ellipse
    methods::callGeneric(x = data[, 1], y = data[, 2],
                         group = group, level = level)
  }
)

# Tolerance ====================================================================
#' @export
#' @rdname viz_tolerance
#' @aliases wrap_tolerance,numeric,numeric-method
setMethod(
  f = "wrap_tolerance",
  signature = c(x = "numeric", y = "numeric"),
  definition = function(x, y, group = NULL, level = 0.95) {
    ## Validation
    n <- length(x)
    arkhe::assert_length(y, n)
    arkhe::assert_type(level, "numeric")

    ## Add groups, if any
    if (is.null(group)) group <- rep("", n)
    group <- as.character(group)
    arkhe::assert_length(group, n)

    ## Clean
    ok <- !is.na(x) & !is.na(y) & !is.na(group)
    x <- x[ok]
    y <- y[ok]
    group <- group[ok]

    ## Compute ellipse
    index <- split(seq_len(n), f = group)
    lapply(
      X = index,
      FUN = function(i) {
        xi <- x[i]
        yi <- y[i]
        if (length(xi) < 3) return(NULL)

        df <- 1
        radius <- sqrt(stats::qchisq(p = level, df = df))
        wrap_ellipse(xi, yi, radius = radius)
      }
    )
  }
)

#' @export
#' @rdname viz_tolerance
#' @aliases wrap_tolerance,MultivariateAnalysis,missing-method
setMethod(
  f = "wrap_tolerance",
  signature = c(x = "MultivariateAnalysis", y = "missing"),
  definition = function(x, margin = 1, axes = c(1, 2), group = NULL,
                        level = 0.95, principal = TRUE) {
    ## Validation
    arkhe::assert_scalar(margin, "numeric")
    arkhe::assert_type(axes, "numeric")
    arkhe::assert_length(axes, 2)

    ## Get coordinates
    data <- get_coordinates(x, margin = margin, principal = principal)
    data <- data[, axes]

    ## Add groups, if any
    if (length(group) > 1) {
      group <- group[get_order(x, margin = margin)]
    } else if (length(group) == 1) {
      group <- get_extra(x)[[group]]
    } else if (has_groups(x, margin = margin)) {
      group <- get_groups(x, margin = margin)
    }

    ## Compute ellipse
    methods::callGeneric(x = data[, 1], y = data[, 2],
                         group = group, level = level)
  }
)

#' @export
#' @rdname viz_tolerance
#' @aliases wrap_tolerance,PCOA,missing-method
setMethod(
  f = "wrap_tolerance",
  signature = c(x = "PCOA", y = "missing"),
  definition = function(x, axes = c(1, 2), group = NULL, level = 0.95) {
    ## Validation
    arkhe::assert_type(axes, "numeric")
    arkhe::assert_length(axes, 2)

    ## Get coordinates
    data <- get_coordinates(x)
    data <- data[, axes]

    ## Compute ellipse
    methods::callGeneric(x = data[, 1], y = data[, 2],
                         group = group, level = level)
  }
)

# Helpers ======================================================================
wrap_ellipse <- function(x, y, radius = 1) {
  ## Compute ellipse
  xy <- cbind(x, y)
  mu <- colMeans(xy)
  sigma <- stats::cov(xy)
  # rob <- robustbase::covMcd(xy)
  # mu <- rob$center
  # sigma <- rob$cov
  ellipse(sigma = sigma, mu = mu, radius = radius)
}

#' Computes an Ellipse
#'
#' @param sigma A square positive definite \eqn{2 \times 2}{2 x 2} covariance
#'  or correlation `matrix`.
#' @param mu A length-two [`numeric`] vector giving the centre of the ellipse.
#' @param scale If `sigma` is a correlation matrix, then the standard deviations
#'  of each parameter can be given in the scale parameter.
#'  Defaults to `c(1, 1)`, so no rescaling will be done.
#' @param level A length-\eqn{k} [`numeric`] vector giving the confidence level
#'  of a pairwise confidence region.
#' @param radius The size of the ellipse may also be controlled by specifying
#'  the value of a t-statistic on its boundary.
#' @param n A length-one [`numeric`] vector specifying the number of points used
#'  in the ellipse.
#' @param ... Currently not used.
#' @note Adapted from [ellipse::ellipse()].
#' @return
#'  A [`list`] of \eqn{k} \eqn{n \times 2}{n x 2} `matrix`, suitable for
#'  plotting.
#' @keywords internal
#' @noRd
ellipse <- function(sigma, ..., mu = c(0, 0), scale = c(1, 1), level = 0.95,
                    radius = sqrt(stats::qchisq(level, 2)), n = 100) {
  r <- sigma[1, 2]

  if (missing(scale)) {
    scale <- sqrt(diag(sigma))
    if (scale[1] > 0) r <- r / scale[1]
    if (scale[2] > 0) r <- r / scale[2]
  }

  r <- min(max(r, -1), 1)  # clamp to -1..1, in case of rounding errors
  d <- acos(r)
  a <- seq(0, 2 * pi, len = n)

  lapply(
    X = radius,
    FUN = function(x) {
      matrix(
        data = c(x * scale[1] * cos(a + d / 2) + mu[1],
                 x * scale[2] * cos(a - d / 2) + mu[2]),
        nrow = n,
        ncol = 2,
        dimnames = list(NULL, c("x", "y"))
      )
    }
  )
}

# GENERIC METHODS
#' @include AllClasses.R
NULL

# S4 dispatch to base S3 generic ===============================================
setGeneric("rownames")
setGeneric("colnames")
setGeneric("dimnames")
setGeneric("loadings")
setGeneric("biplot")

# Import S4 generics ===========================================================
#' @importMethodsFrom arkhe bootstrap
#' @importMethodsFrom arkhe describe
NULL

# Extract ======================================================================
## Dimnames --------------------------------------------------------------------
#' Dimnames of an Object
#'
#' Retrieve or set the dimnames of an object.
#' @param x An object from which to retrieve the row or column names
#'  (a [`CA-class`] or [`PCA-class`] object).
#' @param do.NULL A [`logical`] scalar. If `FALSE` and names are `NULL`, names
#'  are created.
#' @param prefix A [`character`] string specifying the prefix for created names.
#' @author N. Frerebeau
#' @docType methods
#' @family mutators
#' @name dimnames
#' @rdname dimnames
NULL

## Subset ----------------------------------------------------------------------
#' Extract Parts of an Object
#'
#' Operators acting on objects to extract parts.
#' @param x An object from which to extract element(s) or in which to replace
#'  element(s).
#' @param i A [`character`] string specifying elements to extract.
#'  Any unambiguous substring can be given (see details).
#' @details
#'  If `i` is "`data`", returns a list with the following elements:
#'  \describe{
#'   \item{`data`}{A [`numeric`] matrix of raw data.}
#'   \item{`mean`}{A [`numeric`] vector giving the variables means (`PCA`).}
#'   \item{`sd`}{A [`numeric`] vector giving the variables standard deviations
#'   (`PCA`).}
#'  }
#'
#'  If `i` is "`rows`", returns a list with the following elements:
#'  \describe{
#'   \item{`coord`}{A [`numeric`] matrix of rows/individuals coordinates.}
#'   \item{`cos2`}{A [`numeric`] matrix of rows/individuals squared cosine.}
#'   \item{`masses`}{A [`numeric`] vector giving the rows masses/individual
#'   weights.}
#'   \item{`sup`}{A [`logical`] vector specifying whether a point is a
#'   supplementary observation or not.}
#'  }
#'
#'  If `i` is "`columns`", returns a list with the following elements:
#'  \describe{
#'   \item{`coord`}{A [`numeric`] matrix of columns/variables coordinates.}
#'   \item{\code{cor}}{A [`numeric`] matrix of correlation between variables and
#'   the dimensions (`PCA`).}
#'   \item{`cos2`}{A [`numeric`] matrix of columns/variables squared cosine.}
#'   \item{`masses`}{A [`numeric`] vector giving the columns masses/variable
#'   weights.}
#'   \item{`sup`}{A [`logical`] vector specifying whether a point is a
#'   supplementary observation or not.}
#'  }
#'
#'  If `i` is "`eigenvalues`", returns a [`numeric`] vector of eigenvalues.
#' @return
#'  A [`list`].
#' @example inst/examples/ex-subset.R
#' @author N. Frerebeau
#' @docType methods
#' @family mutators
#' @name subset
#' @rdname subset
NULL

# CA ===========================================================================
#' Correspondence Analysis
#'
#' Computes a simple correspondence analysis based on the singular value
#' decomposition.
#' @param object A \eqn{m \times p}{m x p} `numeric` [`matrix`] or a
#'  [`data.frame`].
#' @param rank An [`integer`] value specifying the maximal number of
#'  components to be kept in the results. If `NULL` (the default),
#'  \eqn{min(m, p) - 1} components will be returned.
#' @param sup_row A `vector` specifying the indices of the supplementary rows.
#' @param sup_col A `vector` specifying the indices of the supplementary columns.
#' @param sup_quali A `vector` specifying the indices of the supplementary
#'  qualitative columns.
#' @param autodetect A [`logical`] scalar: should non-numeric variables be
#'  automatically removed?
#' @param ... Currently not used.
#' @return
#'  A [`CA-class`] object.
#' @example inst/examples/ex-ca.R
#' @seealso [svd()]
#' @references
#'  Greenacre, M. J. *Theory and Applications of Correspondence Analysis*.
#'  London: Academic Press, 1984.
#'
#'  Greenacre, M. J. *Correspondence Analysis in Practice*. Seconde edition.
#'  Interdisciplinary Statistics Series. Boca Raton: Chapman & Hall/CRC, 2007.
#'
#'  Lebart, L., Piron, M. and Morineau, A. *Statistique exploratoire
#'  multidimensionnelle: visualisation et inférence en fouille de données*.
#'  Paris: Dunod, 2006.
#' @author N. Frerebeau
#' @docType methods
#' @family multivariate analysis
#' @aliases ca-method
setGeneric(
  name = "ca",
  def = function(object, ...) standardGeneric("ca"),
  valueClass = "CA"
)

# MCA ==========================================================================
#' Multiple Correspondence Analysis
#'
#' Computes a multiple correspondence analysis.
#' @param object A \eqn{m \times p}{m x p} `numeric` [`matrix`] or a
#'  [`data.frame`].
#' @param rank An [`integer`] value specifying the maximal number of
#'  components to be kept in the results. If `NULL` (the default),
#'  \eqn{min(m, p) - 1} components will be returned.
#' @param sup_row A `vector` specifying the indices of the supplementary rows.
#' @param sup_col A `vector` specifying the indices of the supplementary
#'  categorical columns.
#' @param sup_quanti A `vector` specifying the indices of the supplementary
#'  quantitative columns.
#' @param autodetect A [`logical`] scalar: should numeric variables be
#'  automatically removed (except `sup_quanti`)?
#' @param ... Currently not used.
#' @return
#'  A [`MCA-class`] object.
# @example inst/examples/ex-mca.R
#' @seealso [svd()], [cdt()]
#' @references
#'  Lebart, L., Piron, M. and Morineau, A. *Statistique exploratoire
#'  multidimensionnelle: visualisation et inférence en fouille de données*.
#'  Paris: Dunod, 2006.
#' @author N. Frerebeau
#' @docType methods
#' @family multivariate analysis
#' @aliases mca-method
setGeneric(
  name = "mca",
  def = function(object, ...) standardGeneric("mca"),
  valueClass = "MCA"
)

# PCA ==========================================================================
#' Principal Components Analysis
#'
#' Computes a principal components analysis based on the singular value
#' decomposition.
#' @param object A \eqn{m \times p}{m x p} `numeric` [`matrix`] or a
#'  [`data.frame`].
#' @param center A [`logical`] scalar: should the variables be shifted to be
#'  zero centered?
#' @param scale A [`logical`] scalar: should the variables be scaled to unit
#'  variance?
#' @param rank An [`integer`] value specifying the maximal number of components
#'  to be kept in the results. If `NULL` (the default), \eqn{p - 1} components
#'  will be returned.
#' @param sup_row A `vector` specifying the indices of the supplementary rows.
#' @param sup_col A `vector` specifying the indices of the supplementary columns.
#' @param sup_quali A `vector` specifying the indices of the supplementary
#'  qualitative columns.
#' @param weight_row A [`numeric`] vector specifying the active row (individual)
#'  weights. If `NULL` (the default), uniform weights are used. Row weights are
#'  internally normalized to sum 1
#' @param weight_col A [`numeric`] vector specifying the active column
#'  (variable) weights. If `NULL` (the default), uniform weights (1) are
#'  used.
#' @param autodetect A [`logical`] scalar: should non-numeric variables be
#'  automatically removed (except `sup_quali`)?
#' @param ... Currently not used.
#' @return
#'  A [`PCA-class`] object.
#' @example inst/examples/ex-pca.R
#' @seealso [svd()]
#' @references
#'  Lebart, L., Piron, M. and Morineau, A. *Statistique exploratoire
#'  multidimensionnelle: visualisation et inférence en fouille de données*.
#'  Paris: Dunod, 2006.
#' @author N. Frerebeau
#' @docType methods
#' @family multivariate analysis
#' @aliases pca-method
setGeneric(
  name = "pca",
  def = function(object, ...) standardGeneric("pca"),
  valueClass = "PCA"
)

# PCoA =========================================================================
#' Principal Coordinates Analysis
#'
#' Computes classical (metric) multidimensional scaling.
#' @param object A [distance structure][stats::dist()].
#' @param rank An [`integer`] value specifying the maximal number dimension of
#'  the space which the data are to be represented in.
#' @param ... Currently not used.
#' @return
#'  A [`PCOA-class`] object.
#' @references
#'  Gower, J. C. (1966). Some Distance Properties of Latent Root and Vector
#'  Methods Used in Multivariate Analysis. *Biometrika*, 53(3‑4): 325-338.
#'  \doi{10.1093/biomet/53.3-4.325}.
#' @example inst/examples/ex-pcoa.R
#' @seealso [stats::cmdscale()]
#' @author N. Frerebeau
#' @docType methods
#' @family multivariate analysis
#' @aliases pcoa-method
setGeneric(
  name = "pcoa",
  def = function(object, ...) standardGeneric("pcoa"),
  valueClass = "PCOA"
)

# Predict ======================================================================
#' Predict New Coordinates
#'
#' Predict the projection of new individuals/rows or variables/columns.
#' @param object A [`CA-class`] or [`PCA-class`] object.
#' @param newdata An object of supplementary points coercible to a
#'  [`matrix`] for which to compute principal coordinates.
#' @param margin A length-one [`numeric`] vector giving the subscript which the
#'  data will be predicted: `1` indicates individuals/rows (the default), `2`
#'  indicates variables/columns.
#' @return
#'  A [`data.frame`] of coordinates.
#' @example inst/examples/ex-predict.R
#' @author N. Frerebeau
#' @docType methods
#' @family multivariate analysis
#' @name predict
#' @rdname predict
NULL

# Bootstrap ====================================================================
#' Partial Bootstrap Analysis
#'
#' Checks analysis with partial bootstrap resampling.
#' @param object A [`CA-class`] or [`PCA-class`] object.
#' @param n A non-negative [`integer`] giving the number of bootstrap
#'  replications.
#' @return
#'  Returns a [`BootstrapCA-class`] or a [`BootstrapPCA-class`] object.
#' @example inst/examples/ex-bootstrap.R
#' @references
#'  Greenacre, Michael J. *Theory and Applications of Correspondence
#'  Analysis*. London: Academic Press, 1984.
#'
#'  Lebart, L., Piron, M. and Morineau, A. *Statistique exploratoire
#'  multidimensionnelle: visualisation et inférence en fouille de données*.
#'  Paris: Dunod, 2006.
#'
#'  Lockyear, K. (2013). Applying Bootstrapped Correspondence Analysis to
#'  Archaeological Data. *Journal of Archaeological Science*, 40(12): 4744-4753.
#'  \doi{10.1016/j.jas.2012.08.035}.
#'
#'  Ringrose, T. J. (1992). Bootstrapping and Correspondence Analysis in
#'  Archaeology. *Journal of Archaeological Science*, 19(6): 615-629.
#'  \doi{10.1016/0305-4403(92)90032-X}.
#' @author N. Frerebeau
#' @docType methods
#' @family resampling methods
#' @name bootstrap
#' @rdname bootstrap
NULL

# Results ======================================================================
#' Export Results
#'
#' Creates a Zip archive of all results in CSV format.
#' @param object A [`CA-class`], [`MCA-class`] or [`PCA-class`] object.
#' @param file A [`character`] string specifying the pathname of the zip file.
#' @param flags A [`character`] string of flags (see [utils::zip()]).
#' @param ... Currently not used.
#' @example inst/examples/ex-export.R
#' @seealso [utils::write.csv()], [utils::zip()]
#' @author N. Frerebeau
#' @docType methods
#' @family getters
#' @aliases export-method
setGeneric(
  name = "export",
  def = function(object, ...) standardGeneric("export")
)

### Data -----------------------------------------------------------------------
#' Get Original Data
#'
#' @param x An object from which to get element(s) (a [`CA-class`],
#'  [`MCA-class`] or [`PCA-class`] object).
#' @param ... Currently not used.
#' @return
#'  Returns a [`data.frame`] of original data.
#' @author N. Frerebeau
#' @docType methods
#' @family getters
#' @aliases get_data-method
setGeneric(
  name = "get_data",
  def = function(x, ...) standardGeneric("get_data"),
  valueClass = "data.frame"
)

## Coordinates -----------------------------------------------------------------
#' Get Coordinates
#'
#' @param x An object from which to get element(s) (a [`CA-class`],
#'  [`MCA-class`] or [`PCA-class`] object).
#' @param margin A length-one [`numeric`] vector giving the subscript which the
#'  data will be returned: `1` indicates individuals/rows (the default), `2`
#'  indicates variables/columns.
#' @param principal A [`logical`] scalar: should principal coordinates be
#'  returned? If `FALSE`, standard coordinates are returned.
#' @param sup_name A [`character`] string specifying the name of the column to
#'  create for supplementary points attribution (see below).
#' @param ... Currently not used.
#' @return
#'  * `get_coordinates()` returns a [`data.frame`] of coordinates. An extra
#'    column (named after `sup_name`) is added specifying whether an observation
#'    is a supplementary point or not.
#'  * `get_replications()` returns an [`array`] of coordinates.
#' @example inst/examples/ex-coordinates.R
#' @author N. Frerebeau
#' @docType methods
#' @family getters
#' @aliases get_coordinates-method
setGeneric(
  name = "get_coordinates",
  def = function(x, ...) standardGeneric("get_coordinates"),
  valueClass = "data.frame"
)

#' @rdname get_coordinates
#' @aliases get_replications-method
setGeneric(
  name = "get_replications",
  def = function(x, ...) standardGeneric("get_replications"),
  valueClass = "array"
)

## Eigenvalues -----------------------------------------------------------------
#' Get Eigenvalues
#'
#' @param x An object from which to get element(s) (a [`CA-class`],
#'  [`MCA-class`] or [`PCA-class`] object).
#' @param margin A length-one [`numeric`] vector giving the subscript which the
#'  data will be returned: `1` indicates individuals/rows (the default), `2`
#'  indicates variables/columns.
#' @param digits An [`integer`] indicating the number of decimal places to be
#'  used.
#' @param ... Currently not used.
#' @return
#'  * `get_eigenvalues()` returns a [`data.frame`] with the following columns:
#'    `eigenvalues`, `variance` (percentage of variance) and `cumulative`
#'    (cumulative percentage of variance).
#'  * `get_variance()` returns a [`numeric`] vector giving the amount of
#'    variance explained by each (principal) component.
#'  * `get_distance()`returns a [`numeric`] vector of squared distance to the
#'    centroid.
#'  * `get_inertia()` returns a [`numeric`] vector giving the inertia (weighted
#'    squared distance to the centroid).
#' @author N. Frerebeau
#' @docType methods
#' @family getters
#' @aliases get_eigenvalues-method
setGeneric(
  name = "get_eigenvalues",
  def = function(x) standardGeneric("get_eigenvalues"),
  valueClass = "data.frame"
)

#' @rdname get_eigenvalues
#' @aliases get_variance-method
setGeneric(
  name = "get_variance",
  def = function(x, ...) standardGeneric("get_variance"),
  valueClass = "numeric"
)

#' @rdname get_eigenvalues
#' @aliases get_distances-method
setGeneric(
  name = "get_distances",
  def = function(x, ...) standardGeneric("get_distances"),
  valueClass = "numeric"
)

#' @rdname get_eigenvalues
#' @aliases get_inertia-method
setGeneric(
  name = "get_inertia",
  def = function(x, ...) standardGeneric("get_inertia"),
  valueClass = "numeric"
)

## Contributions ---------------------------------------------------------------
#' Get Contributions
#'
#' @param x An object from which to get element(s) (a [`CA-class`],
#'  [`MCA-class`] or [`PCA-class`] object).
#' @param margin A length-one [`numeric`] vector giving the subscript which the
#'  data will be returned: `1` indicates individuals/rows (the default), `2`
#'  indicates variables/columns.
#' @param sup_name A [`character`] string specifying the name of the column to
#'  create for supplementary points attribution (see below).
#' @param ... Currently not used.
#' @return
#'  * `get_contributions()` returns a [`data.frame`] of contributions to the
#'    definition of the principal dimensions.
#'  * `get_correlations()` returns a [`data.frame`] of correlations between
#'    variables and dimensions. An extra column (named after `sup_name`)
#'    is added specifying whether an observation is a supplementary point or
#'    not.
#'  * `get_cos2()` returns a [`data.frame`] of \eqn{cos^2}{cos2} values (i.e.
#'    quality of the representation of the points on the factor map). An extra
#'    column (named after `sup_name`) is added specifying whether an observation
#'    is a supplementary point or not.
#' @author N. Frerebeau
#' @docType methods
#' @family getters
#' @aliases get_contributions-method
setGeneric(
  name = "get_contributions",
  def = function(x, ...) standardGeneric("get_contributions"),
  valueClass = "data.frame"
)

#' @rdname get_contributions
#' @aliases get_correlations-method
setGeneric(
  name = "get_correlations",
  def = function(x, ...) standardGeneric("get_correlations"),
  valueClass = "data.frame"
)

#' @rdname get_contributions
#' @aliases get_cos2-method
setGeneric(
  name = "get_cos2",
  def = function(x, ...) standardGeneric("get_cos2"),
  valueClass = "data.frame"
)

# Plot =========================================================================
#' Plot Coordinates
#'
#' @param x An \R object.
#' @param ... Further [graphical parameters][graphics::par].
#' @inheritParams viz_points
#' @author N. Frerebeau
#' @docType methods
#' @family plot methods
#' @name plot
#' @rdname plot
NULL

## Biplot ----------------------------------------------------------------------
#' Biplot
#'
#' @param x A [`CA-class`], [`MCA-class`] or [`PCA-class`] object.
#' @param axes A length-two [`numeric`] vector giving the dimensions to be
#'  plotted.
#' @param type A [`character`] string specifying the biplot to be plotted
#'  (see below). It must be one of "`rows`", "`columns`", "`contribution`" (CA),
#'  "`form`" or "`covariance`" (PCA). Any unambiguous substring can be given.
#' @param labels A [`character`] vector specifying whether
#'  "`rows`"/"`individuals`" and/or "`columns`"/"`variables`" names must be
#'  drawn. Any unambiguous substring can be given.
#' @param col.rows,col.columns A length-two `vector` of color specification for
#'  the active and supplementary rows/columns.
#' @param pch.rows,pch.columns A length-two `vector` of symbol specification for
#'  the active and supplementary rows/columns.
#' @param lty.columns A length-two `vector` of line type specification for
#'  the active and supplementary columns.
#' @param size A length-two [`numeric`] vector giving range of possible sizes
#'  (greater than 0). Only used if `type` is "`contribution`" (CA).
#' @param xlim A length-two [`numeric`] vector giving the x limits of the plot.
#'  The default value, `NULL`, indicates that the range of the
#'  [finite][is.finite()] values to be plotted should be used.
#' @param ylim A length-two [`numeric`] vector giving the y limits of the plot.
#'  The default value, `NULL`, indicates that the range of the
#'  [finite][is.finite()] values to be plotted should be used.
#' @param main A [`character`] string giving a main title for the plot.
#' @param sub A [`character`] string giving a subtitle for the plot.
#' @param legend A [`list`] of additional arguments to be passed to
#'  [graphics::legend()]; names of the list are used as argument names.
#'  If `NULL`, no legend is displayed.
#' @inheritParams prepare_plot
#' @param ... Currently not used.
#' @details
#'  A biplot is the simultaneous representation of rows and columns of a
#'  rectangular dataset. It is the generalization of a scatterplot to the case
#'  of mutlivariate data: it allows to visualize as much information as possible
#'  in a single graph (Greenacre 2010).
#'
#'  Biplots have the drawbacks of their advantages: they can quickly become
#'  difficult to read as they display a lot of information at once. It may then
#'  be preferable to visualize the results for individuals and variables
#'  separately.
#' @section PCA Biplots:
#'  \describe{
#'   \item{`form` (row-metric-preserving)}{The form biplot favors the
#'   representation of the individuals: the distance between the individuals
#'   approximates the Euclidean distance between rows. In the form biplot the
#'   length of a vector approximates the quality of the representation of the
#'   variable.}
#'   \item{`covariance` (column-metric-preserving)}{The covariance biplot favors
#'   the representation of the variables: the length of a vector approximates
#'   the standard deviation of the variable and the cosine of the angle formed
#'   by two vectors approximates the correlation between the two variables. In
#'   the covariance biplot the distance between the individuals approximates the
#'   Mahalanobis distance between rows.}
#'  }
#' @section CA Biplots:
#'  \describe{
#'   \item{`symetric` (symetric biplot)}{Represents the row and column profiles
#'   simultaneously in a common space: rows and columns are in standard
#'   coordinates. Note that the the inter-distance between any row and column
#'   items is not meaningful (i.e. the proximity between rows and columns cannot
#'   be directly interpreted).}
#'   \item{`rows` (asymetric biplot)}{Row principal biplot (row-metric-preserving)
#'   with rows in principal coordinates and columns in standard coordinates.}
#'   \item{`columns` (asymetric biplot)}{Column principal biplot
#'   (column-metric-preserving) with rows in standard coordinates and columns in
#'   principal coordinates.}
#'   \item{`contribution` (asymetric biplot)}{Contribution biplot with rows in
#'   principal coordinates and columns in standard coordinates multiplied by the
#'   square roots of their masses.}
#'  }
#' @return
#'  `biplot()` is called for its side-effects: it results in a graphic being
#'  displayed. Invisibly returns `x`.
#' @example inst/examples/ex-biplot.R
#' @references
#'  Aitchison, J. and Greenacre, M. J. (2002). Biplots of Compositional Data.
#'  *Journal of the Royal Statistical Society: Series C (Applied Statistics)*,
#'  51(4): 375-92. \doi{10.1111/1467-9876.00275}.
#'
#'  Greenacre, M. J. (2010). *Biplots in Practice*. Bilbao: Fundación BBVA.
#' @author N. Frerebeau
#' @docType methods
#' @family plot methods
#' @name biplot
#' @rdname biplot
NULL

## Coordinates -----------------------------------------------------------------
#' Visualize Individuals Factor Map
#'
#' Plots row/individual principal coordinates.
#' @inheritParams viz_points
#' @param ... Further [graphical parameters][graphics::par].
#' @return
#'  `viz_*()` is called for its side-effects: it results in a graphic
#'  being displayed. Invisibly returns `x`.
#' @example inst/examples/ex-plot.R
#' @author N. Frerebeau
#' @docType methods
#' @family plot methods
#' @aliases viz_individuals-method
setGeneric(
  name = "viz_individuals",
  def = function(x, ...) standardGeneric("viz_individuals")
)

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

#' Visualize Variables Factor Map
#'
#' Plots column/variable principal coordinates.
#' @inheritParams viz_points
#' @param ... Further [graphical parameters][graphics::par].
#' @return
#'  `viz_*()` is called for its side-effects: it results in a graphic
#'  being displayed. Invisibly returns `x`.
#' @example inst/examples/ex-plot.R
#' @author N. Frerebeau
#' @docType methods
#' @family plot methods
#' @aliases viz_variables-method
setGeneric(
  name = "viz_variables",
  def = function(x, ...) standardGeneric("viz_variables")
)

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

## Eigenvalues -----------------------------------------------------------------
#' Scree Plot
#'
#' Plot eigenvalues (scree plot) or variances histogram.
#' @param x A [`CA-class`], [`MCA-class`] or [`PCA-class`] object.
#' @param eigenvalues A [`logical`] scalar: should the eigenvalues be plotted
#'  instead of variance/inertia?
#' @param cumulative A [`logical`] scalar: should the cumulative percentages of
#'  variance be plotted?
#' @param labels A [`logical`] scalar: should text labels be drawn on top of
#'  bars?
#' @param limit An [`integer`] specifying the number of top elements to be
#'  displayed.
#' @param col,border A [`character`] string specifying the bars infilling and
#'  border colors.
#' @param col.cumulative A specification for the line color.
#' @param lty.cumulative A specification for the line type.
#' @param lwd.cumulative A specification for the line width.
#' @param ... Extra parameters to be passed to [graphics::barplot()].
#' @return
#'  `screeplot()` is called for its side-effects: it results in a graphic
#'  being displayed. Invisibly returns `x`.
#' @example inst/examples/ex-screeplot.R
#' @author N. Frerebeau
#' @docType methods
#' @family plot methods
#' @aliases screeplot-method
#' @name screeplot
#' @rdname screeplot
NULL

## Contributions ---------------------------------------------------------------
#' Visualize Contributions and cos2
#'
#' Plots contributions histogram and \eqn{cos^2}{cos2} scatterplot.
#' @param x A [`CA-class`], [`MCA-class`] or [`PCA-class`] object.
#' @param margin A length-one [`numeric`] vector giving the subscript which the
#'  data will be returned: `1` indicates individuals/rows (the default), `2`
#'  indicates variables/columns.
#' @param axes A [`numeric`] vector giving the dimensions to be plotted.
#' @param active A [`logical`] scalar: should the active observations be
#'  plotted?
#' @param sup A [`logical`] scalar: should the supplementary observations be
#'  plotted?
#' @param sort A [`logical`] scalar: should the data be sorted?
#' @param decreasing A [`logical`] scalar: should the sort order be decreasing?
#'  Only used if `sort` is `TRUE`.
#' @param limit An [`integer`] specifying the number of top elements to be
#'  displayed.
#' @param horiz A [`logical`] scalar: should the bars be drawn horizontally
#'  with the first at the bottom?
#' @param col,border A [`character`] string specifying the bars infilling and
#'  border colors.
#' @param ... Extra parameters to be passed to [graphics::barplot()].
#' @details
#'  The red dashed line indicates the expected average contribution (variables
#'  with a contribution larger than this cutoff can be considered as important
#'  in contributing to the component).
#' @return
#'  `viz_contributions()` and `viz_cos2()` are called for their side-effects:
#'  they result in a graphic being displayed. Invisibly return `x`.
#' @example inst/examples/ex-contributions.R
#' @author N. Frerebeau
#' @docType methods
#' @family plot methods
#' @aliases viz_contributions-method
setGeneric(
  name = "viz_contributions",
  def = function(x, ...) standardGeneric("viz_contributions")
)

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

# Envelopes ====================================================================
#' Convex Hulls
#'
#' Plots convex hull of a set of observations.
#' @param x,y A [`numeric`] vector. If `y` is missing, `x` must be an object
#'  from which to wrap observations (a [`CA-class`], [`MCA-class`] or
#'  [`PCA-class`] object).
#' @param margin A length-one [`numeric`] vector giving the subscript which the
#'  data will be returned: `1` indicates individuals/rows (the default), `2`
#'  indicates variables/columns.
#' @param axes A length-two [`numeric`] vector giving the dimensions
#'  for which to compute results.
#' @param group A vector specifying the group an observation belongs to.
#' @param principal A [`logical`] scalar: should principal coordinates be
#'  used? If `FALSE`, standard coordinates are returned.
#' @param color The colors for borders (will be mapped to `group`).
#'  Ignored if set to `FALSE`. If `NULL`, the default color scheme will be used.
#' @param fill The background colors (will be mapped to `group`).
#'  Ignored if set to `FALSE`.
#' @param symbol A vector of symbols (will be mapped to `group`).
#'  Ignored if set to `FALSE`.
#' @param ... Further [graphical parameters][graphics::par] to be passed to
#'  [graphics::polygon()].
#' @return
#'  `wrap_hull()` returns a [`data.frame`] of envelope `x` and `y` coordinates.
#'  An extra column named `group` is added specifying the group an observation
#'  belongs to.
#'
#'  `viz_hull()`is called for its side-effects: it results in a graphic being
#'  displayed. Invisibly returns `x`.
#' @example inst/examples/ex-hull.R
#' @author N. Frerebeau
#' @docType methods
#' @family envelopes
#' @aliases viz_hull-method
setGeneric(
  name = "viz_hull",
  def = function(x, y, ...) standardGeneric("viz_hull")
)

#' @rdname viz_hull
#' @aliases wrap_hull-method
setGeneric(
  name = "wrap_hull",
  def = function(x, y, ...) standardGeneric("wrap_hull")
)

#' Ellipses
#'
#' Plots ellipses.
#' @inheritParams viz_hull
#' @param level A [`numeric`] vector specifying the confidence/tolerance level.
#' @param type A [`character`] string specifying the ellipse to draw.
#'  It must be one of "`tolerance`" or "`confidence`").
#'  Any unambiguous substring can be given.
#' @return
#'  `viz_ellipses()`is called for its side-effects: it results in a graphic
#'  being displayed. Invisibly returns `x`.
#' @example inst/examples/ex-ellipses.R
#' @author N. Frerebeau
#' @docType methods
#' @family envelopes
#' @aliases viz_ellipses-method
setGeneric(
  name = "viz_ellipses",
  def = function(x, y, ...) standardGeneric("viz_ellipses")
)

#' Confidence Ellipses
#'
#' Plots confidence ellipses.
#' @inheritParams viz_hull
#' @inheritParams viz_ellipses
#' @return
#'  `wrap_confidence()` returns a [`data.frame`] of envelope `x` and `y`
#'  coordinates. An extra column named `group` is added specifying the group an
#'  observation belongs to.
#'
#'  `viz_confidence()`is called for its side-effects: it results in a graphic
#'  being displayed. Invisibly returns `x`.
#' @example inst/examples/ex-confidence.R
#' @author N. Frerebeau
#' @docType methods
#' @family envelopes
#' @aliases viz_confidence-method
setGeneric(
  name = "viz_confidence",
  def = function(x, y, ...) standardGeneric("viz_confidence")
)

#' @rdname viz_confidence
#' @aliases wrap_confidence-method
setGeneric(
  name = "wrap_confidence",
  def = function(x, y, ...) standardGeneric("wrap_confidence")
)

#' Tolerance Ellipses
#'
#' Plots tolerance ellipses.
#' @inheritParams viz_hull
#' @inheritParams viz_ellipses
#' @return
#'  `wrap_tolerance()` returns a [`data.frame`] of envelope `x` and `y`
#'  coordinates. An extra column named `group` is added specifying the group an
#'  observation belongs to.
#'
#'  `viz_tolerance()`is called for its side-effects: it results in a graphic
#'  being displayed. Invisibly returns `x`.
#' @example inst/examples/ex-tolerance.R
#' @author N. Frerebeau
#' @docType methods
#' @family envelopes
#' @aliases viz_tolerance-method
setGeneric(
  name = "viz_tolerance",
  def = function(x, y, ...) standardGeneric("viz_tolerance")
)

#' @rdname viz_tolerance
#' @aliases wrap_tolerance-method
setGeneric(
  name = "wrap_tolerance",
  def = function(x, y, ...) standardGeneric("wrap_tolerance")
)

# Summarize ====================================================================
#' Object Summaries
#'
#' Provides a summary of the results of a multivariate data analysis.
#' @param object A [`CA-class`], [`MCA-class`] or [`PCA-class`] object.
#' @param axes A length-two [`numeric`] vector giving the dimensions to be
#'  summarized.
#' @param margin A length-one [`numeric`] vector giving the subscript which the
#'  data will be summarized: `1` indicates individuals/rows (the default), `2`
#'  indicates variables/columns.
#' @param rank An [`integer`] value specifying the maximal number of components
#'  to be kept in the results. Deprecated, use `axes` instead.
#' @param active A [`logical`] scalar: should the active observations be
#'  summarized?
#' @param sup A [`logical`] scalar: should the supplementary observations be
#'  summarized?
#' @param x A [`MultivariateSummary-class`] object.
#' @param row.names A [`character`] vector giving the row names for the data
#'  frame, or `NULL`.
#' @param optional A [`logical`] scalar: should the names of the variables in
#'  the data frame be checked? If `FALSE` then the names of the variables in the
#'  data frame are checked to ensure that they are syntactically valid variable
#'  names and are not duplicated.
#' @param ... Currently not used.
#' @example inst/examples/ex-summary.R
#' @author N. Frerebeau
#' @docType methods
#' @family summary
#' @name summary
#' @rdname summary
NULL

#' Object Description
#'
#' @param x A [`CA-class`], [`MCA-class`] or [`PCA-class`] object.
#' @param ... Further parameters to be passed to [cat()].
#' @return
#'  `describe()` is called for its side-effects. Invisibly returns `x`.
#' @example inst/examples/ex-summary.R
#' @author N. Frerebeau
#' @family summary
#' @docType methods
#' @rdname describe
#' @name describe
NULL

#' Tidy Coordinates
#'
#' @param x A [`CA-class`], [`MCA-class`] or [`PCA-class`] object.
#' @param margin A length-one [`numeric`] vector giving the subscript
#'  which the data will be returned: `1` indicates individuals/rows (the
#'  default), `2` indicates variables/columns.
#' @param axes A length-two [`numeric`] vector giving the dimensions
#'  for which to compute results.
#' @param principal A [`logical`] scalar: should principal coordinates be
#'  returned? If `FALSE`, standard coordinates are returned.
#' @param ... Currently not used.
#' @return
#'  `tidy()` returns a long [`data.frame`] with the following columns:
#'    \describe{
#'     \item{`label`}{Row/column names of the original data.}
#'     \item{`component`}{Component.}
#'     \item{`supplementary`}{Whether an observation is active or
#'     supplementary.}
#'     \item{`coordinate`}{Coordinates.}
#'     \item{`contribution`}{Contributions to the definition of the components.}
#'     \item{`cos2`}{\eqn{cos^2}{cos2}.}
#'    }
#'
#'  `augment()` returns a wide [`data.frame`] of the row/column coordinates
#'    along `axes` and the following columns:
#'    \describe{
#'     \item{`label`}{Row/column names of the original data.}
#'     \item{`supplementary`}{Whether an observation is active or
#'     supplementary.}
#'     \item{`mass`}{Weight/mass of each observation.}
#'     \item{`sum`}{Sum of squared coordinates along `axes`.}
#'     \item{`contribution`}{Joint contributions to the definition of `axes`.}
#'     \item{`cos2`}{Joint \eqn{cos^2}{cos2} along `axes`.}
#'    }
#' @example inst/examples/ex-coordinates.R
#' @author N. Frerebeau
#' @docType methods
#' @family summary
#' @aliases tidy-method
setGeneric(
  name = "tidy",
  def = function(x, ...) standardGeneric("tidy"),
  valueClass = "data.frame"
)

#' @rdname tidy
#' @aliases augment-method
setGeneric(
  name = "augment",
  def = function(x, ...) standardGeneric("augment"),
  valueClass = "data.frame"
)

# Tools ========================================================================
#' Complete Disjunctive Table
#'
#' Computes the complete disjunctive table of a factor table.
#' @param object A [`data.frame`].
#' @param exclude A `vector` of values to be excluded when forming the set of
#'  levels (see [factor()]). If `NULL` (the default), will make `NA` an extra
#'  level.
#' @param abbrev A [`logical`] scalar: should the column names be abbreviated?
#'  If `FALSE`, these are of the form 'factor_level' but if `abbrev = TRUE` they
#'  are just 'level' which will suffice if the factors have distinct levels.
#' @param ... Currently not used.
#' @return A [`data.frame`].
#' @example inst/examples/ex-cdt.R
#' @author N. Frerebeau
#' @docType methods
#' @family tools
#' @aliases cdt-method
setGeneric(
  name = "cdt",
  def = function(object, ...) standardGeneric("cdt")
)

#' Burt Table
#'
#' Computes the burt table of a factor table.
#' @param object A [`data.frame`].
#' @inheritParams cdt
#' @param ... Currently not used.
#' @return A symetric [`matrix`].
#' @example inst/examples/ex-cdt.R
#' @author N. Frerebeau
#' @docType methods
#' @family tools
#' @aliases burt-method
setGeneric(
  name = "burt",
  def = function(object, ...) standardGeneric("burt")
)

# BIPLOT
#' @include AllGenerics.R
NULL

# CA ===========================================================================
#' @export
#' @method biplot CA
biplot.CA <- function(x, ..., axes = c(1, 2),
                      type = c("symetric", "rows", "columns", "contributions"),
                      active = TRUE, sup = TRUE, labels = NULL,
                      col.rows = c("#E69F00", "#E69F00"),
                      col.columns = c("#56B4E9", "#56B4E9"),
                      pch.rows = c(16, 1), pch.columns = c(17, 2),
                      size = c(1, 3),
                      xlim = NULL, ylim = NULL, main = NULL, sub = NULL,
                      legend = list(x = "topleft")) {
  ## Validation
  type <- match.arg(type, several.ok = FALSE)

  ## Type of biplot
  if (type == "symetric") {
    princ_row <- TRUE
    princ_col <- TRUE
  }
  if (type == "rows") {
    princ_row <- TRUE
    princ_col <- FALSE
  }
  if (type == "columns") {
    princ_row <- FALSE
    princ_col <- TRUE
  }
  if (type == "contributions") {
    princ_row <- FALSE
    princ_col <- TRUE
    sup <- FALSE # Override
  }

  ## Get data
  coord_col <-  prepare_plot(x, margin = 2, axes = axes, active = active, sup = sup,
                             principal = princ_col, extra_quali = "observation",
                             color = col.columns, symbol = pch.columns, line_type = 0)
  coord_row <-  prepare_plot(x, margin = 1, axes = axes, active = active, sup = sup,
                             principal = princ_row, extra_quali = "observation",
                             color = col.rows, symbol = pch.rows, line_type = 0)

  ## Graphical parameters
  if (type == "contributions") {
    mass_row <- get_masses(x, margin = 1)
    mass_col <- get_masses(x, margin = 2)

    coord_row$x <- coord_row$x * sqrt(mass_row)
    coord_row$y <- coord_row$y * sqrt(mass_row)

    coord_row$cex <- khroma::palette_size_sequential(size)(mass_row)
    coord_col$cex <- khroma::palette_size_sequential(size)(mass_col)
  }

  coord <- viz_biplot(
    coord_row, coord_col,
    rows = TRUE, columns = TRUE,
    labels = labels,
    xlim = xlim, ylim = ylim,
    main = main, sub = sub,
    xlab = print_variance(x, axes[[1]]),
    ylab = print_variance(x, axes[[2]]),
    legend = legend,
    ...
  )

  ## Add legend
  prepare_legend(coord, legend, points = TRUE, lines = FALSE)

  invisible(x)
}

#' @export
#' @rdname biplot
#' @aliases biplot,CA-method
setMethod("biplot", c(x = "CA"), biplot.CA)

# PCA ==========================================================================
#' @export
#' @method biplot PCA
biplot.PCA <- function(x, ..., axes = c(1, 2), type = c("form", "covariance"),
                       active = TRUE, sup = TRUE, labels = "variables",
                       col.rows = c("#E69F00", "#E69F00"),
                       col.columns = c("#56B4E9", "#56B4E9"),
                       pch.rows = c(16, 1), lty.columns = c(1, 3),
                       xlim = NULL, ylim = NULL, main = NULL, sub = NULL,
                       legend = list(x = "topleft")) {
  ## Validation
  type <- match.arg(type, several.ok = FALSE)

  ## Type of biplot
  if (type == "form") {
    princ_row <- TRUE
    princ_col <- FALSE
  }
  if (type == "covariance") {
    princ_row <- FALSE
    princ_col <- TRUE
  }

  ## Get data
  coord_col <-  prepare_plot(x, margin = 2, axes = axes, active = active, sup = sup,
                             principal = princ_col, extra_quali = "observation",
                             color = col.columns, symbol = NA,
                             line_type = lty.columns, ...)
  coord_row <-  prepare_plot(x, margin = 1, axes = axes, active = active, sup = sup,
                             principal = princ_row, extra_quali = "observation",
                             color = col.rows, symbol = pch.rows,
                             line_type = NA, ...)

  arrows_col <- function() {
    graphics::arrows(
      x0 = 0, y0 = 0,
      x1 = coord_col$x, y1 = coord_col$y,
      length = 0.10, angle = 30,
      col = coord_col$col, lty = coord_col$lty, lwd = coord_col$lwd
    )
  }

  coord <- viz_biplot(
    coord_row, coord_col,
    rows = TRUE, columns = FALSE, labels = labels,
    xlim = xlim, ylim = ylim,
    main = main, sub = sub,
    xlab = print_variance(x, axes[[1]]),
    ylab = print_variance(x, axes[[2]]),
    panel.first = arrows_col(),
    legend = legend,
    ...
  )

  ## Add legend
  prepare_legend(coord, legend, points = TRUE, lines = TRUE)

  invisible(x)
}

#' @export
#' @rdname biplot
#' @aliases biplot,PCA-method
setMethod("biplot", c(x = "PCA"), biplot.PCA)

# Helpers ======================================================================
#' Build a Biplot
#'
#' @param coord_row A [`data.frame`] returned by [prepare_plot()].
#' @param coord_col A [`data.frame`] returned by [prepare_plot()].
#' @param rows A [`logical`] scalar: should the rows be drawn?
#' @param columns A [`logical`] scalar: should the columns be drawn?
#' @param labels A [`character`] vector specifying whether
#'  "`rows`"/"`individuals`" and/or "`columns`"/"`variables`" names must be
#'  drawn. Any unambiguous substring can be given.
#' @param xlim A length-two [`numeric`] vector giving the x limits of the plot.
#'  The default value, `NULL`, indicates that the range of the
#'  [finite][is.finite()] values to be plotted should be used.
#' @param ylim A length-two [`numeric`] vector giving the y limits of the plot.
#'  The default value, `NULL`, indicates that the range of the
#'  [finite][is.finite()] values to be plotted should be used.
#' @param main A [`character`] string giving a main title for the plot.
#' @param sub A [`character`] string giving a subtitle for the plot.
#' @param xlab,ylab A [`character`] vector giving the x and y axis labels.
#' @param axes A [`logical`] scalar: should axes be drawn on the plot?
#' @param frame.plot A [`logical`] scalar: should a box be drawn around the
#'  plot?
#' @param ann A [`logical`] scalar: should the default annotation (title and x
#'  and y axis labels) appear on the plot?
#' @param panel.first An `expression` to be evaluated after the plot axes are
#'  set up but before any plotting takes place. This can be useful for drawing
#'  background grids.
#' @param panel.last An `expression` to be evaluated after plotting has taken
#'  place but before the axes, title and box are added.
#' @return A [`data.frame`] to be passed to [prepare_legend()].
#' @author N. Frerebeau
#' @keywords internal
#' @noRd
viz_biplot <- function(coord_row, coord_col, ..., rows = TRUE, columns = TRUE,
                       labels = c("rows", "columns", "individuals", "variables"),
                       xlim = NULL, ylim = NULL, main = NULL, sub = NULL,
                       xlab = NULL, ylab = NULL, axes = TRUE, frame.plot = axes,
                       ann = graphics::par("ann"),
                       panel.first = NULL, panel.last = NULL) {

  ## Save and restore graphical parameters
  ## pty: square plotting region, independent of device size
  old_par <- graphics::par(pty = "s", no.readonly = TRUE)
  on.exit(graphics::par(old_par), add = TRUE)

  ## Open new window
  grDevices::dev.hold()
  on.exit(grDevices::dev.flush(), add = TRUE)
  graphics::plot.new()

  ## Set plotting coordinates
  xlim <- xlim %||% range(coord_row$x, coord_col$x, na.rm = TRUE, finite = TRUE)
  ylim <- ylim %||% range(coord_row$y, coord_col$y, na.rm = TRUE, finite = TRUE)
  graphics::plot.window(xlim = xlim, ylim = ylim, asp = 1)

  ## Evaluate pre-plot expressions
  panel.first

  ## Plot
  graphics::abline(h = 0, lty = "dashed", lwd = 1, col = graphics::par("fg"))
  graphics::abline(v = 0, lty = "dashed", lwd = 1, col = graphics::par("fg"))
  if (rows) {
    graphics::points(x = coord_row$x, y = coord_row$y, col = coord_row$col,
                     pch = coord_row$pch, cex = coord_row$cex)
  }
  if (columns) {
    graphics::points(x = coord_col$x, y = coord_col$y, col = coord_col$col,
                     pch = coord_col$pch, cex = coord_col$cex)
  }

  ## Labels
  if (!is.null(labels)) {
    labels <- match.arg(labels, several.ok = TRUE)
    if (any(labels == "rows") | any(labels == "individuals")) {
      viz_labels(coord_row, filter = NULL)
    }
    if (any(labels == "columns") | any(labels == "variables")) {
      viz_labels(coord_col, filter = NULL)
    }
  }

  ## Evaluate post-plot and pre-axis expressions
  panel.last

  ## Construct axis
  if (axes) {
    graphics::axis(side = 1, las = 1)
    graphics::axis(side = 2, las = 1)
  }

  ## Plot frame
  if (frame.plot) {
    graphics::box()
  }

  ## Add annotation
  if (ann) {
    graphics::title(main = main, sub = sub, xlab = xlab, ylab = ylab)
  }

  ## Legend
  coord_row$extra_quali <- paste(coord_row$extra_quali, "ind.", sep = " ")
  coord_col$extra_quali <- paste(coord_col$extra_quali, "var.", sep = " ")
  rbind(coord_row, coord_col)
}

# PRINCIPAL COMPONENTS ANALYSIS
#' @include AllGenerics.R
NULL

#' @export
#' @rdname pca
#' @aliases pca,data.frame-method
setMethod(
  f = "pca",
  signature = c(object = "data.frame"),
  definition = function(object, center = TRUE, scale = TRUE, rank = NULL,
                        sup_row = NULL, sup_col = NULL, sup_quali = NULL,
                        weight_row = NULL, weight_col = NULL, autodetect = FALSE) {
    ## Remove non-numeric variables, if any
    clean <- drop_variable(object, f = is.numeric, negate = TRUE,
                           sup = sup_col, extra = sup_quali,
                           auto = autodetect, what = "qualitative")

    ## Compute PCA
    results <- methods::callGeneric(
      object = clean$data, center = center, scale = scale,
      rank = rank, sup_row = sup_row, sup_col = clean$sup,
      weight_row = weight_row, weight_col = weight_col
    )

    ## Add supplementary quantitative variables
    if (!is.null(clean$extra)) set_extra(results) <- clean$extra

    results
  }
)

#' @export
#' @rdname pca
#' @aliases pca,matrix-method
setMethod(
  f = "pca",
  signature = c(object = "matrix"),
  definition = function(object, center = TRUE, scale = TRUE, rank = NULL,
                        sup_row = NULL, sup_col = NULL,
                        weight_row = NULL, weight_col = NULL) {
    # Fix dimension names
    names_row <- rownames(object)
    names_col <- colnames(object)
    if (is.null(names_row)) names_row <- as.character(seq_len(nrow(object)))
    if (is.null(names_col)) names_col <- as.character(seq_len(ncol(object)))

    # Subset
    is_row_sup <- find_variable(sup_row, nrow(object), names = rownames(object))
    is_col_sup <- find_variable(sup_col, ncol(object), names = colnames(object))
    N <- object[!is_row_sup, !is_col_sup, drop = FALSE]

    ## Check missing values
    arkhe::assert_missing(N)

    ## Check dimensions
    arkhe::assert_filled(N)

    # Dimension of the solution
    ndim <- min(rank, dim(N) - 1)
    i <- nrow(N)
    j <- ncol(N)

    # Weights
    w_row <- if (is.null(weight_row)) rep(1, nrow(N)) else weight_row
    w_col <- if (is.null(weight_col)) rep(1, ncol(N)) else weight_col
    w_row <- w_row / sum(w_row)

    # Build matrix
    s_row <- sqrt(w_row)
    s_col <- sqrt(w_col)
    W_row1 <- matrix(s_row, nrow = i, ncol = j, byrow = FALSE)
    W_col1 <- matrix(s_col, nrow = i, ncol = j, byrow = TRUE)
    W_row2 <- matrix(s_row, nrow = i, ncol = ndim, byrow = FALSE)
    W_col2 <- matrix(s_col, nrow = j, ncol = ndim, byrow = FALSE)

    # Center data
    if (center) {
      var_mean <- weighted_mean(N, w_row)
    } else {
      var_mean <- rep(0, j)
    }
    ctr <- matrix(var_mean, nrow = i, ncol = j, byrow = TRUE)
    P <- N - ctr

    # Scale data
    if (scale) {
      var_sd <- weighted_sd(P, w_row)
    } else {
      var_sd <- rep(1, j)
    }
    std <- matrix(var_sd, nrow = i, ncol = j, byrow = TRUE)
    M <- P / std

    # Matrix of standardized residuals
    S <- M * W_col1 * W_row1

    # Singular Value Decomposition
    D <- svd2(S, ndim)
    sv <- D$d # Singular values

    # Standard coordinates
    U <- D$u / W_row2
    V <- D$v / W_col2

    sv_U <- matrix(sv, nrow = i, ncol = ndim, byrow = TRUE)
    sv_V <- matrix(sv, nrow = j, ncol = ndim, byrow = TRUE)

    # Principal coordinates
    coord_row <- U * sv_U
    coord_col <- V * sv_V

    # Contributions
    contrib_row <- ((coord_row * W_row2) / sv_U)^2 * 100
    contrib_col <- ((coord_col * W_col2) / sv_V)^2 * 100

    # Squared distance to centroide
    dist_row <- rowSums((M * W_col1)^2)
    dist_col <- colSums((M * W_row1)^2)

    # Supplementary points
    if (any(is_row_sup)) {
      extra_row <- object[is_row_sup, !is_col_sup, drop = FALSE]
      ind_sup <- (t(extra_row) - var_mean) * w_col / var_sd

      # Coordinates
      coord_row_sup <- crossprod(ind_sup, V)
      coord_row <- rbind(coord_row, coord_row_sup)

      # Distances
      dist_row_sup <- colSums(ind_sup^2 * w_col)
      dist_row <- c(dist_row, dist_row_sup)
    }
    if (any(is_col_sup)) {
      extra_col <- object[!is_row_sup, is_col_sup, drop = FALSE]
      # Center and scale
      if (center) {
        extra_col <- t(t(extra_col) - weighted_mean(extra_col, w_row))
      }
      if (scale) {
        extra_col <- t(t(extra_col) / weighted_sd(extra_col, w_row))
      }
      var_sup <- extra_col * w_row

      # Coordinates
      coord_col_sup <- crossprod(var_sup, U)
      coord_col <- rbind(coord_col, coord_col_sup)

      # Distances
      dist_col_sup <- colSums(extra_col^2 * w_row)
      dist_col <- c(dist_col, dist_col_sup)
    }

    # Squared cosine
    cos_row <- coord_row^2 / dist_row
    cos_col <- coord_col^2 / dist_col

    # names(sv) <- paste0("F", dim_keep)
    .PCA(
      data = object,
      dimension = as.integer(ndim),
      singular_values = sv,
      rows = build_results(
        names = names_row,
        principal = coord_row,
        standard = U,
        contributions = contrib_row,
        distances = sqrt(dist_row),
        cosine = cos_row,
        weights = w_row,
        supplement = is_row_sup
      ),
      columns = build_results(
        names = names_col,
        principal = coord_col,
        standard = V,
        contributions = contrib_col,
        distances = sqrt(dist_col),
        cosine = cos_col,
        weights = w_col,
        supplement = is_col_sup
      ),
      center = var_mean,
      scale = var_sd
    )
  }
)

# PREDICT
#' @include AllGenerics.R
NULL

# CA ===========================================================================
#' @export
#' @rdname predict
#' @aliases predict,CA-method
setMethod(
  f = "predict",
  signature = c(object = "CA"),
  definition = function(object, newdata, margin = 1) {
    ## Coerce to matrix
    if (missing(newdata)) {
      data <- object@data
      data <- data[!object@rows@supplement, !object@columns@supplement, drop = FALSE]
    } else {
      data <- as.matrix(newdata)
    }

    ## TODO: keep only matching rows/columns

    ## Get standard coordinates
    if (margin == 1) {
      data <- data / rowSums(data)
      std <- object@columns@standard
    }
    if (margin == 2) {
      data <- t(data) / colSums(data)
      std <- object@rows@standard
    }

    ## Compute principal coordinates
    coords <- crossprod(t(data), std)
    coords <- as.data.frame(coords)
    colnames(coords) <- paste0("F", seq_along(coords))
    return(coords)
  }
)

# MCA ==========================================================================
#' @export
#' @rdname predict
#' @aliases predict,MCA-method
setMethod(
  f = "predict",
  signature = c(object = "MCA"),
  definition = function(object, newdata, margin = 1) {
    ## Coerce to matrix
    if (missing(newdata)) {
      data <- object@data
      data <- data[!object@rows@supplement, !object@columns@supplement, drop = FALSE]
    } else {
      ## Complete disjunctive table
      data <- cdt(newdata)
    }

    methods::callNextMethod(object = object, newdata = data, margin = margin)
  }
)

# PCA ==========================================================================
#' @export
#' @rdname predict
#' @aliases predict,PCA-method
setMethod(
  f = "predict",
  signature = c(object = "PCA"),
  definition = function(object, newdata, margin = 1) {
    ## Coerce to matrix
    if (missing(newdata)) {
      data <- object@data
      data <- data[!object@rows@supplement, !object@columns@supplement]
    } else {
      data <- as.matrix(newdata)
    }

    ## Get standard coordinates
    var_mean <- object@center
    var_sd <- object@scale

    if (margin == 1) {
      std <- object@columns@standard
      w <- object@columns@weights

      newdata <- (t(newdata) - var_mean) * w / var_sd
    }
    if (margin == 2) {
      std <- object@rows@standard
      w <- object@rows@weights
      j <- ncol(newdata)

      X <- if (all(var_mean == 0)) rep(0, j) else weighted_mean(newdata, w)
      newdata <- t(t(newdata) - X)
      Y <- if (all(var_sd == 1)) rep(1, j) else weighted_sd(newdata, w)
      newdata <- t(t(newdata) / Y)
      newdata <- newdata * w
    }

    ## Compute principal coordinates
    coords <- crossprod(newdata, std)
    coords <- as.data.frame(coords)
    colnames(coords) <- paste0("F", seq_along(coords))
    return(coords)
  }
)

# PLOT COORDINATES
#' @include AllGenerics.R
NULL

# Internal environment =========================================================
the <- new.env(parent = emptyenv())
the$margin <- 1       # Updated by prepare_plot()
the$axes <- c(1, 2)   # Updated by prepare_plot()
the$principal <- TRUE # Updated by prepare_plot()

get_margin <- function(...) {
  get("margin", envir = the)
}

get_axes <- function(...) {
  get("axes", envir = the)
}

get_principal <- function(...) {
  get("principal", envir = the)
}

# Rows =========================================================================
#' @export
#' @rdname viz_individuals
#' @aliases viz_rows,MultivariateAnalysis-method
setMethod(
  f = "viz_rows",
  signature = c(x = "MultivariateAnalysis"),
  definition = function(x, ..., axes = c(1, 2), active = TRUE, sup = TRUE,
                        labels = FALSE, extra_quali = NULL, extra_quanti = NULL,
                        ellipse = NULL, hull = NULL,
                        color = NULL, fill = FALSE, symbol = FALSE, size = c(1, 6),
                        xlim = NULL, ylim = NULL, main = NULL, sub = NULL,
                        panel.first = NULL, panel.last = NULL,
                        legend = list(x = "topleft")) {
    viz_points(x, margin = 1, axes = axes, ...,
               active = active, sup = sup, labels = labels,
               extra_quali = extra_quali, extra_quanti = extra_quanti,
               color = color, fill = fill, symbol = symbol, size = size,
               xlim = xlim, ylim = ylim, main = main, sub = sub,
               panel.first = panel.first, panel.last = panel.last,
               ellipse = ellipse, hull = hull,
               legend = legend)
    invisible(x)
  }
)

#' @export
#' @rdname viz_individuals
#' @aliases viz_rows,BootstrapCA-method
setMethod(
  f = "viz_rows",
  signature = c(x = "BootstrapCA"),
  definition = function(x, ..., axes = c(1, 2), color = FALSE, fill = FALSE,
                        symbol = FALSE, legend = NULL) {
    viz_points(x, margin = 1, axes = axes, ..., active = TRUE, sup = TRUE,
               labels = FALSE, extra_quali = NULL,
               color = color, fill = fill, symbol = symbol, legend = legend)
    invisible(x)
  }
)

# Individuals ==================================================================
#' @export
#' @rdname viz_individuals
#' @aliases viz_individuals,PCA-method
setMethod(
  f = "viz_individuals",
  signature = c(x = "PCA"),
  definition = function(x, ..., axes = c(1, 2), active = TRUE, sup = TRUE,
                        labels = FALSE, extra_quali = NULL, extra_quanti = NULL,
                        ellipse = NULL, hull = NULL,
                        color = NULL, fill = FALSE, symbol = FALSE, size = c(1, 6),
                        xlim = NULL, ylim = NULL, main = NULL, sub = NULL,
                        panel.first = NULL, panel.last = NULL,
                        legend = list(x = "topleft")) {
    viz_points(x, margin = 1, axes = axes, ...,
               active = active, sup = sup, labels = labels,
               extra_quali = extra_quali, extra_quanti = extra_quanti,
               color = color, fill = fill, symbol = symbol, size = size,
               xlim = xlim, ylim = ylim, main = main, sub = sub,
               panel.first = panel.first, panel.last = panel.last,
               ellipse = ellipse, hull = hull,
               legend = legend)
    invisible(x)
  }
)

# Columns =====================================================================
#' @export
#' @rdname viz_variables
#' @aliases viz_columns,MultivariateAnalysis-method
setMethod(
  f = "viz_columns",
  signature = c(x = "MultivariateAnalysis"),
  definition = function(x, ..., axes = c(1, 2), active = TRUE, sup = TRUE,
                        labels = FALSE, extra_quali = NULL, extra_quanti = NULL,
                        color = NULL, fill = FALSE, symbol = FALSE, size = c(1, 6),
                        xlim = NULL, ylim = NULL, main = NULL, sub = NULL,
                        panel.first = NULL, panel.last = NULL,
                        legend = list(x = "topleft")) {
    viz_points(x, margin = 2, axes = axes, ...,
               active = active, sup = sup, labels = labels,
               extra_quali = extra_quali, extra_quanti = extra_quanti,
               color = color, fill = fill, symbol = symbol, size = size,
               xlim = xlim, ylim = ylim, main = main, sub = sub,
               panel.first = panel.first, panel.last = panel.last,
               legend = legend)
    invisible(x)
  }
)

#' @export
#' @rdname viz_variables
#' @aliases viz_columns,MultivariateBootstrap-method
setMethod(
  f = "viz_columns",
  signature = c(x = "MultivariateBootstrap"),
  definition = function(x, ..., axes = c(1, 2), color = FALSE, fill = FALSE,
                        symbol = FALSE, legend = NULL) {
    viz_points(x, ..., margin = 2, axes = axes, active = TRUE, sup = TRUE,
               labels = FALSE, extra_quali = NULL,
               color = color, fill = fill, symbol = symbol, legend = legend)
    invisible(x)
  }
)

# Variables ====================================================================
#' @export
#' @rdname viz_variables
#' @aliases viz_variables,PCA-method
setMethod(
  f = "viz_variables",
  signature = c(x = "PCA"),
  definition = function(x, ..., axes = c(1, 2), active = TRUE, sup = TRUE,
                        labels = list(filter = "contribution", n = 10),
                        extra_quali = NULL, extra_quanti = NULL,
                        color = NULL, symbol = NULL, size = 1,
                        xlim = NULL, ylim = NULL, main = NULL, sub = NULL,
                        panel.first = NULL, panel.last = NULL,
                        legend = list(x = "topleft")) {
    ## Prepare data
    coord <- prepare_plot(x, margin = 2, axes = axes, ...,
                          active = active, sup = sup,
                          extra_quali = extra_quali, extra_quanti = extra_quanti,
                          color = color, line_type = symbol, line_width = size)

    ## Save and restore graphical parameters
    ## pty: square plotting region, independent of device size
    old_par <- graphics::par(pty = "s", no.readonly = TRUE)
    on.exit(graphics::par(old_par), add = TRUE)

    ## Open new window
    grDevices::dev.hold()
    on.exit(grDevices::dev.flush(), add = TRUE)
    graphics::plot.new()

    ## Set plotting coordinates
    xlim <- xlim %||% range(coord$x, na.rm = TRUE, finite = TRUE)
    if (is_scaled(x)) xlim <- c(-1, 1)
    ylim <- ylim %||% range(coord$y, na.rm = TRUE, finite = TRUE)
    if (is_scaled(x)) ylim <- c(-1, 1)
    graphics::plot.window(xlim = xlim, ylim = ylim, asp = 1)

    ## Evaluate pre-plot expressions
    panel.first

    ## Plot
    graphics::abline(h = 0, lty = "dashed", lwd = 1, col = graphics::par("fg"))
    graphics::abline(v = 0, lty = "dashed", lwd = 1, col = graphics::par("fg"))

    ## Scaled variables?
    if (is_scaled(x)) {
      circle(x = 0, y = 0, radius = 1, lwd = 1,
             border = graphics::par("fg"), n = 100)
    }

    graphics::arrows(
      x0 = 0, y0 = 0, x1 = coord$x, y1 = coord$y, length = 0.15, angle = 30,
      col = coord$col,
      lty = coord$lty,
      lwd = coord$lwd
    )

    ## Labels
    if (isTRUE(labels)) labels <- list()
    if (is.list(labels)) {
      viz_labels(coord, filter = labels$filter, n = labels$n)
    }

    ## Evaluate post-plot and pre-axis expressions
    panel.last

    ## Construct axis (axes)
    if (TRUE) {
      graphics::axis(side = 1, las = 1)
      graphics::axis(side = 2, las = 1)
    }

    ## Plot frame (frame.plot)
    if (TRUE) {
      graphics::box()
    }

    ## Add annotation (ann)
    if (TRUE) {
      graphics::title(
        main = main, sub = sub,
        xlab = print_variance(x, axes[[1]]),
        ylab = print_variance(x, axes[[2]])
      )
    }

    ## Legend
    prepare_legend(coord, legend, points = FALSE, lines = TRUE)

    invisible(x)
  }
)

#' @export
#' @rdname viz_variables
#' @aliases viz_variables,CA-method
setMethod(
  f = "viz_variables",
  signature = c(x = "CA"),
  definition = function(x, ..., axes = c(1, 2), active = TRUE, sup = TRUE,
                        labels = FALSE, extra_quali = NULL, extra_quanti = NULL,
                        color = NULL, fill = FALSE, symbol = FALSE, size = c(1, 6),
                        xlim = NULL, ylim = NULL, main = NULL, sub = NULL,
                        panel.first = NULL, panel.last = NULL,
                        legend = list(x = "topleft")) {
    viz_points(x, margin = 2, axes = axes, ...,
               active = active, sup = sup, labels = labels,
               extra_quali = extra_quali, extra_quanti = extra_quanti,
               color = color, fill = fill, symbol = symbol, size = size,
               xlim = xlim, ylim = ylim, main = main, sub = sub,
               panel.first = panel.first, panel.last = panel.last,
               legend = legend)
  }
)

#' @export
#' @rdname viz_variables
#' @aliases viz_variables,BootstrapPCA-method
setMethod(
  f = "viz_variables",
  signature = c(x = "BootstrapPCA"),
  definition = function(x, ..., axes = c(1, 2), color = FALSE, fill = FALSE,
                        symbol = FALSE, legend = NULL) {
    viz_points(x, ..., margin = 2, axes = axes, active = TRUE, sup = TRUE,
               labels = FALSE, extra_quali = NULL,
               color = color, fill = fill, symbol = symbol, legend = legend)
    invisible(x)
  }
)

# Helpers ======================================================================
#' Build a Factor Map
#'
#' @param x A [`CA-class`], [`MCA-class`] or [`PCA-class`] object.
#' @param labels A [`logical`] scalar: should labels be drawn? Labeling a large
#'  number of points can be computationally expensive and make the graph
#'  difficult to read. A selection of points to label can be provided using a
#'  `list` of two named elements, `filter` (a string specifying how to filter
#'  the labels to be drawn) and `n` (an integer specifying the number of labels
#'  to be drawn). See examples below.
#' @param xlim A length-two [`numeric`] vector giving the x limits of the plot.
#'  The default value, `NULL`, indicates that the range of the
#'  [finite][is.finite()] values to be plotted should be used.
#' @param ylim A length-two [`numeric`] vector giving the y limits of the plot.
#'  The default value, `NULL`, indicates that the range of the
#'  [finite][is.finite()] values to be plotted should be used.
#' @param main A [`character`] string giving a main title for the plot.
#' @param sub A [`character`] string giving a subtitle for the plot.
#' @param xlab,ylab A [`character`] vector giving the x and y axis labels.
#' @param ann A [`logical`] scalar: should the default annotation (title and x
#'  and y axis labels) appear on the plot?
#' @param frame.plot A [`logical`] scalar: should a box be drawn around the
#'  plot?
#' @param panel.first An `expression` to be evaluated after the plot axes are
#'  set up but before any plotting takes place. This can be useful for drawing
#'  background grids.
#' @param panel.last An `expression` to be evaluated after plotting has taken
#'  place but before the axes, title and box are added.
#' @param ellipse A [`list`] of additional arguments to be passed to
#'  [viz_ellipses()]; names of the list are used as argument names.
#'  If `NULL`, no ellipse are displayed.
#' @param hull A [`logical`] scalar: should convex hulls be displayed?
#' @param legend A [`list`] of additional arguments to be passed to
#'  [graphics::legend()]; names of the list are used as argument names.
#'  If `NULL`, no legend is displayed.
#' @param ... Currently not used.
#' @inheritParams prepare_plot
#' @author N. Frerebeau
#' @keywords internal
viz_points <- function(x, margin, axes, ...,
                       active = TRUE, sup = TRUE,
                       labels = list(filter = "contribution", n = 10),
                       extra_quali = NULL, extra_quanti = NULL,
                       color = NULL, fill = FALSE,
                       symbol = NULL, size = c(1, 6),
                       xlim = NULL, ylim = NULL,
                       main = NULL, sub = NULL, xlab = NULL, ylab = NULL,
                       ann = graphics::par("ann"), frame.plot = TRUE,
                       panel.first = NULL, panel.last = NULL,
                       ellipse = NULL, hull = FALSE,
                       legend = list(x = "topleft")) {
  ## Prepare data
  coord <- prepare_plot(x, margin = margin, axes = axes,
                        active = active, sup = sup,
                        extra_quali = extra_quali,
                        extra_quanti = extra_quanti,
                        color = color, fill = fill,
                        symbol = symbol, size = size, ...)

  ## Save and restore graphical parameters
  ## pty: square plotting region, independent of device size
  old_par <- graphics::par(pty = "s", no.readonly = TRUE)
  on.exit(graphics::par(old_par), add = TRUE)

  ## Open new window
  grDevices::dev.hold()
  on.exit(grDevices::dev.flush(), add = TRUE)
  graphics::plot.new()

  ## Set plotting coordinates
  xlim <- xlim %||% range(coord$x, na.rm = TRUE, finite = TRUE)
  ylim <- ylim %||% range(coord$y, na.rm = TRUE, finite = TRUE)
  graphics::plot.window(xlim = xlim, ylim = ylim, asp = 1)

  ## Evaluate pre-plot expressions
  panel.first

  ## Plot
  graphics::abline(h = 0, lty = "dashed", lwd = 1, col = graphics::par("fg"))
  graphics::abline(v = 0, lty = "dashed", lwd = 1, col = graphics::par("fg"))
  graphics::points(
    x = coord$x,
    y = coord$y,
    col = coord$col,
    bg = coord$bg,
    pch = coord$pch,
    cex = coord$cex
  )

  ## Labels
  if (isTRUE(labels)) labels <- list()
  if (is.list(labels)) {
    viz_labels(coord, filter = labels$filter, n = labels$n)
  }

  ## Evaluate post-plot and pre-axis expressions
  panel.last

  ## Construct axis (axes)
  if (TRUE) {
    graphics::axis(side = 1, las = 1)
    graphics::axis(side = 2, las = 1)
  }

  ## Plot frame
  if (frame.plot) {
    graphics::box()
  }

  ## Add annotation
  if (ann) {
    graphics::title(
      main = main, sub = sub,
      xlab = xlab %||% print_variance(x, axes[[1]]),
      ylab = ylab %||% print_variance(x, axes[[2]])
    )
  }

  group <- coord$extra_quali
  if (all(is.na(group))) group[] <- ""

  ## Add ellipse
  if (is.list(ellipse) && length(ellipse) > 0) {
    args_ell <- list(x = x, group = group,
                     color = color, fill = FALSE, symbol = FALSE)
    ellipse <- modifyList(args_ell, val = ellipse)
    do.call(viz_ellipses, ellipse)
  }

  ## Add convex hull
  if (isTRUE(hull)) {
    args_hull <- list(x = x, group = group,
                      color = color, fill = FALSE, symbol = FALSE)
    do.call(viz_hull, args_hull)
  }

  ## Legend
  prepare_legend(coord, legend, points = TRUE, lines = FALSE)

  invisible(coord)
}

#' Non-Overlapping Text Labels
#'
#' @param x A [`data.frame`] (typically returned by [prepare_plot()]).
#' @param filter A [`character`] string specifying the variable used to filter
#'  observations. If `NULL`, all labels are drawn.
#' @param n An [`integer`] specifying the number of labels to draw.
#'  Only the labels of the top \eqn{n} observations according to `filter` will
#'  be drawn. If `NULL`, all labels are drawn.
#' @param type A [`character`] string specifying the shape of the field.
#'  It must be one of "`text`", "`shadow`" or "`box`". Any unambiguous substring
#'  can be given.
#' @param ... Currently not used.
#' @details
#'  Only labels in the plotting region (given by `par("usr")`) will be drawn.
#' @author N. Frerebeau
#' @keywords internal
viz_labels <- function(x, filter = "contribution", n = 10,
                       type = "shadow", ...) {
  ## Select
  if (!is.null(filter) && !is.null(n) && n > 0) {
    top <- min(nrow(x), n)
    how <- x[[filter]]
    k <- order(how, decreasing = TRUE)[seq_len(top)] # Get order
    x <- x[k, , drop = FALSE] # Subset
  }

  ## Filter
  xlim <- graphics::par("usr")[c(1, 2)]
  ylim <- graphics::par("usr")[c(3, 4)]
  x_filter <- x$x >= min(xlim) & x$x <= max(xlim)
  y_filter <- x$y >= min(ylim) & x$y <= max(ylim)
  xy_filter <- which(x_filter & y_filter)
  x <- x[xy_filter, , drop = FALSE]

  label(
    x = x$x,
    y = x$y,
    labels = x$label,
    type = type,
    col = x$col,
    # cex = x$cex,
    xpd = TRUE
  )
}

#' Prepare Data for Plotting
#'
#' @param x A [`MultivariateAnalysis-class`] object.
#' @param margin A length-one [`numeric`] vector giving the subscript
#'  which the data will be returned: `1` indicates individuals/rows (the
#'  default), `2` indicates variables/columns.
#' @param axes A length-two [`numeric`] vector giving the dimensions to be
#'  plotted.
#' @param active A [`logical`] scalar: should the active observations be
#'  plotted?
#' @param sup A [`logical`] scalar: should the supplementary observations be
#'  plotted?
#' @param principal A [`logical`] scalar: should principal coordinates be
#'  returned? If `FALSE`, standard coordinates are returned.
#' @param extra_quali An optional vector of qualitative data for aesthetics
#'  mapping.
#' @param extra_quanti An optional vector of quantitative data for aesthetics
#'  mapping. If a single [`character`] string is passed, it must be one of
#'  "`observation`", "`mass`", "`sum`", "`contribution`" or "`cos2`"
#'  (see [`augment()`]).
#' @param color The colors for lines and points (will be mapped to
#'  `extra_quanti` or `extra_quali`; if both are set, the latter has priority).
#'  Ignored if set to `FALSE`. If `NULL`, the default color scheme will be used.
#' @param fill The background colors for points (will be mapped to
#'  `extra_quanti` or `extra_quali`; if both are set, the latter has priority).
#'  Ignored if set to `FALSE`.
#' @param symbol A vector of plotting characters or symbols (will be mapped to
#'  `extra_quali`). This can either be a single character or an integer code for
#'  one of a set of graphics symbols. If `symbol` is a named a named vector,
#'  then the symbols will be associated with their name within `extra_quali`.
#'  Ignored if set to `FALSE`.
#' @param size A length-two [`numeric`] vector giving range of possible sizes
#'  (greater than 0; will be mapped to `extra_quanti`).
#'  Ignored if set to `FALSE`.
#' @param line_type A specification for the line type (will be mapped to
#'  `extra_quali`). If `line_type` is a named a named vector, then the line
#'  types will be associated with their name within `extra_quali`.
#'  Ignored if set to `FALSE`.
#' @param line_width A specification for the line type and width (will
#'  be mapped to `extra_quanti`).
#'  Ignored if set to `FALSE`.
#' @param ... Further [graphical parameters][graphics::par].
#' @return
#'  A [`data.frame`] with the following columns:
#'    \describe{
#'     \item{`x`}{Coordinates along x.}
#'     \item{`y`}{Coordinates along y.}
#'     \item{`extra_quali`}{Extra qualitative variable to be highlighted.}
#'     \item{`extra_quanti`}{Extra quantitative variable to be highlighted.}
#'     \item{`label`}{Label.}
#'     \item{`sup`}{Is supplementary?}
#'     \item{`col`}{Color for lines and symbols.}
#'     \item{`bg`}{Background color for symbols.}
#'     \item{`pch`}{Symbols.}
#'     \item{`cex`}{Symbol sizes.}
#'     \item{`lty`}{Line types.}
#'     \item{`lwd`}{Line widths.}
#'    }
#' @author N. Frerebeau
#' @keywords internal
prepare_plot <- function(x, margin, ..., axes = c(1, 2), active = TRUE,
                         sup = TRUE, principal = TRUE,
                         extra_quali = NULL, extra_quanti = NULL,
                         color = NULL, fill = FALSE,
                         symbol = NULL, size = c(1, 6),
                         line_type = NULL, line_width = size) {
  ## Validation
  arkhe::assert_scalar(margin, "numeric")
  arkhe::assert_type(axes, "numeric")
  arkhe::assert_length(axes, 2)
  arkhe::assert_scalar(sup, "logical")
  arkhe::assert_scalar(principal, "logical")

  ## Set margin and axes
  assign("margin", value = margin, envir = the)
  assign("axes", value = axes, envir = the)
  assign("principal", value = principal, envir = the)

  ## Prepare data
  data <- augment(x, margin = margin, axes = axes, principal = principal)
  n <- nrow(data)

  ## Recode
  data$observation <- ifelse(data$supplementary, "suppl.", "active")

  ## Set graphical parameters
  ## (recycle if of length one)
  dots <- list(...)
  col <- recycle(dots$col %||% graphics::par("col"), n)
  bg <- recycle(dots$bg %||% graphics::par("bg"), n)
  pch <- recycle(dots$pch %||% 16, n)
  cex <- recycle(dots$cex %||% graphics::par("cex"), n)
  lty <- recycle(dots$lty %||% graphics::par("lty"), n)
  lwd <- recycle(dots$lwd %||% graphics::par("lwd"), n)

  ## Highlight quantitative information
  if (length(extra_quanti) == 1) {
    extra <- get_extra(x)[[extra_quanti]]
    if (length(extra) > 1) {
      extra_quanti <- extra
    } else {
      choices <- c("mass", "sum", "contribution", "cos2")
      extra_quanti <- match.arg(extra_quanti, choices = choices, several.ok = FALSE)
      extra_quanti <- data[[extra_quanti]]
    }
  }
  if (length(extra_quanti) > 0) {
    extra_quanti <- as.vector(extra_quanti)
    arkhe::assert_type(extra_quanti, "numeric")
    arkhe::assert_length(extra_quanti, n)
    ## Continuous scales
    ## (ignored if col, bg, cex and lwd are set by user)
    if (is.null(dots$col) && !isFALSE(color))
      col <- khroma::palette_color_continuous(colors = color)(extra_quanti)
    if (is.null(dots$bg) && !isFALSE(fill))
      bg <- khroma::palette_color_continuous(colors = fill)(extra_quanti)
    if (is.null(dots$cex) && !isFALSE(size))
      cex <- khroma::palette_size_sequential(range = size)(extra_quanti)
    if (is.null(dots$lwd) && !isFALSE(line_width))
      lwd <- khroma::palette_size_sequential(range = line_width)(extra_quanti)
  } else {
    extra_quanti <- rep(NA_real_, n)
  }

  ## Highlight qualitative information
  if (is.null(extra_quali) && has_groups(x, margin = margin)) {
    extra_quali <- get_groups(x, margin = margin)
  }
  if (is.character(extra_quali) && length(extra_quali) == 1) {
    extra <- get_extra(x)[[extra_quali]]
    if (length(extra) > 1) {
      extra_quali <- extra
    } else {
      choices <- c("observation")
      extra_quali <- match.arg(extra_quali, choices = choices, several.ok = FALSE)
      extra_quali <- data[[extra_quali]]
    }
  }
  if (!isFALSE(extra_quali) && length(extra_quali) > 0) {
    extra_quali <- as.vector(extra_quali)
    arkhe::assert_length(extra_quali, n)
    ## Discrete scales
    ## (ignored if col, bg, pch and lty are set by user)
    if (is.null(dots$col) && !isFALSE(color))
      col <- khroma::palette_color_discrete(colors = color)(extra_quali)
    if (is.null(dots$bg) && !isFALSE(fill))
      bg <- khroma::palette_color_discrete(colors = fill)(extra_quali)
    if (is.null(dots$pch) && !isFALSE(symbol))
      pch <- khroma::palette_shape(symbols = symbol)(extra_quali)
    if (is.null(dots$lty) && !isFALSE(line_type))
      lty <- khroma::palette_line(types = line_type)(extra_quali)
  } else {
    extra_quali <- rep(NA_character_, n)
  }

  coord <- data.frame(
    data,
    x = data[[1L]],
    y = data[[2L]],
    extra_quali = extra_quali,
    extra_quanti = extra_quanti,
    label = data$label,
    col = col,
    bg = bg,
    pch = pch,
    cex = cex,
    lty = lty,
    lwd = lwd
  )

  ## Subset
  if (active & !sup) coord <- coord[!coord$supplementary, , drop = FALSE]
  if (!active & sup) coord <- coord[coord$supplementary, , drop = FALSE]

  coord
}

#' Build a Legend
#'
#' @param x A [`data.frame`] returned by [prepare_plot()].
#' @param args A [`list`] of additional arguments to be passed to
#'  [graphics::legend()]; names of the list are used as argument names.
#'  If `NULL` or empty, no legend is displayed.
#' @param points A [`logical`] scalar: legend for points?
#' @param lines A [`logical`] scalar: legend for lines?
#' @author N. Frerebeau
#' @keywords internal
prepare_legend <- function(x, args, points = TRUE, lines = TRUE) {
  quanti <- x$extra_quanti
  quali <- x$extra_quali

  if (!is.list(args) || length(args) == 0) return(NULL)
  if (all(is.na(quanti)) && all(is.na(quali))) return(NULL)

  ## Continuous scale
  if (!all(is.na(quanti))) {
    quanti <- quanti[!is.na(quanti)]
    # im <- grDevices::as.raster(x$col)

    pr <- pretty(quanti, n = ifelse(nrow(x) > 5, 5, nrow(x)))
    pr <- pr[pr <= max(quanti) & pr >= min(quanti)]
    i <- order(quanti, method = "radix")
    i <- setdiff(i, which(duplicated(quanti)))

    col <- grDevices::colorRamp(x$col[i])(scale_range(pr, from = range(quanti)))
    col <- grDevices::rgb(col, maxColorValue = 255)

    leg <- list(legend = pr, col = col)
    if (points) {
      k <- duplicated(quanti)
      cex <- stats::approx(x = quanti[i], y = x$cex[i], xout = pr, ties = "ordered")$y
      leg <- utils::modifyList(leg, list(pch = unique(x$pch), pt.cex = cex))
    }
    if (lines) {
      lwd <- stats::approx(x = quanti[i], y = x$lwd[i], xout = pr, ties = "ordered")$y
      leg <- utils::modifyList(leg, list(lty = unique(x$lty), lwd = lwd))
    }
  }
  ## Discrete scale
  if (!all(is.na(quali))) {
    param <- stats::aggregate(
      x[, c("col", "bg", "pch", "lty")],
      by = list(leg = quali),
      FUN = unique
    )
    leg <- list(legend = param$leg, col = param$col)
    if (points) {
      leg <- utils::modifyList(leg, list(pt.bg = param$bg, pch = param$pch))
    }
    if (lines) {
      leg <- utils::modifyList(leg, list(lty = param$lty))
    }
  }

  leg <- utils::modifyList(leg, args)
  do.call(graphics::legend, args = leg)
}

# SCREEPLOT
#' @include AllGenerics.R
NULL

# Screeplot ====================================================================
#' @export
#' @method screeplot MultivariateAnalysis
screeplot.MultivariateAnalysis <- function(x, ..., eigenvalues = FALSE, cumulative = FALSE,
                                           labels = TRUE, limit = 10,
                                           col = "grey90", border = "grey10",
                                           col.cumulative = "red", lty.cumulative = "solid",
                                           lwd.cumulative = 2) {
  ## TODO
  horiz <- FALSE

  ## Save and restore graphical parameters
  old_par <- graphics::par(mar = c(5, 4, 4, 2 + 2 * cumulative) + 0.1,
                           no.readonly = TRUE)
  on.exit(graphics::par(old_par), add = TRUE)

  ## Prepare data
  data <- get_eigenvalues(x)
  data$x <- seq_len(nrow(data))
  data$z <- data[[3L]]

  ## Subset
  if (!is.null(limit)) {
    limit <- min(nrow(data), limit)
    data <- data[seq_len(limit), , drop = FALSE]
  }

  if (eigenvalues) {
    data$y <- data[[1L]]
    data$labels <- round(data$y, digits = 1)
    ylab <- tr_("Eigenvalues")
  } else {
    data$y <- data[[2L]]
    data$labels <- paste0(round(data$y, digits = 1), "%")
    if (methods::is(x, "CA")) {
      ylab <- tr_("Proportion of inertia (%)")
    } else {
      ylab <- tr_("Explained variance (%)")
    }
  }

  k <- max(data$y) / max(data$z)
  data$k <- data$z * k

  ## Bar plot
  mid <- graphics::barplot(
    height = data$y,
    names.arg = data$x,
    horiz = horiz,
    xlab = if (horiz) ylab else NULL,
    ylab = if (horiz) NULL else ylab,
    ylim = c(0, max(data$k)) * 1.05,
    col = col,
    border = border,
    las = 1,
    ...
  )

  if (labels) {
    graphics::text(
      x = mid,
      y = data$y,
      labels = data$labels,
      pos = 3
    )
  }

  if (cumulative && !horiz) {
    if (methods::is(x, "CA")) {
      ylab2 <- tr_("Cumulative inertia (%)")
    } else {
      ylab2 <- tr_("Cumulative variance (%)")
    }
    tick_labels <- seq(from = 0, to = 100, by = 20)
    tick_at <- tick_labels * k
    graphics::lines(
      x = mid,
      y = data$k,
      type = "b",
      pch = 16,
      lty = lty.cumulative,
      lwd = lwd.cumulative,
      col = col.cumulative
    )
    graphics::axis(side = 4, at = tick_at, labels = tick_labels,
                   col = col.cumulative, col.ticks = col.cumulative,
                   col.axis = col.cumulative, las = 1)
    graphics::mtext(
      text = ylab2,
      side = 4, line = 3, col = col.cumulative
    )
  }

  invisible(x)
}

#' @export
#' @rdname screeplot
#' @aliases screeplot,MultivariateAnalysis-method
setMethod("screeplot", c(x = "MultivariateAnalysis"), screeplot.MultivariateAnalysis)

#' @export
#' @method screeplot PCOA
screeplot.PCOA <- function(x, ..., labels = FALSE, limit = NULL,
                           col = "grey90", border = "grey10") {
  ## TODO
  horiz <- FALSE

  ## Prepare data
  data <- get_eigenvalues(x)
  data$x <- seq_len(nrow(data))
  data$y <- data[[1L]]
  data$labels <- round(data$y, digits = 1)

  ## Subset
  if (!is.null(limit)) {
    limit <- min(nrow(data), limit)
    data <- data[seq_len(limit), , drop = FALSE]
  }

  ## Bar plot
  ylab <- tr_("Eigenvalues")
  mid <- graphics::barplot(
    height = data$y,
    names.arg = data$x,
    horiz = horiz,
    xlab = if (horiz) ylab else NULL,
    ylab = if (horiz) NULL else ylab,
    ylim = c(0, max(data$y)) * 1.05,
    col = col,
    border = border,
    las = 1,
    ...
  )

  if (labels) {
    graphics::text(
      x = mid,
      y = data$y,
      labels = data$labels,
      pos = 3
    )
  }

  invisible(x)
}

#' @export
#' @rdname screeplot
#' @aliases screeplot,PCOA-method
setMethod("screeplot", c(x = "PCOA"), screeplot.PCOA)

# CORRESPONDENCE ANALYSIS
#' @include AllGenerics.R
NULL

#' @export
#' @rdname ca
#' @aliases ca,data.frame-method
setMethod(
  f = "ca",
  signature = c(object = "data.frame"),
  definition = function(object, rank = NULL, sup_row = NULL, sup_col = NULL,
                        sup_quali = NULL, autodetect = FALSE) {
    ## Remove non-numeric variables, if any
    clean <- drop_variable(object, f = is.numeric, negate = TRUE,
                           sup = sup_col, extra = sup_quali,
                           auto = autodetect, what = "qualitative")
    ## Compute PCA
    results <- methods::callGeneric(
      object = clean$data, rank = rank,
      sup_row = sup_row, sup_col = clean$sup
    )

    ## Add supplementary quantitative variables
    if (!is.null(clean$extra)) set_extra(results) <- clean$extra

    results
  }
)

#' @export
#' @rdname ca
#' @aliases ca,matrix-method
setMethod(
  f = "ca",
  signature = c(object = "matrix"),
  definition = function(object, rank = NULL, sup_row = NULL, sup_col = NULL) {
    ## Fix dimension names
    names_row <- rownames(object)
    names_col <- colnames(object)
    if (is.null(names_row)) names_row <- as.character(seq_len(nrow(object)))
    if (is.null(names_col)) names_col <- as.character(seq_len(ncol(object)))

    ## Subset
    is_row_sup <- find_variable(sup_row, nrow(object), names = rownames(object))
    is_col_sup <- find_variable(sup_col, ncol(object), names = colnames(object))
    N <- object[!is_row_sup, !is_col_sup, drop = FALSE]

    ## Check missing values
    arkhe::assert_missing(N)

    ## Check dimensions
    arkhe::assert_filled(N)

    ## Dimension of the solution
    ndim <- min(rank, dim(N) - 1)
    i <- nrow(N)
    j <- ncol(N)

    ## Grand total
    total <- sum(N, na.rm = FALSE)
    ## Relative frequencies
    P <- N / total

    ## Calcul des marges
    w_row <- rowSums(P, na.rm = FALSE)
    w_col <- colSums(P, na.rm = FALSE)

    ## /!\ Important: we need to clean the data before processing
    ## Empty rows/columns must be removed to avoid error in svd()
    if (any(w_row == 0))
      stop(tr_("Empty rows detected."), call. = FALSE)
    if (any(w_col == 0))
      stop(tr_("Empty columns detected."), call. = FALSE)

    ## Build matrix
    ## matrix * vector is faster (!) than:
    # matrix %*% t(vector)
    # t(t(matrix) * vector)
    s_row <- sqrt(w_row)
    s_col <- sqrt(w_col)
    W_row1 <- matrix(s_row, nrow = i, ncol = j, byrow = FALSE)
    W_col1 <- matrix(s_col, nrow = i, ncol = j, byrow = TRUE)
    W_row2 <- matrix(s_row, nrow = i, ncol = ndim, byrow = FALSE)
    W_col2 <- matrix(s_col, nrow = j, ncol = ndim, byrow = FALSE)

    ## Calcul des écarts à l'indépendance
    M <- P - tcrossprod(w_row, w_col)

    ## Matrix of standardized residuals
    S <- M / W_row1 / W_col1

    ## Singular Value Decomposition
    D <- svd2(S, ndim)
    sv <- D$d # Singular values

    ## Standard coordinates
    U <- D$u / W_row2
    V <- D$v / W_col2

    sv_U <- matrix(sv, nrow = i, ncol = ndim, byrow = TRUE)
    sv_V <- matrix(sv, nrow = j, ncol = ndim, byrow = TRUE)

    ## Principal coordinates
    coord_row <- U * sv_U
    coord_col <- V * sv_V

    ## Contributions
    contrib_row <- ((coord_row * W_row2) / sv_U)^2 * 100
    contrib_col <- ((coord_col * W_col2) / sv_V)^2 * 100

    ## Squared distance to centroide
    dist_row <- rowSums(S^2) / w_row
    dist_col <- colSums(S^2) / w_col

    ## Supplementary points
    if (any(is_row_sup)) {
      extra_row <- object[is_row_sup, !is_col_sup, drop = FALSE]
      row_sup <- t(extra_row / rowSums(extra_row))

      ## Coordinates
      coord_row_sup <- crossprod(row_sup, V)
      coord_row <- rbind(coord_row, coord_row_sup)

      ## Distances
      dist_row_sup <- colSums((row_sup - w_col)^2 / w_col)
      dist_row <- c(dist_row, dist_row_sup)
    }
    if (any(is_col_sup)) {
      extra_col <- object[!is_row_sup, is_col_sup, drop = FALSE]
      col_sup <- t(t(extra_col) / colSums(extra_col))

      ## Coordinates
      coord_col_sup <- crossprod(col_sup, U)
      coord_col <- rbind(coord_col, coord_col_sup)

      ## Distances
      dist_col_sup <- colSums((col_sup - w_row)^2 / w_row)
      dist_col <- c(dist_col, dist_col_sup)
    }

    ## Squared cosine
    cos_row <- coord_row^2 / dist_row
    cos_col <- coord_col^2 / dist_col

    .CA(
      data = object,
      dimension = as.integer(ndim),
      singular_values = sv,
      rows = build_results(
        names = names_row,
        principal = coord_row,
        standard = U,
        contributions = contrib_row,
        distances = dist_row,
        cosine = cos_row,
        weights = w_row,
        supplement = is_row_sup
      ),
      columns = build_results(
        names = names_col,
        principal = coord_col,
        standard = V,
        contributions = contrib_col,
        distances = dist_col,
        cosine = cos_col,
        weights = w_col,
        supplement = is_col_sup
      )
    )
  }
)

# SVD
#' @include AllGenerics.R
NULL

#' Singular Value Decomposition of a Matrix
#'
#' @param x A \eqn{m \times p}{m x p} numeric [`matrix`].
#' @param rank An [`integer`] value specifying the maximal number of components
#'  to be kept in the results.
#' @return
#'  A [`list`] with the following elements:
#'  \describe{
#'   \item{`d`}{A vector containing the singular values of `x`, of length
#'   `rank`, sorted decreasingly.}
#'   \item{`u`}{A matrix whose columns contain the left singular vectors of
#'   `x`. Dimension `c(m, rank)`.}
#'   \item{`v`}{A matrix whose columns contain the right singular vectors of
#'   `x`. Dimension `c(p, rank)`.}
#'  }
#' @note
#'  In both PCA and PCA-cor whitening there is a sign-ambiguity in the
#'  eigenvector matrices. In order to resolve the sign-ambiguity we use
#'  eigenvector matrices with a positive diagonal. This has the effect to make
#'  cross-correlations and cross-correlations positive diagonal for PCA.
#' @keywords internal
svd2 <- function(x, rank = Inf) {
  D <- svd(x, nu = rank, nv = rank)

  keep <- seq_len(rank)
  sv <- D$d[keep]

  U <- D$u
  V <- D$v

  # Fix sign for consistency with FactoMineR
  if (rank > 1) {
    mult <- sign(as.vector(crossprod(rep(1, nrow(V)), as.matrix(V))))
    mult[mult == 0] <- 1

    # Build matrix
    # matrix * vector is faster (!) than:
    # matrix %*% t(vector)
    # t(t(matrix) * vector)
    mult_U <- matrix(mult, nrow = nrow(U), ncol = rank, byrow = TRUE)
    mult_V <- matrix(mult, nrow = nrow(V), ncol = rank, byrow = TRUE)

    U <- U * mult_U
    V <- V * mult_V
  }

  names(sv) <- paste0("F", keep)
  list(
    d = sv,
    u = U,
    v = V
  )
}

# PLOT ELLIPSE
#' @include AllGenerics.R
NULL

#' @export
#' @rdname viz_ellipses
#' @aliases viz_ellipses,numeric,numeric-method
setMethod(
  f = "viz_ellipses",
  signature = c(x = "numeric", y = "numeric"),
  definition = function(x, y, ..., group = NULL,
                        type = c("tolerance", "confidence"), level = 0.95,
                        color = NULL, fill = FALSE, symbol = FALSE) {
    type <- match.arg(type, several.ok = FALSE)
    fun <- switch(
      type,
      tolerance = wrap_tolerance,
      confidence = wrap_confidence
    )
    ell <- fun(x, y, group = group, level = level)
    .viz_ellipses(ell, color = color, fill = fill, symbol = symbol, ...)

    invisible(list(x = x, y = y))
  }
)

#' @export
#' @rdname viz_ellipses
#' @aliases viz_ellipses,MultivariateAnalysis,missing-method
setMethod(
  f = "viz_ellipses",
  signature = c(x = "MultivariateAnalysis", y = "missing"),
  definition = function(x, ..., group = NULL,
                        type = c("tolerance", "confidence"), level = 0.95,
                        color = NULL, fill = FALSE, symbol = FALSE) {
    type <- match.arg(type, several.ok = FALSE)
    fun <- switch(
      type,
      tolerance = wrap_tolerance,
      confidence = wrap_confidence
    )
    ell <- fun(x, margin = get_margin(), axes = get_axes(),
               group = group, level = level, principal = get_principal())
    .viz_ellipses(ell, color = color, fill = fill, symbol = symbol, ...)

    invisible(x)
  }
)

#' @export
#' @rdname viz_ellipses
#' @aliases viz_ellipses,PCOA,missing-method
setMethod(
  f = "viz_ellipses",
  signature = c(x = "PCOA", y = "missing"),
  definition = function(x, ..., group = NULL,
                        type = c("tolerance", "confidence"), level = 0.95,
                        color = NULL, fill = FALSE, symbol = FALSE) {
    type <- match.arg(type, several.ok = FALSE)
    fun <- switch(
      type,
      tolerance = wrap_tolerance,
      confidence = wrap_confidence
    )
    ell <- fun(x, axes = get_axes(), group = group, level = level)
    .viz_ellipses(ell, color = color, fill = fill, symbol = symbol, ...)

    invisible(x)
  }
)


#' @param x A `list` of `matrix` returned by [wrap_ellipse()].
#' @noRd
.viz_ellipses <- function(x, ..., color = NULL, fill = FALSE, symbol = FALSE) {
  n <- length(x)

  ## Recycle graphical parameters if of length one
  dots <- list(...)
  col <- recycle(dots$border %||% graphics::par("fg"), n)
  bg <- recycle(dots$col %||% NA, n)
  lty <- recycle(dots$lty %||% graphics::par("lty"), n)
  lwd <- recycle(dots$lwd %||% graphics::par("lwd"), n)

  if (n > 1) {
    ## Discrete scales
    extra_quali <- names(x)
    if (is.null(dots$border) && !isFALSE(color))
      col <- khroma::palette_color_discrete(colors = color)(extra_quali)
    if (is.null(dots$col) && !isFALSE(fill))
      bg <- khroma::palette_color_discrete(colors = fill)(extra_quali)
    if (is.null(dots$lty) && !isFALSE(symbol))
      lty <- khroma::palette_line(types = symbol)(extra_quali)
  }

  for (i in seq_along(x)) {
    lvl <- x[[i]]
    for (j in seq_along(lvl)) {
      graphics::polygon(
        x = lvl[[j]],
        border = col[i],
        col = bg[i],
        lty = lty[i],
        lwd = lwd[i]
      )
    }
  }

  invisible(x)
}

# Tolerance ====================================================================
#' @export
#' @rdname viz_tolerance
#' @aliases viz_tolerance,numeric,numeric-method
setMethod(
  f = "viz_tolerance",
  signature = c(x = "numeric", y = "numeric"),
  definition = function(x, y, ..., group = NULL, level = 0.95,
                        color = NULL, fill = FALSE, symbol = FALSE) {
    viz_ellipses(x, y, group = group, type = "tolerance", level = level,
                 color = color, fill = fill, symbol = symbol, ...)
    invisible(list(x = x, y = y))
  }
)

#' @export
#' @rdname viz_tolerance
#' @aliases viz_tolerance,MultivariateAnalysis,missing-method
setMethod(
  f = "viz_tolerance",
  signature = c(x = "MultivariateAnalysis", y = "missing"),
  definition = function(x, ..., group = NULL, level = 0.95,
                        color = NULL, fill = FALSE, symbol = FALSE) {
    viz_ellipses(x, group = group, type = "tolerance", level = level,
                 color = color, fill = fill, symbol = symbol, ...)
    invisible(x)
  }
)

#' @export
#' @rdname viz_tolerance
#' @aliases viz_tolerance,MultivariateBootstrap,missing-method
setMethod(
  f = "viz_tolerance",
  signature = c(x = "MultivariateBootstrap", y = "missing"),
  definition = function(x, ..., level = 0.95,
                        color = FALSE, fill = FALSE, symbol = FALSE) {
    viz_ellipses(x, group = NULL, type = "tolerance", level = level,
                 color = color, fill = fill, symbol = symbol, ...)
    invisible(x)
  }
)

#' @export
#' @rdname viz_tolerance
#' @aliases viz_tolerance,PCOA,missing-method
setMethod(
  f = "viz_tolerance",
  signature = c(x = "PCOA", y = "missing"),
  definition = function(x, ..., group = NULL, level = 0.95,
                        color = NULL, fill = FALSE, symbol = FALSE) {
    viz_ellipses(x, group = group, type = "tolerance", level = level,
                 color = color, fill = fill, symbol = symbol, ...)
    invisible(x)
  }
)

# Confidence ===================================================================
#' @export
#' @rdname viz_confidence
#' @aliases viz_confidence,numeric,numeric-method
setMethod(
  f = "viz_confidence",
  signature = c(x = "numeric", y = "numeric"),
  definition = function(x, y, ..., group = NULL, level = 0.95,
                        color = NULL, fill = FALSE, symbol = FALSE) {
    viz_ellipses(x, y, group = group, type = "confidence", level = level,
                 color = color, fill = fill, symbol = symbol, ...)
    invisible(list(x = x, y = y))
  }
)

#' @export
#' @rdname viz_confidence
#' @aliases viz_confidence,MultivariateAnalysis,missing-method
setMethod(
  f = "viz_confidence",
  signature = c(x = "MultivariateAnalysis", y = "missing"),
  definition = function(x, ..., group = NULL, level = 0.95,
                        color = NULL, fill = FALSE, symbol = FALSE) {
    viz_ellipses(x, group = group, type = "confidence", level = level,
                 color = color, fill = fill, symbol = symbol, ...)
    invisible(x)
  }
)

#' @export
#' @rdname viz_confidence
#' @aliases viz_confidence,MultivariateBootstrap,missing-method
setMethod(
  f = "viz_confidence",
  signature = c(x = "MultivariateBootstrap", y = "missing"),
  definition = function(x, ..., level = 0.95,
                        color = FALSE, fill = FALSE, symbol = FALSE) {
    viz_ellipses(x, group = NULL, type = "confidence", level = level,
                 color = color, fill = fill, symbol = symbol, ...)
    invisible(x)
  }
)

#' @export
#' @rdname viz_confidence
#' @aliases viz_confidence,PCOA,missing-method
setMethod(
  f = "viz_confidence",
  signature = c(x = "PCOA", y = "missing"),
  definition = function(x, ..., axes = c(1, 2), group = NULL, level = 0.95,
                        color = NULL, fill = FALSE, symbol = FALSE) {
    viz_ellipses(x, group = group, type = "confidence", level = level,
                 color = color, fill = fill, symbol = symbol, ...)
    invisible(x)
  }
)

# SUMMARY
#' @include AllGenerics.R
NULL

# CA ===========================================================================
#' @export
#' @method summary CA
summary.CA <- function(object, ..., axes = c(1, 2), margin = 1,
                       active = TRUE, sup = TRUE, rank = NULL) {
  ## Get data
  values <- build_summary(object, axes = axes, margin = margin, rank = rank,
                          active = active, sup = sup)

  .SummaryCA(
    data = object@data,
    eigenvalues = values$eigenvalues,
    results = values$results,
    supplement = values$supplement,
    margin = as.integer(margin)
  )
}

#' @export
#' @rdname summary
#' @aliases summary,CA-method
setMethod("summary", c(object = "CA"), summary.CA)

#' @export
#' @rdname describe
#' @aliases describe,CA-method
setMethod(
  f = "describe",
  signature = signature(x = "CA"),
  definition = function(x, ...) {
    row_sup <- x@rows@supplement
    col_sup <- x@columns@supplement

    sup_txt <- tr_(" (+ %d supplementary)")
    row_txt <- if (any(row_sup)) sprintf(sup_txt, sum(row_sup)) else ""
    col_txt <- if (any(col_sup)) sprintf(sup_txt, sum(col_sup)) else ""

    cat(
      sprintf(tr_("* Row variable: %d categories%s."), sum(!row_sup), row_txt),
      sprintf(tr_("* Column variable: %d categories%s."), sum(!col_sup), col_txt),
      ...,
      sep = "\n"
    )
    invisible(x)
  }
)

# PCA ==========================================================================
#' @export
#' @method summary PCA
summary.PCA <- function(object, ..., axes = c(1, 2), margin = 1,
                        active = TRUE, sup = TRUE, rank = NULL) {
  ## Get data
  values <- build_summary(object, axes = axes, margin = margin, rank = rank,
                          active = active, sup = sup)

  .SummaryPCA(
    data = object@data,
    eigenvalues = values$eigenvalues,
    results = values$results,
    supplement = values$supplement,
    margin = as.integer(margin)
  )
}

#' @export
#' @rdname summary
#' @aliases summary,PCA-method
setMethod("summary", c(object = "PCA"), summary.PCA)

#' @export
#' @rdname describe
#' @aliases describe,PCA-method
setMethod(
  f = "describe",
  signature = signature(x = "PCA"),
  definition = function(x, ...) {
    row_sup <- x@rows@supplement
    col_sup <- x@columns@supplement

    sup_txt <- tr_(" (+ %d supplementary)")
    row_txt <- if (any(row_sup)) sprintf(sup_txt, sum(row_sup)) else ""
    col_txt <- if (any(col_sup)) sprintf(sup_txt, sum(col_sup)) else ""

    if (is_centered(x)) {
      var_center <- tr_("* Variables were shifted to be zero centered.")
    } else {
      var_center <- tr_("* Variables were NOT shifted to be zero centered.")
    }
    if (is_scaled(x)) {
      var_scale <- tr_("* Variables were scaled to unit variance.")
    } else {
      var_scale <- tr_("* Variables were NOT scaled to unit variance.")
    }

    cat(
      sprintf(tr_("* %d individuals%s."), sum(!row_sup), row_txt),
      sprintf(tr_("* %d variables%s."), sum(!col_sup), col_txt),
      var_center,
      var_scale,
      ...,
      sep = "\n"
    )
    invisible(x)
  }
)

# Helpers ======================================================================
build_summary <- function(object, axes, margin, rank = NULL,
                          active = TRUE, sup = TRUE,
                          prefix = "F") {
  ## Validation
  arkhe::assert_filled(axes)
  arkhe::assert_type(axes, "numeric")

  ## /!\ Backward compatibility /!\
  if (!is.null(rank)) {
    axes <- seq_len(rank)
    msg <- "'rank' argument is deprecated, use 'axes' instead."
    warning(msg, call. = FALSE)
  }

  ## Get data
  eig <- get_eigenvalues(object)
  inertia <- get_distances(object, margin = margin)
  coord <- get_coordinates(object, margin = margin)
  contrib <- get_contributions(object, margin = margin)
  cos2 <- get_cos2(object, margin = margin)

  if (inherits(object, "CA")) inertia <- inertia * 1000

  ## Fix lengths
  n <- nrow(coord)
  m <- nrow(contrib)
  if (n > m) {
    length(inertia) <- n
    contrib[seq(m + 1, n, 1), ] <- NA
  }

  ## Bind columns
  values <- vector(mode = "list", length = length(axes))
  for (j in axes) {
    v <- cbind(coord[[j]], contrib[[j]], cos2[[j]])
    colnames(v) <- paste0(prefix, j, c("_coord", "_contrib", "_cos2"))
    values[[j]] <- v
  }
  values <- do.call(cbind, values)
  values <- cbind(inertia = inertia, values)
  if (inherits(object, "PCA")) colnames(values)[1] <- "dist"
  rownames(values) <- rownames(coord)

  ## Remove data
  is_sup <- coord$.sup
  if (!active && !sup) active <- TRUE
  if (!active) {
    values <- values[is_sup, , drop = FALSE]
    is_sup <- is_sup[is_sup]
  }
  if (!sup) {
    values <- values[!is_sup, , drop = FALSE]
    is_sup <- is_sup[!is_sup]
  }

  list(
    eigenvalues = as.matrix(eig),
    results = as.matrix(values),
    supplement = is_sup
  )
}

# BOOTSTRAP
#' @include AllGenerics.R
NULL

# CA ===========================================================================
#' @export
#' @rdname bootstrap
#' @aliases bootstrap,CA-method
setMethod(
  f = "bootstrap",
  signature = c(object = "CA"),
  definition = function(object, n = 30) {
    ## Data replication
    n <- as.integer(n)
    arkhe::assert_scalar(n, "integer")

    data <- object@data
    data <- data[!object@rows@supplement, !object@columns@supplement]
    repl <- stats::rmultinom(n = n, size = sum(data), prob = data)

    i <- nrow(data)
    j <- ncol(data)

    k_n <- seq_len(n)
    k_i <- seq_len(i)
    k_j <- seq_len(j)

    new_row <- matrix(data = NA_integer_, nrow = i * n, ncol = j)
    new_col <- matrix(data = NA_integer_, nrow = i, ncol = j * n)
    for (p in k_n) {
      m_i <- k_i + i * (p - 1)
      m_j <- k_j + j * (p - 1)
      new_row[m_i, ] <- repl[, p]
      new_col[, m_j] <- repl[, p]
    }

    res_row <- ca(rbind(data, new_row), sup_row = 1:(i * n) + i)
    res_col <- ca(cbind(data, new_col), sup_col = 1:(j * n) + j)

    ## Set names
    names_row <- rep_len(object@rows@names, i * (n + 1))
    names_col <- rep_len(object@columns@names, j * (n + 1))
    res_row@rows@names <- make.unique(names_row, sep = "_")
    res_col@columns@names <- make.unique(names_col, sep = "_")

    ## Set groups
    res_row@rows@groups <- names_row
    res_col@columns@groups <- names_col

    .BootstrapCA(
      object,
      rows = res_row@rows,
      columns = res_col@columns,
      replications = n
    )
  }
)

# PCA ==========================================================================
#' @export
#' @rdname bootstrap
#' @aliases bootstrap,PCA-method
setMethod(
  f = "bootstrap",
  signature = c(object = "PCA"),
  definition = function(object, n = 30) {
    ## Get data
    n <- as.integer(n)
    arkhe::assert_scalar(n, "integer")

    data <- object@data
    data <- data[!object@rows@supplement, !object@columns@supplement]
    U <- object@rows@standard
    w <- object@rows@weights
    i <- nrow(data)
    j <- ncol(data)

    k_n <- seq_len(n)
    k_i <- seq_len(i)
    k_j <- seq_len(j)

    ## Data replication
    new_coord <- matrix(data = NA_integer_, nrow = j * n, ncol = ncol(U))
    new_dist <- vector(mode = "numeric", length = j * n)
    for (p in k_n) {
      m_j <- k_j + j * (p - 1)
      z <- sample(i, size = i, replace = TRUE)
      w_i <- w[z]
      new_data <- data[z, ]

      ## Principal coordinates
      # Center and scale
      if (is_centered(object)) {
        new_data <- t(t(new_data) - weighted_mean(new_data, w_i))
      }
      if (is_scaled(object)) {
        new_data <- t(t(new_data) / weighted_sd(new_data, w_i))
      }
      var_sup <- new_data * w_i
      new_coord[m_j, ] <- crossprod(var_sup, U[z, ])

      ## Squared distance to centroide
      new_dist[m_j] <- colSums(new_data^2 * w_i)
    }

    ## Squared cosine
    new_cos <- new_coord^2 / new_dist

    ## Set names
    names_col <- rep_len(object@columns@names, j * (n + 1))

    new_col <- build_results(
      names = make.unique(names_col, sep = "_"),
      principal = rbind(object@columns@principal, new_coord),
      standard = object@columns@standard,
      contributions = object@columns@contributions,
      distances = c(object@columns@distances, new_dist),
      cosine = rbind(object@columns@cosine, new_cos),
      weights = object@columns@weights,
      supplement = c(object@columns@supplement, !logical(j * n)),
      groups = names_col
    )

    .BootstrapPCA(
      object,
      columns = new_col,
      replications = n
    )
  }
)

# AUGMENT
#' @include AllGenerics.R
NULL

#' @export
#' @rdname tidy
#' @aliases augment,MultivariateAnalysis-method
setMethod(
  f = "augment",
  signature = c(x = "MultivariateAnalysis"),
  definition = function(x, ..., margin = 1, axes = c(1, 2), principal = TRUE) {
    ## Validation
    arkhe::assert_scalar(margin, "numeric")
    arkhe::assert_scalar(principal, "logical")
    arkhe::assert_type(axes, "numeric")
    arkhe::assert_length(axes, 2)

    ## Get data
    coords <- get_coordinates(x, margin = margin, principal = principal)

    mass <- contrib <- rep(NA_real_, nrow(coords))
    mass[!coords$.sup] <- get_masses(x, margin = margin)
    contrib[!coords$.sup] <- joint_contributions(x, margin = margin, axes = axes)
    sum <- joint_coordinates(x, margin = margin, axes = axes, principal = principal)
    cos2 <- joint_cos2(x, margin = margin, axes = axes)

    res <- data.frame(
      coords[, axes, drop = FALSE],
      label = rownames(coords),
      supplementary = coords$.sup,
      mass = mass,
      sum = sum,
      contribution = contrib,
      cos2 = cos2,
      row.names = NULL
    )

    if (!methods::is(x, "MultivariateBootstrap")) {
      ## Reorder
      ## /!\ see build_results() /!\
      origin <- get_order(x, margin = margin)
      res <- res[origin, , drop = FALSE]
    }

    res
  }
)

#' Joint
#'
#' @param object A [`CA-class`] or [`PCA-class`] object.
#' @param what A [`character`] string.
#' @param margin A length-one [`numeric`] vector giving the subscript
#'  which the data will be returned: `1` indicates individuals/rows (the
#'  default), `2` indicates variables/columns.
#' @param axes A length-two [`numeric`] vector giving the dimensions
#'  to be for which to compute results.
#' @param sup A [`logical`] scalar: should supplementary points be
#'  returned?
#' @param ... Extra parameters to be passed to internal methods.
#' @seealso \link[=mutator]{get_*()}
#' @example inst/examples/ex-joint.R
#' @author N. Frerebeau
#' @docType methods
#' @family summary
#' @name joint
#' @rdname joint
#' @noRd
NULL

joint <- function(object, what, ...) {
  choices <- c("coordinates", "contributions", "cos2")
  what <- match.arg(what, choices = choices, several.ok = FALSE)

  fun <- switch (
    what,
    coordinates = joint_coordinates,
    contributions = joint_contributions,
    cos2 = joint_cos2
  )

  fun(object, ...)
}

joint_coordinates <- function(object, ..., margin = 1, axes = c(1, 2),
                              principal = TRUE) {
  axes <- axes[c(1, 2)]
  coord <- get_coordinates(object, margin = margin, principal = principal)
  rowSums(coord[, axes]^2)
}

joint_contributions <- function(object, ..., margin = 1, axes = c(1, 2)) {
  axes <- axes[c(1, 2)]
  contrib <- get_contributions(object, margin = margin)
  eig <- matrix(
    data = object@singular_values[axes]^2,
    nrow = nrow(contrib),
    ncol = 2,
    byrow = TRUE
  )
  rowSums(contrib[, axes] * eig)
}

joint_cos2 <- function(object, ..., margin = 1, axes = c(1, 2)) {
  axes <- axes[c(1, 2)]
  cos2 <- get_cos2(object, margin = margin)
  rowSums(cos2[, axes])
}

# CONVEX HULL
#' @include AllGenerics.R
NULL

#' @export
#' @rdname viz_hull
#' @aliases wrap_hull,numeric,numeric-method
setMethod(
  f = "wrap_hull",
  signature = c(x = "numeric", y = "numeric"),
  definition = function(x, y, group = NULL) {
    ## Validation
    n <- length(x)
    arkhe::assert_length(y, n)

    ## Add groups, if any
    if (is.null(group)) group <- rep("", n)
    group <- as.character(group)
    arkhe::assert_length(group, n)

    ## Clean
    ok <- !is.na(x) & !is.na(y) & !is.na(group)
    x <- x[ok]
    y <- y[ok]
    group <- group[ok]

    ## Compute convex hulls
    index <- split(seq_along(group), f = group)
    lapply(
      X = index,
      FUN = function(i) {
        xi <- x[i]
        yi <- y[i]
        if (length(xi) < 3) return(NULL)

        i <- grDevices::chull(xi, yi)
        cbind(xi, yi)[c(i, i[1]), , drop = FALSE]
      }
    )
  }
)

#' @export
#' @rdname viz_hull
#' @aliases wrap_hull,MultivariateAnalysis,missing-method
setMethod(
  f = "wrap_hull",
  signature = c(x = "MultivariateAnalysis", y = "missing"),
  definition = function(x, margin = 1, axes = c(1, 2), group = NULL,
                        principal = TRUE) {
    ## Validation
    arkhe::assert_scalar(margin, "numeric")
    arkhe::assert_type(axes, "numeric")
    arkhe::assert_length(axes, 2)

    ## Get coordinates
    data <- get_coordinates(x, margin = margin, principal = principal)
    data <- data[, axes]

    ## Add groups, if any
    if (length(group) > 1) {
      group <- group[get_order(x, margin = margin)]
    } else if (length(group) == 1) {
      group <- get_extra(x)[[group]]
    } else if (has_groups(x, margin = margin)) {
      group <- get_groups(x, margin = margin)
    }

    ## Compute convex hulls
    methods::callGeneric(x = data[, 1], y = data[, 2], group = group)
  }
)

#' @export
#' @rdname viz_hull
#' @aliases wrap_hull,PCOA,missing-method
setMethod(
  f = "wrap_hull",
  signature = c(x = "PCOA", y = "missing"),
  definition = function(x, axes = c(1, 2), group = NULL) {
    ## Validation
    arkhe::assert_type(axes, "numeric")
    arkhe::assert_length(axes, 2)

    ## Get coordinates
    data <- get_coordinates(x)
    data <- data[, axes]

    ## Compute convex hulls
    methods::callGeneric(x = data[, 1], y = data[, 2], group = group)
  }
)

# HELPERS

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

recycle <- function(x, n) {
  if (length(x) == 1) rep(x, n) else x
}

print_variance <- function(object, axis) {
  v <- get_variance(object, digits = 1) # Get percentage of variance
  sprintf("%s (%g%%)", names(v)[[axis]], v[[axis]])
}

#' Weighted Column Means and Standard Deviations
#'
#' @param x A [`numeric`] matrix.
#' @param w An [`numeric`] vector.
#' @return A [`numeric`] vector.
#' @keywords internal
#' @noRd
weighted_mean <- function(x, w) {
  as.vector(crossprod(w, x))
}
weighted_sd <- function(x, w) {
  sqrt(as.vector(crossprod(w, x^2)))
}

#' Column Index
#'
#' @param index A [`numeric`] vector.
#' @param n An [`integer`] value.
#' @param names A [`character`] vector.
#' @return A [`logical`] vector.
#' @keywords internal
#' @noRd
find_variable <- function(index, n, names = NULL) {
  x <- logical(n)

  if (is.null(index)) return(x)

  if (is.logical(index)) {
    arkhe::assert_length(index, n)
    return(index)
  }

  if (is.character(index)) {
    index <- match(index, names)
    index <- index[!is.na(index)]
    if (length(index) == 0) return(x)
  }

  if (is.numeric(index)) {
    x[index] <- TRUE
    return(x)
  }

  arkhe::assert_type(index, "numeric")
}

#' Remove Columns Using a Predicate
#'
#' @param x A [`data.frame`].
#' @param f A predicate [`function`].
#' @param negate A [`logical`] scalar: should the negation of `f` be used
#'  instead of `f`?
#' @param sup A `vector` specifying the indices of the supplementary columns.
#' @param extra A `vector` specifying the indices of the extra columns.
#' @param auto A [`logical`] scalar: should invalid variables be automatically
#'  removed?
#' @param what A [`character`] string to be used in the message.
#' @param verbose A [`logical`] scalar: should \R report extra information on
#'  progress?
#' @details
#'  Side effect: move `sup` and `extra` columns at the end of `x`.
#' @return A `list` with the following elements: `data` (a `matrix`),
#'  `sup` (an `integer` vector) and `extra` (a `data.frame` or `NULL`).
#' @keywords internal
#' @noRd
drop_variable <- function(x, f, negate = FALSE, sup = NULL, extra = NULL,
                          auto = TRUE, what = "extra",
                          verbose = getOption("dimensio.verbose")) {
  ## Check variables
  if (negate) f <- Negate(f)
  not_ok <- vapply(x, FUN = f, FUN.VALUE = logical(1))

  ## Get extra variables
  is_extra <- find_variable(extra, ncol(x), names = colnames(x))
  is_sup <- find_variable(sup, ncol(x), names = colnames(x))

  ## Quit
  if (!auto && any(not_ok & !is_extra)) {
    msg <- tr_("Some variables are invalid: %s.")
    col <- paste(colnames(x)[not_ok & !is_extra], collapse = ", ")
    stop(sprintf(msg, col), call. = FALSE)
  }

  ## Extract extra variables, if any
  if (any(is_extra)) {
    extra <- x[, is_extra, drop = FALSE]
  }

  ## Remove supplementary/extra variables, if any
  tmp <- x
  x <- x[, !(not_ok | is_sup | is_extra), drop = FALSE]

  ## Move supplementary variables at the end, if any
  is_sup_ok <- is_sup & !not_ok
  if (any(is_sup_ok)) {
    sup <- seq_len(sum(is_sup_ok)) + ncol(x)
    x <- cbind(x, tmp[, is_sup_ok, drop = FALSE])
  } else {
    # warning("!", call. = FALSE)
    sup <- NULL
  }

  ## Generate message
  if (any(not_ok)) {
    not_ok[is_sup | is_extra] <- FALSE
    if (any(not_ok) && verbose) {
      tot <- sum(not_ok)
      msg <- ngettext(tot, "%d %s variable was removed: %s.",
                      "%d %s variables were removed: %s.")
      col <- paste(colnames(tmp)[not_ok], collapse = ", ")
      message(sprintf(msg, tot, what, col))
    }
  }

  list(
    data = as.matrix(x),
    sup = sup,
    extra = extra
  )
}

# TOOLS
#' @include AllGenerics.R
NULL

#' @export
#' @rdname cdt
#' @aliases cdt,matrix-method
setMethod(
  f = "cdt",
  signature = c(object = "matrix"),
  definition = function(object, exclude = NULL, abbrev = TRUE) {
    ## Fix colnames
    if (is.null(colnames(object))) {
      colnames(object) <- paste0("V", seq_len(ncol(object)))
    }

    d <- apply(
      X = object,
      MARGIN = 2,
      FUN = function(cl, exclude) {
        cl <- factor(x = cl, exclude = exclude)
        n <- length(cl)
        z <- matrix(0, nrow = n, ncol = nlevels(cl))
        z[seq_len(n) + n * (unclass(cl) - 1)] <- 1
        dimnames(z) <- list(names(cl), levels(cl))
        z
      },
      exclude = exclude,
      simplify = FALSE
    )
    mtx <- do.call(cbind, d)

    if (!abbrev) {
      n <- vapply(X = d, FUN = ncol, FUN.VALUE = integer(1))
      colnames(mtx) <- paste(rep(colnames(object), n), colnames(mtx), sep = "_")
    }

    mtx
  }
)

#' @export
#' @rdname cdt
#' @aliases cdt,data.frame-method
setMethod(
  f = "cdt",
  signature = c(object = "data.frame"),
  definition = function(object, exclude = NULL, abbrev = TRUE) {
    object <- as.matrix(object)
    methods::callGeneric(object, exclude = exclude, abbrev = abbrev)
  }
)

#' @export
#' @rdname burt
#' @aliases burt,data.frame-method
setMethod(
  f = "burt",
  signature = c(object = "data.frame"),
  definition = function(object, exclude = NULL, abbrev = TRUE) {
    x <- cdt(object, exclude = exclude, abbrev = abbrev)
    crossprod(x, x)
  }
)

# SHOW
#' @include AllGenerics.R
NULL

setMethod(
  f = "show",
  signature = "CA",
  definition = function(object) {
    cat(
      tr_("Correspondence Analysis (CA):"),
      utils::capture.output(describe(object)),
      sep = "\n"
    )
    invisible(object)
  }
)

setMethod(
  f = "show",
  signature = "MCA",
  definition = function(object) {
    cat(
      tr_("Multiple Correspondence Analysis (MCA):"),
      utils::capture.output(describe(object)),
      sep = "\n"
    )
    invisible(object)
  }
)

setMethod(
  f = "show",
  signature = "PCA",
  definition = function(object) {
    cat(
      tr_("Principal Components Analysis (PCA):"),
      utils::capture.output(describe(object)),
      sep = "\n"
    )
    invisible(object)
  }
)

setMethod(
  f = "show",
  signature = "PCOA",
  definition = function(object) {
    cat(
      tr_("Principal Coordinate Analysis (PCoA):"),
      sprintf(tr_("* Method: %s."), object@method),
      sep = "\n"
    )
    invisible(object)
  }
)

setMethod(
  f = "show",
  signature = "MultivariateSummary",
  definition = function(object) {
    ## Get options
    n_dig <- getOption("dimensio.digits")
    n_max <- getOption("dimensio.max.print")

    if (methods::is(object, "SummaryCA")) {
      active <- c(tr_("Active rows"), tr_("Active columns"))
      suppl <- c(tr_("Supplementary rows"), tr_("Supplementary columns"))
      title <- tr_("Correspondence Analysis (CA)")
    }
    if (methods::is(object, "SummaryPCA")) {
      active <- c(tr_("Active individuals"), tr_("Active variables"))
      suppl <- c(tr_("Supplementary individuals"), tr_("Supplementary variables"))
      title <- tr_("Principal Components Analysis (PCA)")
    }

    ## Get data
    eig <- round(object@eigenvalues, digits = n_dig)
    res <- round(object@results, digits = n_dig)

    ## Prepare data
    is_sup <- object@supplement
    eigen <- c(paste0("\n## ", tr_("Eigenvalues")), "",
               utils::capture.output(format_table(eig)))

    ## Supplementary points
    sum_sup <- extra_sup <- NULL
    if (any(is_sup)) {
      res_sup <- res[is_sup, ]
      n_sup <- nrow(res_sup)
      if (n_sup > n_max) {
        res_sup <- res_sup[seq_len(n_max), ]
        extra_sup <- sprintf("(%s more)", n_sup - n_max)
      }
      is_na <- apply(X = res_sup, MARGIN = 2, FUN = anyNA)
      res_sup <- res_sup[, !is_na]
      sum_sup <- c(paste0("\n## ", suppl[[object@margin]]), "",
                   utils::capture.output(format_table(res_sup)))
    }

    ## Active points
    sum_act <- extra_act <- NULL
    if (any(!is_sup)) {
      res_act <- res[!is_sup, ]
      n_act <- nrow(res_act)
      if (n_act > n_max) {
        res_act <- res_act[seq_len(n_max), ]
        extra_act <- sprintf("(%s more)", n_act - n_max)
      }
      sum_act <- c(paste0("\n## ", active[[object@margin]]), "",
                   utils::capture.output(format_table(res_act)))
    }

    ## Print
    header <- paste0("# ", title)
    cat(header, eigen, sum_act, extra_act, sum_sup, extra_sup, sep = "\n")
    invisible(object)
  }
)


format_table <- function(x) {
  val <- rbind(colnames(x), format_head(colnames(x), left = FALSE), x)
  val <- apply(X = val, MARGIN = 2, FUN = format_col, left = FALSE)
  row_names <- c("", format_head(rownames(x))[which.max(nchar(rownames(x)))], rownames(x))
  val <- cbind(format_col(row_names), val)
  val <- apply(X = val, MARGIN = 1, FUN = format_row)
  cat(val, sep = "\n")
}

vec_rep <- function(x, times) {
  force(x)
  vapply(
    X = times,
    FUN = function(i) paste0(rep(x, i), collapse = ""),
    FUN.VALUE = character(1)
  )
}
format_head <- function(x, left = TRUE) {
  n <- nchar(x) - 1
  d <- vec_rep("-", n)
  if (left) paste0(":", d) else paste0(d, ":")
}
format_col <- function(x, left = TRUE) {
  n <- max(nchar(x))
  d <- vapply(
    X = n - nchar(x),
    FUN = function(i) ifelse(i == 0, "", paste0(rep(" ", i), collapse = "")),
    FUN.VALUE = character(1)
  )
  if (left) paste0(x, d) else paste0(d, x)
}
format_row <- function(x) {
  paste0("| ", paste0(x, collapse = " | "), " |")
}

# PLOT CONTRIBUTIONS
#' @include AllGenerics.R
NULL

#' @export
#' @rdname viz_contributions
#' @aliases viz_contributions,MultivariateAnalysis-method
setMethod(
  f = "viz_contributions",
  signature = c(x = "MultivariateAnalysis"),
  definition = function(x, ..., margin = 2, axes = 1,
                        sort = TRUE, decreasing = TRUE, limit = 10,
                        horiz = FALSE, col = "grey90", border = "grey10") {
    ## Prepare data
    data <- prepare_contrib(x, margin = margin, axes = axes, sort = sort,
                            decreasing = decreasing, limit = limit)

    ## Expected average contribution
    theo <- 100 / length(data$y)
    if (length(axes) > 1) {
      eig <- get_eigenvalues(x)[axes, 1]
      theo <- sum(theo * eig) / sum(eig)
    }

    ## Bar plot
    msg <- tr_("Contribution to %s (%%)")
    ylab <- sprintf(msg, paste0("F", axes, collapse = "-"))
    mid <- graphics::barplot(
      height = data$y,
      names.arg = data$x,
      horiz = horiz,
      xlab = if (horiz) ylab else NULL,
      ylab = if (horiz) NULL else ylab,
      col = col,
      border = border,
      las = 1,
      ...
    )
    graphics::abline(h = theo, lty = 2, col = "red")

    invisible(x)
  }
)

# Must return a data.frame (`x`, `y`, `label`)
prepare_contrib <- function(object, margin, axes, sort = TRUE,
                            decreasing = TRUE, limit = 10) {
  ## Get data
  contrib <- get_contributions(object, margin = margin)
  if (length(axes) > 1) {
    values <- joint_contributions(object, margin = margin, axes = axes)
  } else {
    values <- contrib[[axes[[1]]]]
  }

  ## Prepare data
  data <- data.frame(
    x = rownames(contrib),
    y = values,
    label = round(values, digits = 2)
  )

  ## Sort data
  if (sort) {
    data <- data[order(data$y, decreasing = decreasing), ]
  }

  ## Subset
  if (!is.null(limit)) {
    limit <- min(nrow(data), limit)
    data <- data[seq_len(limit), , drop = FALSE]
  }

  ## Prevent reordering
  data$x <- factor(data$x, levels = unique(data$x))

  data
}

# GET DISTANCES
#' @include AllGenerics.R
NULL

#' @export
#' @rdname get_eigenvalues
#' @aliases get_distances,MultivariateAnalysis-method
setMethod(
  f = "get_distances",
  signature = c(x = "MultivariateAnalysis"),
  definition = function(x, margin = 1) {
    arkhe::assert_scalar(margin, "numeric")

    if (margin == 1) {
      d2 <- x@rows@distances
      names(d2) <- x@rows@names
      suppl <- x@rows@supplement
    }
    if (margin == 2) {
      d2 <- x@columns@distances
      names(d2) <- x@columns@names
      suppl <- x@columns@supplement
    }

    d2
  }
)

# GET COORDINATES
#' @include AllGenerics.R
NULL

# Coordinates ==================================================================
#' @export
#' @rdname get_coordinates
#' @aliases get_coordinates,MultivariateAnalysis-method
setMethod(
  f = "get_coordinates",
  signature = c(x = "MultivariateAnalysis"),
  definition = function(x, margin = 1, principal = TRUE, sup_name = ".sup") {
    arkhe::assert_scalar(margin, "numeric")
    arkhe::assert_scalar(principal, "logical")
    arkhe::assert_scalar(sup_name, "character")

    if (margin == 1) {
      coords <- x@rows@principal
      suppl <- x@rows@supplement
      id <- x@rows@names
    }
    if (margin == 2) {
      coords <- x@columns@principal
      suppl <- x@columns@supplement
      id <- x@columns@names
    }

    # P = sqrt(eigenvalue) X S
    if (!principal) {
      coords <- t(t(coords) / x@singular_values)
    }

    coords <- as.data.frame(coords, row.names = id)
    coords[[sup_name]] <- suppl

    coords
  }
)

#' @export
#' @rdname get_coordinates
#' @aliases get_coordinates,PCOA-method
setMethod(
  f = "get_coordinates",
  signature = c(x = "PCOA"),
  definition = function(x) {
    as.data.frame(x@points)
  }
)

# Replications =================================================================
#' @export
#' @rdname get_coordinates
#' @aliases get_replications,MultivariateBootstrap-method
setMethod(
  f = "get_replications",
  signature = c(x = "MultivariateBootstrap"),
  definition = function(x, margin = 1) {
    coords <- get_coordinates(x = x, margin = margin)

    k <- x@replications
    i <- nrow(coords) / (k + 1)
    j <- ncol(coords) - 1

    ## Drop the original data and the last column
    repl_coords <- coords[-seq_len(i), seq_len(j)]
    repl <- split(x = repl_coords, f = rep(seq_len(k), each = i))
    repl <- array(data = unlist(repl), dim = c(i, j, k))
    rownames(repl) <- rownames(coords)[seq_len(i)]
    colnames(repl) <- colnames(repl_coords)
    repl
  }
)

#' @export
#' @rdname get_coordinates
#' @aliases get_replications,BootstrapPCA-method
setMethod(
  f = "get_replications",
  signature = c(x = "BootstrapPCA"),
  definition = function(x) {
    methods::callNextMethod(x = x, margin = 2)
  }
)

# GET EIGENVALUES
#' @include AllGenerics.R
NULL

#' @export
#' @rdname get_eigenvalues
#' @aliases get_eigenvalues,MultivariateAnalysis-method
setMethod(
  f = "get_eigenvalues",
  signature = c(x = "MultivariateAnalysis"),
  definition = function(x) {
    eig <- x@singular_values^2 # Eigenvalues
    pvar <- eig / sum(eig) * 100 # Percentage
    cvar <- cumsum(pvar) # Cumulative percentage

    z <- data.frame(eig, pvar, cvar)
    colnames(z) <- c("eigenvalues", "variance", "cumulative")
    z
  }
)

#' @export
#' @rdname get_eigenvalues
#' @aliases get_eigenvalues,PCOA-method
setMethod(
  f = "get_eigenvalues",
  signature = c(x = "PCOA"),
  definition = function(x) {
    eig <- x@eigenvalues# Eigenvalues
    pvar <- eig / sum(eig) * 100 # Percentage
    cvar <- cumsum(pvar) # Cumulative percentage

    z <- data.frame(eig, pvar, cvar)
    colnames(z) <- c("eigenvalues", "variance", "cumulative")
    z
  }
)

# PLOT COORDINATES
#' @include AllGenerics.R
NULL

#' @export
#' @method plot PCOA
plot.PCOA <- function(x, ..., axes = c(1, 2), labels = FALSE,
                      extra_quali = NULL, extra_quanti = NULL,
                      ellipse = NULL, hull = FALSE,
                      color = NULL, fill = FALSE, symbol = FALSE, size = c(1, 6),
                      xlim = NULL, ylim = NULL, main = NULL, sub = NULL,
                      ann = graphics::par("ann"), frame.plot = TRUE,
                      panel.first = NULL, panel.last = NULL,
                      legend = list(x = "topleft")) {
  ## Set axes
  arkhe::assert_type(axes, "numeric")
  arkhe::assert_length(axes, 2)
  assign("axes", value = axes, envir = the)

  ## Prepare data
  coord <- get_coordinates(x)
  coord$x <- coord[[axes[[1L]]]]
  coord$y <- coord[[axes[[2L]]]]
  n <- NROW(coord)

  ## Set graphical parameters
  ## (recycle if of length one)
  dots <- list(...)
  col <- recycle(dots$col %||% graphics::par("col"), n)
  bg <- recycle(dots$bg %||% graphics::par("bg"), n)
  pch <- recycle(dots$pch %||% 16, n)
  cex <- recycle(dots$cex %||% graphics::par("cex"), n)

  ## Highlight quantitative information
  if (length(extra_quanti) > 0) {
    arkhe::assert_type(extra_quanti, "numeric")
    arkhe::assert_length(extra_quanti, n)
    ## Continuous scales
    ## (ignored if col, bg and cex are set by user)
    if (is.null(dots$col) && !isFALSE(color))
      col <- khroma::palette_color_continuous(colors = color)(extra_quanti)
    if (is.null(dots$bg) && !isFALSE(fill))
      bg <- khroma::palette_color_continuous(colors = fill)(extra_quanti)
    if (is.null(dots$cex) && !isFALSE(size))
      cex <- khroma::palette_size_sequential(range = size)(extra_quanti)
  }
  ## Highlight qualitative information
  if (length(extra_quali) > 0) {
    arkhe::assert_length(extra_quali, n)
    ## Discrete scales
    ## (ignored if col, bg and pch are set by user)
    if (is.null(dots$col) && !isFALSE(color))
      col <- khroma::palette_color_discrete(colors = color)(extra_quali)
    if (is.null(dots$bg) && !isFALSE(fill))
      bg <- khroma::palette_color_discrete(colors = fill)(extra_quali)
    if (is.null(dots$pch) && !isFALSE(symbol))
      pch <- khroma::palette_shape(symbols = symbol)(extra_quali)
  }

  ## Save and restore graphical parameters
  ## pty: square plotting region, independent of device size
  old_par <- graphics::par(pty = "s", no.readonly = TRUE)
  on.exit(graphics::par(old_par), add = TRUE)

  ## Open new window
  grDevices::dev.hold()
  on.exit(grDevices::dev.flush(), add = TRUE)
  graphics::plot.new()

  ## Set plotting coordinates
  xlim <- xlim %||% range(coord$x, na.rm = TRUE, finite = TRUE)
  ylim <- ylim %||% range(coord$y, na.rm = TRUE, finite = TRUE)
  graphics::plot.window(xlim = xlim, ylim = ylim, asp = 1)

  ## Evaluate pre-plot expressions
  panel.first

  ## Plot
  graphics::abline(h = 0, lty = "dashed", lwd = 1, col = graphics::par("fg"))
  graphics::abline(v = 0, lty = "dashed", lwd = 1, col = graphics::par("fg"))
  graphics::points(x = coord$x, y = coord$y,
                   col = col, bg = bg, pch = pch, cex = cex)

  ## Labels
  if (isTRUE(labels)) {
    label(
      x = coord$x,
      y = coord$y,
      labels = rownames(coord),
      type = "shadow",
      col = col,
      cex = cex,
      xpd = TRUE
    )
  }

  if (length(extra_quali) > 0) {
    ## Add ellipse
    if (is.list(ellipse) && length(ellipse) > 0) {
      args_ell <- list(x = x, group = extra_quali, axes = axes,
                       color = color, fill = FALSE, symbol = FALSE)
      ellipse <- modifyList(args_ell, val = ellipse)
      do.call(viz_ellipses, ellipse)
    }
    ## Add convex hull
    if (isTRUE(hull)) {
      args_hull <- list(x = x, group = extra_quali, axes = axes,
                        color = color, fill = FALSE, symbol = FALSE)
      do.call(viz_hull, args_hull)
    }
  }

  ## Evaluate post-plot and pre-axis expressions
  panel.last

  ## Construct axis (axes)
  if (TRUE) {
    graphics::axis(side = 1, las = 1)
    graphics::axis(side = 2, las = 1)
  }

  ## Plot frame
  if (frame.plot) {
    graphics::box()
  }

  ## Add annotation
  if (ann) {
    graphics::title(
      main = main, sub = sub,
      xlab = colnames(coord)[axes[[1]]],
      ylab = colnames(coord)[axes[[2]]]
    )
  }

  ## Legend
  coord <- data.frame(
    extra_quanti = if (length(extra_quanti) > 0) extra_quanti else rep(NA, n),
    extra_quali = if (length(extra_quali) > 0) extra_quali else rep(NA, n),
    cex = cex, col = col, bg = bg, pch = pch, lty = rep(NA, n)
  )
  prepare_legend(coord, legend, points = TRUE, lines = FALSE)

  invisible(x)
}

#' @export
#' @rdname plot
#' @aliases plot,PCOA,missing-method
setMethod("plot", c(x = "PCOA", y = "missing"), plot.PCOA)

# MUTATORS
#' @include AllGenerics.R
NULL

# Non exported =================================================================
is_centered <- function(x) {
  !all(x@center == 0)
}
is_scaled <- function(x) {
  !all(x@scale == 1)
}

get_masses <- function(x, margin = 1) {
  margin <- margin[[1L]]
  if (margin == 1) mass <- x@rows@weights
  if (margin == 2) mass <- x@columns@weights
  mass
}

get_order <- function(x, margin = 1) {
  margin <- margin[[1L]]
  if (margin == 1) ord <- x@rows@order
  if (margin == 2) ord <- x@columns@order
  ord
}

# Groups =======================================================================
get_groups <- function(x, margin = 1) {
  margin <- margin[[1L]]
  if (margin == 1) grp <- x@rows@groups
  if (margin == 2) grp <- x@columns@groups
  grp
}

`set_groups<-` <- function(x, margin = 1, value) {
  if (is.null(value)) value <- character(0)
  margin <- margin[[1L]]
  if (margin == 1) x@rows@groups <- value
  if (margin == 2) x@columns@groups <- value
  methods::validObject(x)
  x
}

has_groups <- function(x, margin = 1) {
  margin <- margin[[1L]]
  if (margin == 1) grp <- x@rows@groups
  if (margin == 2) grp <- x@columns@groups
  length(grp) > 0
}

# Dimensions ===================================================================
#' @export
#' @method dim MultivariateAnalysis
dim.MultivariateAnalysis <- function(x) {
  x@dimension
}

#' @export
#' @rdname dimnames
#' @aliases dim,MultivariateAnalysis-method
setMethod("dim", "MultivariateAnalysis", dim.MultivariateAnalysis)

#' @export
#' @method rownames MultivariateAnalysis
rownames.MultivariateAnalysis <- function(x, do.NULL = TRUE, prefix = "row") {
  dn <- dimnames(x)
  if (!is.null(dn[[1L]]))
    dn[[1L]]
  else {
    nr <- NROW(x@rows@principal)
    if (do.NULL)
      NULL
    else if (nr > 0L)
      paste0(prefix, seq_len(nr))
    else character()
  }
}

#' @export
#' @rdname dimnames
#' @aliases rownames,MultivariateAnalysis-method
setMethod("rownames", "MultivariateAnalysis", rownames.MultivariateAnalysis)

#' @export
#' @method colnames MultivariateAnalysis
colnames.MultivariateAnalysis <- function(x, do.NULL = TRUE, prefix = "col") {
  dn <- dimnames(x)
  if (!is.null(dn[[2L]]))
    dn[[2L]]
  else {
    nc <- NROW(x@columns@principal)
    if (do.NULL)
      NULL
    else if (nc > 0L)
      paste0(prefix, seq_len(nc))
    else character()
  }
}

#' @export
#' @rdname dimnames
#' @aliases colnames,MultivariateAnalysis-method
setMethod("colnames", "MultivariateAnalysis", colnames.MultivariateAnalysis)

#' @export
#' @method dimnames MultivariateAnalysis
dimnames.MultivariateAnalysis <- function(x) {
  list(x@rows@names, x@columns@names)
}

#' @export
#' @rdname dimnames
#' @aliases dimnames,MultivariateAnalysis-method
setMethod("dimnames", "MultivariateAnalysis", dimnames.MultivariateAnalysis)

# GET CORRELATIONS
#' @include AllGenerics.R
NULL

#' @export
#' @rdname get_contributions
#' @aliases get_correlations,PCA-method
setMethod(
  f = "get_correlations",
  signature = c(x = "PCA"),
  definition = function(x, sup_name = ".sup") {
    arkhe::assert_scalar(sup_name, "character")

    corr <- x@columns@principal / x@columns@distances
    suppl <- x@columns@supplement

    corr <- as.data.frame(corr)
    corr[[sup_name]] <- suppl

    corr
  }
)

# CLASSES DEFINITION

# Register S3 classes ==========================================================
setOldClass("dist")

# MultivariateAnalysis =========================================================
## Results ---------------------------------------------------------------------
#' Multivariate Data Analysis Results
#'
#' An S4 class to store the results of a multivariate data analysis.
#' @slot names A [`character`] vector specifying the row names.
#' @slot principal A [`numeric`] [`matrix`] giving the principal coordinates.
#' @slot standard A [`numeric`] [`matrix`] giving the standard coordinates.
#' @slot contributions A [`numeric`] [`matrix`] giving the contributions to the
#'  definition of the dimensions.
#' @slot cosine A [`numeric`] [`matrix`] giving the \eqn{cos^2}{cos2} values.
#' @slot distances A [`numeric`] vector giving the distances to centroid.
#' @slot weights A [`numeric`] vector giving the masses/weights.
#' @slot supplement A [`logical`] vector specifying the supplementary points.
#' @slot order An [`integer`] vector giving the original indices of the data
#'  (computation moves all supplementary points at the end of the results).
#' @slot groups A [`character`] vector specifying the class for each
#'  observation.
#' @author N. Frerebeau
#' @family class
#' @docType class
#' @name MultivariateResults
#' @aliases MultivariateResults-class
#' @keywords internal
.MultivariateResults <- setClass(
  Class = "MultivariateResults",
  slots = c(
    names = "character",
    principal = "matrix",
    standard = "matrix",
    contributions = "matrix",
    cosine = "matrix",
    distances = "numeric",
    weights = "numeric",
    supplement = "logical",
    order = "integer",
    groups = "character"
  )
)

## Output ----------------------------------------------------------------------
#' Output of Multivariate Data Analysis
#'
#' A virtual S4 class to store the output of a multivariate data analysis.
#' @slot data A [`numeric`] [`matrix`].
#' @slot dimension An [`integer`] giving the dimension of the solution.
#' @slot singular_values A [`numeric`] vector giving the singular values.
#' @slot rows A [`MultivariateResults-class`] object.
#' @slot columns A [`MultivariateResults-class`] object.
#' @slot extra A [`list`] of extra variables.
#' @section Subset:
#'  In the code snippets below, `x` is a `MultivariateAnalysis` object.
#'  \describe{
#'   \item{`x[[i]]`}{Extracts information from a slot selected by subscript `i`.
#'   `i` is a length-one [`character`] vector.}
#'  }
#' @author N. Frerebeau
#' @family class
#' @docType class
#' @name MultivariateAnalysis
#' @aliases MultivariateAnalysis-class
#' @keywords internal
.MultivariateAnalysis <- setClass(
  Class = "MultivariateAnalysis",
  slots = c(
    data = "matrix",
    dimension = "integer",
    singular_values = "numeric",
    rows = "MultivariateResults",
    columns = "MultivariateResults",
    extra = "list"
  ),
  contains = "VIRTUAL"
)

## Bootstrap -------------------------------------------------------------------
#' Output of Bootstrap Replications
#'
#' A virtual S4 class to store the output of a bootstrap analysis.
#' @slot replications An [`integer`] giving the number of bootstrap
#'  replications.
#' @author N. Frerebeau
#' @family class
#' @docType class
#' @name MultivariateBootstrap
#' @aliases MultivariateBootstrap-class
#' @keywords internal
.MultivariateBootstrap <- setClass(
  Class = "MultivariateBootstrap",
  slots = c(
    replications = "integer"
  ),
  contains = "VIRTUAL"
)

## Summary ---------------------------------------------------------------------
#' Summary of Multivariate Data Analysis
#'
#' A virtual S4 class to store the summary of a multivariate data analysis.
#' @slot data A [`numeric`] [`matrix`].
#' @slot eigenvalues A [`numeric`] [`matrix`].
#' @slot results A [`numeric`] [`matrix`].
#' @slot supplement A [`logical`] vector specifying the supplementary points.
#' @slot margin An [`integer`].
#' @author N. Frerebeau
#' @family class
#' @docType class
#' @name MultivariateSummary
#' @aliases MultivariateSummary-class
#' @keywords internal
.MultivariateSummary <- setClass(
  Class = "MultivariateSummary",
  slots = c(
    data = "matrix",
    eigenvalues = "matrix",
    results = "matrix",
    supplement = "logical",
    margin = "integer"
  ),
  contains = "VIRTUAL"
)

#' @rdname MultivariateSummary
#' @aliases SummaryCA-class
.SummaryCA <- setClass(
  Class = "SummaryCA",
  contains = "MultivariateSummary"
)

#' @rdname MultivariateSummary
#' @aliases SummaryPCA-class
.SummaryPCA <- setClass(
  Class = "SummaryPCA",
  contains = "MultivariateSummary"
)

# CA ===========================================================================
#' CA Results
#'
#' An S4 class to store the results of a simple correspondence analysis.
#' @note
#'  This class inherits from [`MultivariateAnalysis-class`].
#' @example inst/examples/ex-ca.R
#' @author N. Frerebeau
#' @family class
#' @docType class
#' @exportClass CA
#' @aliases CA-class
#' @keywords internal
.CA <- setClass(
  Class = "CA",
  contains = "MultivariateAnalysis"
)

#' Bootstrap CA Results
#'
#' An S4 class to store the bootstrap of a correspondence analysis.
#' @note
#'  This class inherits from [`CA-class`] and [`MultivariateBootstrap-class`].
#' @example inst/examples/ex-bootstrap.R
#' @author N. Frerebeau
#' @family class
#' @docType class
#' @aliases BootstrapCA-class
#' @keywords internal
.BootstrapCA <- setClass(
  Class = "BootstrapCA",
  contains = c("MultivariateBootstrap", "CA")
)

# MCA ==========================================================================
#' MCA Results
#'
#' An S4 class to store the results of a multiple correspondence analysis.
#' @note
#'  This class inherits from [`CA-class`].
# @example inst/examples/ex-mca.R
#' @author N. Frerebeau
#' @family class
#' @docType class
#' @exportClass MCA
#' @aliases MCA-class
#' @keywords internal
.MCA <- setClass(
  Class = "MCA",
  contains = "CA"
)

# PCA ==========================================================================
#' PCA Results
#'
#' An S4 class to store the results of a principal components analysis.
#' @slot center A [`numeric`] vector giving the column mean of the initial
#'  dataset (active individuals only).
#' @slot scale A [`numeric`] vector giving the column standard deviations of the
#'  initial dataset (active individuals only).
#' @note
#'  This class inherits from [`MultivariateAnalysis-class`].
#' @example inst/examples/ex-pca.R
#' @author N. Frerebeau
#' @family class
#' @docType class
#' @exportClass PCA
#' @aliases PCA-class
#' @keywords internal
.PCA <- setClass(
  Class = "PCA",
  slots = c(
    center = "numeric",
    scale = "numeric"
  ),
  contains = "MultivariateAnalysis"
)

#' Bootstrap PCA Results
#'
#' An S4 class to store the bootstrap of a principal components analysis.
#' @note
#'  This class inherits from [`PCA-class`] and [`MultivariateBootstrap-class`].
#' @example inst/examples/ex-bootstrap.R
#' @author N. Frerebeau
#' @family class
#' @docType class
#' @aliases BootstrapPCA-class
#' @keywords internal
.BootstrapPCA <- setClass(
  Class = "BootstrapPCA",
  contains = c("MultivariateBootstrap", "PCA")
)

# PCOA =========================================================================
#' PCoA Results
#'
#' An S4 class to store the results of a principal coordinates analysis.
#' @slot points A `numeric` matrix whose rows give the coordinates of the points
#'  chosen to represent the dissimilarities.
#' @slot eigenvalues A [`numeric`] vector giving the eigenvalues computed during
#'  the scaling process.
#' @slot method A [`character`] string giving the distance that has been used to
#'  create the distance structure.
#' @slot GOF A length-two [`numeric`] vector.
#' @slot groups A [`character`] vector specifying the class for each
#'  observation.
#' @example inst/examples/ex-pcoa.R
#' @author N. Frerebeau
#' @family class
#' @docType class
#' @exportClass PCOA
#' @aliases PCOA-class
#' @keywords internal
.PCOA <- setClass(
  Class = "PCOA",
  slots = c(
    points = "matrix",
    eigenvalues = "numeric",
    GOF = "numeric",
    method = "character",
    groups = "character"
  )
)

# Initialize ===================================================================
build_results <- function(names, principal, standard, contributions,
                          distances, cosine, weights, supplement,
                          groups = NULL) {
  ## /!\ Reorder active/supplementary points /!\
  ## Computation moves all supplementary points at the end of the results
  new_i <- seq_len(nrow(principal))
  sup_i <- new_i * -1
  if (any(supplement)) {
    sup_i <- utils::tail(new_i, n = sum(supplement))
    new_i <- c(new_i[!supplement], new_i[supplement])
    names <- names[new_i]
    if (length(groups) > 0) {
      groups <- groups[new_i]
    }
  }

  ## Prepare names
  # names <- rep(names, length.out = length(supplement))
  col_names <- paste0("F", seq_len(ncol(principal)))
  dim_names0 <- list(names[-sup_i], col_names)
  dim_names1 <- list(names, col_names)

  ## Set names
  dimnames(principal) <- dimnames(cosine) <- dim_names1
  dimnames(standard) <- dimnames(contributions) <- dim_names0
  names(distances) <- names
  names(weights) <- names[!supplement]

  .MultivariateResults(
    names = names,
    principal = principal,
    standard = standard,
    contributions = contributions,
    cosine = cosine,
    distances = distances,
    weights = weights,
    supplement = sort(supplement),
    order = new_i,
    groups = groups %||% character(0)
  )
}

# GET INERTIA
#' @include AllGenerics.R
NULL

#' @export
#' @rdname get_eigenvalues
#' @aliases get_inertia,MultivariateAnalysis-method
setMethod(
  f = "get_inertia",
  signature = c(x = "MultivariateAnalysis"),
  definition = function(x, margin = 1) {
    arkhe::assert_scalar(margin, "numeric")

    if (margin == 1) {
      masses <- x@rows@weights
      d2 <- x@rows@distances
      suppl <- x@rows@supplement
      name <- x@rows@names
    }
    if (margin == 2) {
      masses <- x@columns@weights
      d2 <- x@columns@distances
      suppl <- x@columns@supplement
      name <- x@columns@names
    }

    i <- masses * d2[!suppl]
    names(i) <- name[!suppl]
    i
  }
)

# PLOT COS2
#' @include AllGenerics.R
NULL

#' @export
#' @rdname viz_contributions
#' @aliases viz_cos2,MultivariateAnalysis-method
setMethod(
  f = "viz_cos2",
  signature = c(x = "MultivariateAnalysis"),
  definition = function(x, ..., margin = 2, axes = 1, active = TRUE,
                        sup = TRUE, sort = TRUE, decreasing = TRUE,
                        limit = 10, horiz = FALSE,
                        col = "grey90", border = "grey10") {
    ## Prepare data
    data <- prepare_cos2(x, margin = margin, axes = axes,
                         active = active, sup = sup, sort = sort,
                         decreasing = decreasing, limit = limit)

    xx <- paste0("(F", axes, ")", collapse = "-")
    ylab <- bquote(paste(plain(cos)^2~.(xx)))

    ## Bar plot
    mid <- graphics::barplot(
      height = data$y,
      names.arg = data$x,
      horiz = horiz,
      xlab = if (horiz) ylab else NULL,
      ylab = if (horiz) NULL else ylab,
      col = col,
      border = border,
      las = 1,
      ...
    )

    invisible(x)
  }
)

# Must return a data.frame (`x`, `y`, `label`)
prepare_cos2 <- function(object, margin, axes, active = TRUE, sup = TRUE,
                         sort = TRUE, decreasing = TRUE, limit = 10) {
  ## Get data
  cos2 <- get_cos2(object, margin = margin)
  if (length(axes) > 1) {
    values <- joint_cos2(object, margin = margin, axes = axes)
  } else {
    values <- cos2[[axes[[1]]]]
  }

  ## Prepare data
  data <- data.frame(
    x = rownames(cos2),
    y = values,
    label = round(values, digits = 2)
  )

  ## Subset
  if (!active & sup) data <- data[cos2$.sup, ]
  if (active & !sup) data <- data[!cos2$.sup, ]

  ## Sort data
  if (sort) {
    data <- data[order(data$y, decreasing = decreasing), ]
  }

  ## Subset
  if (!is.null(limit)) {
    limit <- min(nrow(data), limit)
    data <- data[seq_len(limit), , drop = FALSE]
  }

  ## Prevent reordering
  data$x <- factor(data$x, levels = unique(data$x))

  data
}

# MULTIPLE CORRESPONDENCE ANALYSIS
#' @include AllGenerics.R
NULL

#' @export
#' @rdname mca
#' @aliases mca,data.frame-method
setMethod(
  f = "mca",
  signature = c(object = "data.frame"),
  definition = function(object, rank = NULL, sup_row = NULL, sup_col = NULL,
                        sup_quanti = NULL, autodetect = FALSE) {
    ## Remove numeric variables, if any
    clean <- drop_variable(object, f = is.numeric, negate = FALSE,
                           sup = sup_col, extra = sup_quanti, auto = autodetect,
                           what = "quantitative")

    ## Compute MCA
    results <- methods::callGeneric(object = clean$data, rank = rank,
                                    sup_row = sup_row, sup_col = clean$sup)

    ## Add supplementary quantitative variables
    if (!is.null(clean$extra)) set_extra(results) <- clean$extra

    results
  }
)

#' @export
#' @rdname mca
#' @aliases mca,matrix-method
setMethod(
  f = "mca",
  signature = c(object = "matrix"),
  definition = function(object, rank = NULL, sup_row = NULL, sup_col = NULL) {
    ## Subset
    is_row_sup <- find_variable(sup_row, nrow(object), names = rownames(object))
    is_col_sup <- find_variable(sup_col, ncol(object), names = colnames(object))
    N <- object[, !is_col_sup, drop = FALSE]

    ## Complete disjunctive table
    Z <- cdt(N)

    ## Check missing values
    arkhe::assert_missing(Z)

    ## Get supplementary columns
    Z_tot <- Z
    sup_col <- NULL
    if (any(is_col_sup)) {
      Z_sup <- cdt(object[, is_col_sup, drop = FALSE])
      Z_tot <- cbind(Z, Z_sup)
      sup_col <- seq_len(ncol(Z_sup)) + ncol(Z)
    }

    ## Compute
    ndim <- min(rank, ncol(Z_tot) - sum(!is_col_sup))
    results <- ca(Z_tot, rank = ndim, sup_row = sup_row, sup_col = sup_col)

    .MCA(results)
  }
)

# TIDY DATA
#' @include AllGenerics.R
NULL

#' @export
#' @rdname tidy
#' @aliases tidy,MultivariateAnalysis-method
setMethod(
  f = "tidy",
  signature = c(x = "MultivariateAnalysis"),
  definition = function(x, ..., margin = 1, principal = TRUE) {
    ## Validation
    arkhe::assert_length(margin, 1)

    ## Get data
    coords <- get_coordinates(x, margin = margin, principal = principal)
    coords_long <- cbind(rownames(coords), coords[, ncol(coords)],
                         utils::stack(coords[, -ncol(coords)]))
    colnames(coords_long) <- c("label", "supplementary", "coordinate", "component")

    contrib <- get_contributions(x, margin = margin)
    contrib_long <- cbind(rownames(contrib), utils::stack(contrib))
    colnames(contrib_long) <- c("label", "contribution", "component")

    cos2 <- get_cos2(x, margin = margin)
    cos2_long <- cbind(rownames(cos2), utils::stack(cos2[, -ncol(cos2)]))
    colnames(cos2_long) <- c("label", "cos2", "component")

    ## Join data
    Reduce(
      f = function(df1, df2) {
        merge(df1, df2, by = c("label", "component"), all = TRUE, sort = TRUE)
      },
      x = list(coords_long, contrib_long, cos2_long)
    )
  }
)

# PRINCIPAL COORDINATES ANALYSIS
#' @include AllGenerics.R
NULL

#' @export
#' @rdname pcoa
#' @aliases pcoa,dist-method
setMethod(
  f = "pcoa",
  signature = c(object = "dist"),
  definition = function(object, rank = 2) {
    ## Multidimensional scaling
    res <- stats::cmdscale(
      d = object,
      k = rank,
      eig = TRUE,
      add = FALSE,
      list. = TRUE
    )

    points <- res$points
    colnames(points) <- paste0("F", seq_len(NCOL(points)))

    .PCOA(
      points = points,
      eigenvalues = res$eig,
      GOF= res$GOF,
      method = attr(object, "method") %||% character(0)
    )
  }
)

# GET VARIANCE
#' @include AllGenerics.R
NULL

#' @export
#' @rdname get_eigenvalues
#' @aliases get_variance,MultivariateAnalysis-method
setMethod(
  f = "get_variance",
  signature = c(x = "MultivariateAnalysis"),
  definition = function(x, digits = 2) {
    eig <- x@singular_values^2
    pc <- round(eig / sum(eig) * 100, digits = digits)
    return(pc)
  }
)

# GET DATA
#' @include AllGenerics.R
NULL

#' @export
#' @rdname get_data
#' @aliases get_data,MultivariateAnalysis-method
setMethod(
  f = "get_data",
  signature = c(x = "MultivariateAnalysis"),
  definition = function(x) {
    as.data.frame(x@data)
  }
)

# Supplementary variables ======================================================
is_supplementary <- function(x, margin = 1) {
  margin <- margin[[1L]]
  if (margin == 1) supp <- x@rows@supplement
  if (margin == 2) supp <- x@columns@supplement
  supp
}

has_supplementary <- function(x, margin = 1) {
  any(is_supplementary(x, margin = margin))
}

get_extra <- function(x) {
  as.data.frame(x@extra)
}

has_extra <- function(x) {
  all(lengths(x@extra) > 0)
}

`set_extra<-` <- function(x, value) {
  value <- lapply(
    X = value,
    FUN = function(val, i) { val[i] },
    i = get_order(x, margin = 1)
  )
  x@extra <- value
  methods::validObject(x)
  x
}

# GET CONTRIBUTIONS
#' @include AllGenerics.R
NULL

#' @export
#' @rdname get_contributions
#' @aliases get_contributions,MultivariateAnalysis-method
setMethod(
  f = "get_contributions",
  signature = c(x = "MultivariateAnalysis"),
  definition = function(x, margin = 1) {
    arkhe::assert_scalar(margin, "numeric")

    if (margin == 1) contrib <- x@rows@contributions
    if (margin == 2) contrib <- x@columns@contributions

    as.data.frame(contrib)
  }
)

# GET COS2
#' @include AllGenerics.R
NULL

#' @export
#' @rdname get_contributions
#' @aliases get_cos2,MultivariateAnalysis-method
setMethod(
  f = "get_cos2",
  signature = c(x = "MultivariateAnalysis"),
  definition = function(x, margin = 1, sup_name = ".sup") {
    arkhe::assert_scalar(margin, "numeric")
    arkhe::assert_scalar(sup_name, "character")

    if (margin == 1) {
      cos2 <- x@rows@cosine
      suppl <- x@rows@supplement
    }
    if (margin == 2) {
      cos2 <- x@columns@cosine
      suppl <- x@columns@supplement
    }

    cos2 <- as.data.frame(cos2)
    cos2[[sup_name]] <- suppl

    cos2
  }
)

# COERCE
#' @include AllGenerics.R
NULL

# To data.frame ================================================================
#' @export
#' @method as.data.frame MultivariateSummary
as.data.frame.MultivariateSummary <- function(x, row.names = NULL, optional = FALSE, ...) {
  as.data.frame(x@results, row.names = row.names, optional = optional, ...)
}

#' @export
#' @rdname summary
#' @aliases as.data.frame,MultivariateSummary-method
setMethod("as.data.frame", "MultivariateSummary", as.data.frame.MultivariateSummary)

# To list ======================================================================
#' @method as.list MultivariateResults
as.list.MultivariateResults <- function(x, ...) {
  list(
    # names = x@names,
    coordinates = x@principal,
    # standard = x@standard,
    contributions = x@contributions,
    cos2 = x@cosine,
    # distances = x@distances,
    masses = x@weights,
    supplement = x@supplement
  )
}

#' @method as.list MultivariateAnalysis
#' @export
as.list.MultivariateAnalysis <- function(x, ...) {
  list(
    data = x@data,
    rows = as.list(x@rows),
    columns = as.list(x@columns),
    eigenvalues = x@singular_values^2
  )
}

# SUBSET
#' @include AllGenerics.R
NULL

#' @export
#' @rdname subset
#' @aliases [[,CA,ANY,missing-method
setMethod(
  f = "[[",
  signature = c(x = "CA", i = "ANY", j = "missing"),
  definition = function(x, i) {
    data <- as.list(x)
    methods::callGeneric(x = data, i = i)
  }
)

#' @export
#' @rdname subset
#' @aliases [[,PCA,ANY,missing-method
setMethod(
  f = "[[",
  signature = c(x = "PCA", i = "ANY", j = "missing"),
  definition = function(x, i) {
    data <- as.list(x)
    data[[1]] <- list(
      data = x@data,
      mean = x@center,
      sd = x@scale
    )
    data[[3]][["cor"]] <- sqrt(x@columns@cosine)
    methods::callGeneric(x = data, i = i)
  }
)

1		# PRINCIPAL COMPONENTS ANALYSIS
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname pca
7		#' @aliases pca,data.frame-method
8		setMethod(
9		f = "pca",
10		signature = c(object = "data.frame"),
11		definition = function(object, center = TRUE, scale = TRUE, rank = NULL,
12		sup_row = NULL, sup_col = NULL, sup_quali = NULL,
13		weight_row = NULL, weight_col = NULL, autodetect = FALSE) {
14		## Remove non-numeric variables, if any
15	10x	clean <- drop_variable(object, f = is.numeric, negate = TRUE,
16	10x	sup = sup_col, extra = sup_quali,
17	10x	auto = autodetect, what = "qualitative")
18
19		## Compute PCA
20	10x	results <- methods::callGeneric(
21	10x	object = clean$data, center = center, scale = scale,
22	10x	rank = rank, sup_row = sup_row, sup_col = clean$sup,
23	10x	weight_row = weight_row, weight_col = weight_col
24		)
25
26		## Add supplementary quantitative variables
27	4x	if (!is.null(clean$extra)) set_extra(results) <- clean$extra
28
29	9x	results
30		}
31		)
32
33		#' @export
34		#' @rdname pca
35		#' @aliases pca,matrix-method
36		setMethod(
37		f = "pca",
38		signature = c(object = "matrix"),
39		definition = function(object, center = TRUE, scale = TRUE, rank = NULL,
40		sup_row = NULL, sup_col = NULL,
41		weight_row = NULL, weight_col = NULL) {
42		# Fix dimension names
43	12x	names_row <- rownames(object)
44	12x	names_col <- colnames(object)
45	7x	if (is.null(names_row)) names_row <- as.character(seq_len(nrow(object)))
46	2x	if (is.null(names_col)) names_col <- as.character(seq_len(ncol(object)))
47
48		# Subset
49	12x	is_row_sup <- find_variable(sup_row, nrow(object), names = rownames(object))
50	12x	is_col_sup <- find_variable(sup_col, ncol(object), names = colnames(object))
51	12x	N <- object[!is_row_sup, !is_col_sup, drop = FALSE]
52
53		## Check missing values
54	12x	arkhe::assert_missing(N)
55
56		## Check dimensions
57	11x	arkhe::assert_filled(N)
58
59		# Dimension of the solution
60	11x	ndim <- min(rank, dim(N) - 1)
61	11x	i <- nrow(N)
62	11x	j <- ncol(N)
63
64		# Weights
65	11x	w_row <- if (is.null(weight_row)) rep(1, nrow(N)) else weight_row
66	11x	w_col <- if (is.null(weight_col)) rep(1, ncol(N)) else weight_col
67	11x	w_row <- w_row / sum(w_row)
68
69		# Build matrix
70	11x	s_row <- sqrt(w_row)
71	11x	s_col <- sqrt(w_col)
72	11x	W_row1 <- matrix(s_row, nrow = i, ncol = j, byrow = FALSE)
73	11x	W_col1 <- matrix(s_col, nrow = i, ncol = j, byrow = TRUE)
74	11x	W_row2 <- matrix(s_row, nrow = i, ncol = ndim, byrow = FALSE)
75	11x	W_col2 <- matrix(s_col, nrow = j, ncol = ndim, byrow = FALSE)
76
77		# Center data
78	11x	if (center) {
79	10x	var_mean <- weighted_mean(N, w_row)
80		} else {
81	1x	var_mean <- rep(0, j)
82		}
83	11x	ctr <- matrix(var_mean, nrow = i, ncol = j, byrow = TRUE)
84	11x	P <- N - ctr
85
86		# Scale data
87	11x	if (scale) {
88	6x	var_sd <- weighted_sd(P, w_row)
89		} else {
90	5x	var_sd <- rep(1, j)
91		}
92	11x	std <- matrix(var_sd, nrow = i, ncol = j, byrow = TRUE)
93	11x	M <- P / std
94
95		# Matrix of standardized residuals
96	11x	S <- M * W_col1 * W_row1
97
98		# Singular Value Decomposition
99	11x	D <- svd2(S, ndim)
100	11x	sv <- D$d # Singular values
101
102		# Standard coordinates
103	11x	U <- D$u / W_row2
104	11x	V <- D$v / W_col2
105
106	11x	sv_U <- matrix(sv, nrow = i, ncol = ndim, byrow = TRUE)
107	11x	sv_V <- matrix(sv, nrow = j, ncol = ndim, byrow = TRUE)
108
109		# Principal coordinates
110	11x	coord_row <- U * sv_U
111	11x	coord_col <- V * sv_V
112
113		# Contributions
114	11x	contrib_row <- ((coord_row * W_row2) / sv_U)^2 * 100
115	11x	contrib_col <- ((coord_col * W_col2) / sv_V)^2 * 100
116
117		# Squared distance to centroide
118	11x	dist_row <- rowSums((M * W_col1)^2)
119	11x	dist_col <- colSums((M * W_row1)^2)
120
121		# Supplementary points
122	11x	if (any(is_row_sup)) {
123	3x	extra_row <- object[is_row_sup, !is_col_sup, drop = FALSE]
124	3x	ind_sup <- (t(extra_row) - var_mean) * w_col / var_sd
125
126		# Coordinates
127	3x	coord_row_sup <- crossprod(ind_sup, V)
128	3x	coord_row <- rbind(coord_row, coord_row_sup)
129
130		# Distances
131	3x	dist_row_sup <- colSums(ind_sup^2 * w_col)
132	3x	dist_row <- c(dist_row, dist_row_sup)
133		}
134	11x	if (any(is_col_sup)) {
135	2x	extra_col <- object[!is_row_sup, is_col_sup, drop = FALSE]
136		# Center and scale
137	2x	if (center) {
138	2x	extra_col <- t(t(extra_col) - weighted_mean(extra_col, w_row))
139		}
140	2x	if (scale) {
141	1x	extra_col <- t(t(extra_col) / weighted_sd(extra_col, w_row))
142		}
143	2x	var_sup <- extra_col * w_row
144
145		# Coordinates
146	2x	coord_col_sup <- crossprod(var_sup, U)
147	2x	coord_col <- rbind(coord_col, coord_col_sup)
148
149		# Distances
150	2x	dist_col_sup <- colSums(extra_col^2 * w_row)
151	2x	dist_col <- c(dist_col, dist_col_sup)
152		}
153
154		# Squared cosine
155	11x	cos_row <- coord_row^2 / dist_row
156	11x	cos_col <- coord_col^2 / dist_col
157
158		# names(sv) <- paste0("F", dim_keep)
159	11x	.PCA(
160	11x	data = object,
161	11x	dimension = as.integer(ndim),
162	11x	singular_values = sv,
163	11x	rows = build_results(
164	11x	names = names_row,
165	11x	principal = coord_row,
166	11x	standard = U,
167	11x	contributions = contrib_row,
168	11x	distances = sqrt(dist_row),
169	11x	cosine = cos_row,
170	11x	weights = w_row,
171	11x	supplement = is_row_sup
172		),
173	11x	columns = build_results(
174	11x	names = names_col,
175	11x	principal = coord_col,
176	11x	standard = V,
177	11x	contributions = contrib_col,
178	11x	distances = sqrt(dist_col),
179	11x	cosine = cos_col,
180	11x	weights = w_col,
181	11x	supplement = is_col_sup
182		),
183	11x	center = var_mean,
184	11x	scale = var_sd
185		)
186		}
187		)

1		# CORRESPONDENCE ANALYSIS
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname ca
7		#' @aliases ca,data.frame-method
8		setMethod(
9		f = "ca",
10		signature = c(object = "data.frame"),
11		definition = function(object, rank = NULL, sup_row = NULL, sup_col = NULL,
12		sup_quali = NULL, autodetect = FALSE) {
13		## Remove non-numeric variables, if any
14	11x	clean <- drop_variable(object, f = is.numeric, negate = TRUE,
15	11x	sup = sup_col, extra = sup_quali,
16	11x	auto = autodetect, what = "qualitative")
17		## Compute PCA
18	11x	results <- methods::callGeneric(
19	11x	object = clean$data, rank = rank,
20	11x	sup_row = sup_row, sup_col = clean$sup
21		)
22
23		## Add supplementary quantitative variables
24	!	if (!is.null(clean$extra)) set_extra(results) <- clean$extra
25
26	9x	results
27		}
28		)
29
30		#' @export
31		#' @rdname ca
32		#' @aliases ca,matrix-method
33		setMethod(
34		f = "ca",
35		signature = c(object = "matrix"),
36		definition = function(object, rank = NULL, sup_row = NULL, sup_col = NULL) {
37		## Fix dimension names
38	17x	names_row <- rownames(object)
39	17x	names_col <- colnames(object)
40	3x	if (is.null(names_row)) names_row <- as.character(seq_len(nrow(object)))
41	2x	if (is.null(names_col)) names_col <- as.character(seq_len(ncol(object)))
42
43		## Subset
44	17x	is_row_sup <- find_variable(sup_row, nrow(object), names = rownames(object))
45	17x	is_col_sup <- find_variable(sup_col, ncol(object), names = colnames(object))
46	17x	N <- object[!is_row_sup, !is_col_sup, drop = FALSE]
47
48		## Check missing values
49	17x	arkhe::assert_missing(N)
50
51		## Check dimensions
52	17x	arkhe::assert_filled(N)
53
54		## Dimension of the solution
55	17x	ndim <- min(rank, dim(N) - 1)
56	17x	i <- nrow(N)
57	17x	j <- ncol(N)
58
59		## Grand total
60	17x	total <- sum(N, na.rm = FALSE)
61		## Relative frequencies
62	17x	P <- N / total
63
64		## Calcul des marges
65	17x	w_row <- rowSums(P, na.rm = FALSE)
66	17x	w_col <- colSums(P, na.rm = FALSE)
67
68		## /!\ Important: we need to clean the data before processing
69		## Empty rows/columns must be removed to avoid error in svd()
70	17x	if (any(w_row == 0))
71	1x	stop(tr_("Empty rows detected."), call. = FALSE)
72	16x	if (any(w_col == 0))
73	1x	stop(tr_("Empty columns detected."), call. = FALSE)
74
75		## Build matrix
76		## matrix * vector is faster (!) than:
77		# matrix %*% t(vector)
78		# t(t(matrix) * vector)
79	15x	s_row <- sqrt(w_row)
80	15x	s_col <- sqrt(w_col)
81	15x	W_row1 <- matrix(s_row, nrow = i, ncol = j, byrow = FALSE)
82	15x	W_col1 <- matrix(s_col, nrow = i, ncol = j, byrow = TRUE)
83	15x	W_row2 <- matrix(s_row, nrow = i, ncol = ndim, byrow = FALSE)
84	15x	W_col2 <- matrix(s_col, nrow = j, ncol = ndim, byrow = FALSE)
85
86		## Calcul des écarts à l'indépendance
87	15x	M <- P - tcrossprod(w_row, w_col)
88
89		## Matrix of standardized residuals
90	15x	S <- M / W_row1 / W_col1
91
92		## Singular Value Decomposition
93	15x	D <- svd2(S, ndim)
94	15x	sv <- D$d # Singular values
95
96		## Standard coordinates
97	15x	U <- D$u / W_row2
98	15x	V <- D$v / W_col2
99
100	15x	sv_U <- matrix(sv, nrow = i, ncol = ndim, byrow = TRUE)
101	15x	sv_V <- matrix(sv, nrow = j, ncol = ndim, byrow = TRUE)
102
103		## Principal coordinates
104	15x	coord_row <- U * sv_U
105	15x	coord_col <- V * sv_V
106
107		## Contributions
108	15x	contrib_row <- ((coord_row * W_row2) / sv_U)^2 * 100
109	15x	contrib_col <- ((coord_col * W_col2) / sv_V)^2 * 100
110
111		## Squared distance to centroide
112	15x	dist_row <- rowSums(S^2) / w_row
113	15x	dist_col <- colSums(S^2) / w_col
114
115		## Supplementary points
116	15x	if (any(is_row_sup)) {
117	4x	extra_row <- object[is_row_sup, !is_col_sup, drop = FALSE]
118	4x	row_sup <- t(extra_row / rowSums(extra_row))
119
120		## Coordinates
121	4x	coord_row_sup <- crossprod(row_sup, V)
122	4x	coord_row <- rbind(coord_row, coord_row_sup)
123
124		## Distances
125	4x	dist_row_sup <- colSums((row_sup - w_col)^2 / w_col)
126	4x	dist_row <- c(dist_row, dist_row_sup)
127		}
128	15x	if (any(is_col_sup)) {
129	3x	extra_col <- object[!is_row_sup, is_col_sup, drop = FALSE]
130	3x	col_sup <- t(t(extra_col) / colSums(extra_col))
131
132		## Coordinates
133	3x	coord_col_sup <- crossprod(col_sup, U)
134	3x	coord_col <- rbind(coord_col, coord_col_sup)
135
136		## Distances
137	3x	dist_col_sup <- colSums((col_sup - w_row)^2 / w_row)
138	3x	dist_col <- c(dist_col, dist_col_sup)
139		}
140
141		## Squared cosine
142	15x	cos_row <- coord_row^2 / dist_row
143	15x	cos_col <- coord_col^2 / dist_col
144
145	15x	.CA(
146	15x	data = object,
147	15x	dimension = as.integer(ndim),
148	15x	singular_values = sv,
149	15x	rows = build_results(
150	15x	names = names_row,
151	15x	principal = coord_row,
152	15x	standard = U,
153	15x	contributions = contrib_row,
154	15x	distances = dist_row,
155	15x	cosine = cos_row,
156	15x	weights = w_row,
157	15x	supplement = is_row_sup
158		),
159	15x	columns = build_results(
160	15x	names = names_col,
161	15x	principal = coord_col,
162	15x	standard = V,
163	15x	contributions = contrib_col,
164	15x	distances = dist_col,
165	15x	cosine = cos_col,
166	15x	weights = w_col,
167	15x	supplement = is_col_sup
168		)
169		)
170		}
171		)

1		# SUMMARY
2		#' @include AllGenerics.R
3		NULL
4
5		# CA ===========================================================================
6		#' @export
7		#' @method summary CA
8		summary.CA <- function(object, ..., axes = c(1, 2), margin = 1,
9		active = TRUE, sup = TRUE, rank = NULL) {
10		## Get data
11	3x	values <- build_summary(object, axes = axes, margin = margin, rank = rank,
12	3x	active = active, sup = sup)
13
14	3x	.SummaryCA(
15	3x	data = object@data,
16	3x	eigenvalues = values$eigenvalues,
17	3x	results = values$results,
18	3x	supplement = values$supplement,
19	3x	margin = as.integer(margin)
20		)
21		}
22
23		#' @export
24		#' @rdname summary
25		#' @aliases summary,CA-method
26		setMethod("summary", c(object = "CA"), summary.CA)
27
28		#' @export
29		#' @rdname describe
30		#' @aliases describe,CA-method
31		setMethod(
32		f = "describe",
33		signature = signature(x = "CA"),
34		definition = function(x, ...) {
35	2x	row_sup <- x@rows@supplement
36	2x	col_sup <- x@columns@supplement
37
38	2x	sup_txt <- tr_(" (+ %d supplementary)")
39	2x	row_txt <- if (any(row_sup)) sprintf(sup_txt, sum(row_sup)) else ""
40	2x	col_txt <- if (any(col_sup)) sprintf(sup_txt, sum(col_sup)) else ""
41
42	2x	cat(
43	2x	sprintf(tr_("* Row variable: %d categories%s."), sum(!row_sup), row_txt),
44	2x	sprintf(tr_("* Column variable: %d categories%s."), sum(!col_sup), col_txt),
45		...,
46	2x	sep = "\n"
47		)
48	2x	invisible(x)
49		}
50		)
51
52		# PCA ==========================================================================
53		#' @export
54		#' @method summary PCA
55		summary.PCA <- function(object, ..., axes = c(1, 2), margin = 1,
56		active = TRUE, sup = TRUE, rank = NULL) {
57		## Get data
58	3x	values <- build_summary(object, axes = axes, margin = margin, rank = rank,
59	3x	active = active, sup = sup)
60
61	3x	.SummaryPCA(
62	3x	data = object@data,
63	3x	eigenvalues = values$eigenvalues,
64	3x	results = values$results,
65	3x	supplement = values$supplement,
66	3x	margin = as.integer(margin)
67		)
68		}
69
70		#' @export
71		#' @rdname summary
72		#' @aliases summary,PCA-method
73		setMethod("summary", c(object = "PCA"), summary.PCA)
74
75		#' @export
76		#' @rdname describe
77		#' @aliases describe,PCA-method
78		setMethod(
79		f = "describe",
80		signature = signature(x = "PCA"),
81		definition = function(x, ...) {
82	1x	row_sup <- x@rows@supplement
83	1x	col_sup <- x@columns@supplement
84
85	1x	sup_txt <- tr_(" (+ %d supplementary)")
86	1x	row_txt <- if (any(row_sup)) sprintf(sup_txt, sum(row_sup)) else ""
87	1x	col_txt <- if (any(col_sup)) sprintf(sup_txt, sum(col_sup)) else ""
88
89	1x	if (is_centered(x)) {
90	1x	var_center <- tr_("* Variables were shifted to be zero centered.")
91		} else {
92	!	var_center <- tr_("* Variables were NOT shifted to be zero centered.")
93		}
94	1x	if (is_scaled(x)) {
95	!	var_scale <- tr_("* Variables were scaled to unit variance.")
96		} else {
97	1x	var_scale <- tr_("* Variables were NOT scaled to unit variance.")
98		}
99
100	1x	cat(
101	1x	sprintf(tr_("* %d individuals%s."), sum(!row_sup), row_txt),
102	1x	sprintf(tr_("* %d variables%s."), sum(!col_sup), col_txt),
103	1x	var_center,
104	1x	var_scale,
105		...,
106	1x	sep = "\n"
107		)
108	1x	invisible(x)
109		}
110		)
111
112		# Helpers ======================================================================
113		build_summary <- function(object, axes, margin, rank = NULL,
114		active = TRUE, sup = TRUE,
115		prefix = "F") {
116		## Validation
117	6x	arkhe::assert_filled(axes)
118	6x	arkhe::assert_type(axes, "numeric")
119
120		## /!\ Backward compatibility /!\
121	6x	if (!is.null(rank)) {
122	!	axes <- seq_len(rank)
123	!	msg <- "'rank' argument is deprecated, use 'axes' instead."
124	!	warning(msg, call. = FALSE)
125		}
126
127		## Get data
128	6x	eig <- get_eigenvalues(object)
129	6x	inertia <- get_distances(object, margin = margin)
130	6x	coord <- get_coordinates(object, margin = margin)
131	6x	contrib <- get_contributions(object, margin = margin)
132	6x	cos2 <- get_cos2(object, margin = margin)
133
134	3x	if (inherits(object, "CA")) inertia <- inertia * 1000
135
136		## Fix lengths
137	6x	n <- nrow(coord)
138	6x	m <- nrow(contrib)
139	6x	if (n > m) {
140	6x	length(inertia) <- n
141	6x	contrib[seq(m + 1, n, 1), ] <- NA
142		}
143
144		## Bind columns
145	6x	values <- vector(mode = "list", length = length(axes))
146	6x	for (j in axes) {
147	12x	v <- cbind(coord[[j]], contrib[[j]], cos2[[j]])
148	12x	colnames(v) <- paste0(prefix, j, c("_coord", "_contrib", "_cos2"))
149	12x	values[[j]] <- v
150		}
151	6x	values <- do.call(cbind, values)
152	6x	values <- cbind(inertia = inertia, values)
153	3x	if (inherits(object, "PCA")) colnames(values)[1] <- "dist"
154	6x	rownames(values) <- rownames(coord)
155
156		## Remove data
157	6x	is_sup <- coord$.sup
158	!	if (!active && !sup) active <- TRUE
159	6x	if (!active) {
160	2x	values <- values[is_sup, , drop = FALSE]
161	2x	is_sup <- is_sup[is_sup]
162		}
163	6x	if (!sup) {
164	2x	values <- values[!is_sup, , drop = FALSE]
165	2x	is_sup <- is_sup[!is_sup]
166		}
167
168	6x	list(
169	6x	eigenvalues = as.matrix(eig),
170	6x	results = as.matrix(values),
171	6x	supplement = is_sup
172		)
173		}

1		# PLOT CONVEX HULL
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname viz_hull
7		#' @aliases viz_hull,numeric,numeric-method
8		setMethod(
9		f = "viz_hull",
10		signature = c(x = "numeric", y = "numeric"),
11		definition = function(x, y, ..., group = NULL,
12		color = NULL, fill = FALSE, symbol = FALSE) {
13	!	hull <- wrap_hull(x, y, group = group)
14	!	.viz_hull(hull, color = color, fill = fill, symbol = symbol, ...)
15	!	invisible(list(x = x, y = y))
16		}
17		)
18
19		#' @export
20		#' @rdname viz_hull
21		#' @aliases viz_hull,MultivariateAnalysis,missing-method
22		setMethod(
23		f = "viz_hull",
24		signature = c(x = "MultivariateAnalysis", y = "missing"),
25		definition = function(x, ..., group = NULL,
26		color = NULL, fill = FALSE, symbol = FALSE) {
27	3x	hull <- wrap_hull(x, margin = get_margin(), axes = get_axes(),
28	3x	group = group, principal = get_principal())
29	3x	.viz_hull(hull, color = color, fill = fill, symbol = symbol, ...)
30	3x	invisible(x)
31		}
32		)
33
34		#' @export
35		#' @rdname viz_hull
36		#' @aliases viz_hull,MultivariateBootstrap,missing-method
37		setMethod(
38		f = "viz_hull",
39		signature = c(x = "MultivariateBootstrap", y = "missing"),
40		definition = function(x, ..., color = FALSE, fill = FALSE, symbol = FALSE) {
41	2x	hull <- wrap_hull(x, margin = get_margin(), axes = get_axes(),
42	2x	group = NULL, principal = get_principal())
43	2x	.viz_hull(hull, color = color, fill = fill, symbol = symbol, ...)
44	2x	invisible(x)
45		}
46		)
47
48		#' @export
49		#' @rdname viz_hull
50		#' @aliases viz_hull,PCOA,missing-method
51		setMethod(
52		f = "viz_hull",
53		signature = c(x = "PCOA", y = "missing"),
54		definition = function(x, ..., group = NULL,
55		color = FALSE, fill = FALSE, symbol = FALSE) {
56	1x	hull <- wrap_hull(x, axes = get_axes(), group = group)
57	1x	.viz_hull(hull, color = color, fill = fill, symbol = symbol, ...)
58	1x	invisible(x)
59		}
60		)
61
62		#' @param x A `list` of `matrix` returned by [wrap_hull()].
63		#' @noRd
64		.viz_hull <- function(x, ..., color = NULL, fill = FALSE, symbol = FALSE) {
65	6x	n <- length(x)
66
67		## Recycle graphical parameters if of length one
68	6x	dots <- list(...)
69	6x	col <- recycle(dots$border %\|\|% graphics::par("fg"), n)
70	6x	bg <- recycle(dots$col %\|\|% NA, n)
71	6x	lty <- recycle(dots$lty %\|\|% graphics::par("lty"), n)
72	6x	lwd <- recycle(dots$lwd %\|\|% graphics::par("lwd"), n)
73
74	6x	if (n > 1) {
75		## Discrete scales
76	6x	extra_quali <- names(x)
77	6x	if (is.null(dots$border) && !isFALSE(color))
78	6x	col <- khroma::palette_color_discrete(color)(extra_quali)
79	6x	if (is.null(dots$col) && !isFALSE(fill))
80	!	bg <- khroma::palette_color_discrete(fill)(extra_quali)
81	6x	if (is.null(dots$lty) && !isFALSE(symbol))
82	!	lty <- khroma::palette_line(symbol)(extra_quali)
83		}
84
85	6x	for (i in seq_along(x)) {
86	20x	graphics::polygon(
87	20x	x = x[[i]],
88	20x	border = col[i],
89	20x	col = bg[i],
90	20x	lty = lty[i],
91	20x	lwd = lwd[i]
92		)
93		}
94		}

1		# REPELLING LABELS
2
3		# Text =========================================================================
4		#' Non-Overlapping Text Labels
5		#'
6		#' Optimize the location of text labels to minimize overplotting text.
7		#' @param x,y A [`numeric`] vector giving the x and y coordinates of a set of
8		#' points. If `y` is `NULL`, an attempt is made to interpret `x` in a suitable
9		#' way (see [grDevices::xy.coords()]).
10		#' @param labels A [`character`] vector or [`expression`] specifying the text
11		#' to be written.
12		#' @param type A [`character`] string specifying the shape of the field.
13		#' It must be one of "`text`", "`shadow`" or "`box`". Any unambiguous substring
14		#' can be given.
15		#' @param ... Further arguments to be passed to [graphics::text()],
16		#' particularly, character expansion, `cex` and color, `col`.
17		#' @return
18		#' `label()` is called it for its side-effects: it results in a graphic
19		#' being displayed.
20		#' @seealso [graphics::text()]
21		#' @source
22		#' This function is modeled after [car::pointLabel()] (originally from the
23		#' \pkg{maptools} package).
24		#' @author N. Frerebeau
25		#' @family annotations
26		#' @keywords internal
27		#' @export
28		label <- function(x, y = NULL, labels = seq_along(x$x),
29		type = c("text", "shadow", "box"), ...) {
30		## Validation
31	!	type <- match.arg(type, several.ok = FALSE)
32	!	x <- grDevices::xy.coords(x = x, y = y)
33
34	!	labels <- grDevices::as.graphicsAnnot(labels)
35	!	if (length(labels) < length(x$x)) labels <- rep(labels, length(x$x))
36
37		## Compute label positions
38	!	labs <- compute_labels(x = x$x, y = x$y, labels = labels)
39
40		## Draw labels
41	!	fun <- switch(
42	!	type,
43	!	text = graphics::text,
44	!	shadow = text_shadow,
45	!	box = text_box
46		)
47	!	fun(labs, labels = labels, ...)
48
49	!	invisible(labs)
50		}
51
52		# Adapted from car::pointLabel()
53		compute_labels <- function(x, y, labels, ..., iter = 50,
54		cex = graphics::par("cex"),
55		font = NULL, vfont = NULL) {
56		## Coordinates
57	!	bound <- graphics::par("usr")
58	!	ratio <- graphics::par("pin")[1] / graphics::par("pin")[2] # x/y ratio
59
60	!	to_unity <- function(x, y) {
61	!	list(x = (x - bound[1]) / (bound[2] - bound[1]) * ratio,
62	!	y = (y - bound[3]) / (bound[4] - bound[3]) / ratio)
63		}
64	!	to_usr <- function(x, y) {
65	!	list(x = bound[1] + x / ratio * (bound[2] - bound[1]),
66	!	y = bound[3] + y * ratio * (bound[4] - bound[3]))
67		}
68
69	!	xy <- to_unity(x = x, y = y)
70	!	x <- xy$x
71	!	y <- xy$y
72	!	n <- length(x)
73
74		## 8 positions: corners and side mid-points of the rectangle
75		## Position 7 (top right) is the most preferred
76	!	width <- graphics::strwidth(labels, units = "figure", cex = cex,
77	!	font = font, vfont = vfont)
78	!	height <- graphics::strheight(labels, units = "figure", cex = cex,
79	!	font = font, vfont = vfont)
80	!	width <- (width + 0.02) * ratio
81	!	height <- (height + 0.02) / ratio
82
83	!	makeoff <- function(pos) {
84	!	c(-1, -1, -1, 0, 0, 1, 1, 1)[pos] * (width / 2) +
85	!	1i * c(-1, 0, 1, -1, 1, -1, 0, 1)[pos] * (height / 2)
86		}
87
88		## Find intersection area of two rectangles
89	!	overlap <- function(xy1, off1, xy2, off2) {
90	!	w <- pmin(Re(xy1 + off1 / 2), Re(xy2 + off2 / 2)) -
91	!	pmax(Re(xy1 - off1 / 2), Re(xy2 - off2 / 2))
92	!	h <- pmin(Im(xy1 + off1 / 2), Im(xy2 + off2 / 2)) -
93	!	pmax(Im(xy1 - off1 / 2), Im(xy2 - off2 / 2))
94	!	w[w <= 0] <- 0
95	!	h[h <= 0] <- 0
96	!	w * h
97		}
98
99	!	objective <- function(gene) {
100	!	offset <- makeoff(gene)
101
102	!	if (!is.null(rectidx1)) {
103	!	area <- sum(overlap(xy[rectidx1] + offset[rectidx1], rectv[rectidx1],
104	!	xy[rectidx2] + offset[rectidx2], rectv[rectidx2]))
105		} else {
106	!	area <- 0
107		}
108
109		## Penalize labels which go outside the image area
110		## Count points outside of the image
111	!	a <- Re(xy + offset - rectv / 2) < 0 \| Re(xy + offset + rectv / 2) > ratio
112	!	b <- Im(xy + offset - rectv / 2) < 0 \| Im(xy + offset + rectv / 2) > 1 / ratio
113	!	outside <- sum(a \| b)
114	!	res <- 1000 * area + outside
115	!	res
116		}
117
118		# Make a list of label rectangles in their reference positions,
119		# centered over the map feature; the real labels are displaced
120		# from these positions so as not to overlap
121		# Note that some labels can be bigger than others
122	!	xy <- x + 1i * y
123	!	rectv <- width + 1i * height
124
125	!	rectidx1 <- rectidx2 <- array(0, (length(x)^2 - length(x)) / 2)
126	!	k <- 0
127	!	for (i in seq_along(x))
128	!	for (j in seq_len(i - 1)) {
129	!	k <- k + 1
130	!	rectidx1[k] <- i
131	!	rectidx2[k] <- j
132		}
133	!	maylap <- overlap(xy[rectidx1], 2 * rectv[rectidx1],
134	!	xy[rectidx2], 2 * rectv[rectidx2]) > 0
135	!	rectidx1 <- rectidx1[maylap]
136	!	rectidx2 <- rectidx2[maylap]
137
138		## Simulated annealing
139		## Initial state
140	!	gene <- rep(8, n)
141	!	score <- objective(gene)
142		## Initial "best" solution
143	!	bestgene <- gene
144	!	bestscore <- score
145	!	iter <- seq_len(iter)
146	!	temp <- 2.5
147	!	for (i in iter) {
148	!	k <- 1 # Energy evaluation count
149	!	for (j in iter) {
150	!	newgene <- gene
151	!	newgene[sample(n, 1)] <- sample(8, 1)
152	!	newscore <- objective(newgene)
153	!	if (newscore <= score \|\| stats::runif(1) < exp((score - newscore) / temp)) {
154		## keep the new set if it has the same or better score or
155		## if it's worse randomly based on the annealing criteria
156	!	k <- k + 1
157	!	score <- newscore
158	!	gene <- newgene
159		}
160	!	if (score <= bestscore) {
161	!	bestscore <- score
162	!	bestgene <- gene
163		}
164	!	if (bestscore == 0 \|\| k == 10) break
165		}
166	!	if (bestscore == 0) break
167	!	temp <- 0.9 * temp
168		}
169
170	!	nx <- Re(xy + makeoff(bestgene))
171	!	ny <- Im(xy + makeoff(bestgene))
172
173	!	xy <- to_usr(x = nx, y = ny)
174	!	xy$labels <- labels
175	!	xy
176		}
177
178		#' Shadow Text
179		#'
180		#' @param x,y A [`numeric`] vector. If `y` is `NULL`, an attempt is made to
181		#' interpret `x` in a suitable way (see [grDevices::xy.coords()]).
182		#' @param labels A [`character`] vector specifying the text to be written.
183		#' @param width Thickness of the shadow, as a fraction of the plotting size.
184		#' @param theta Angles for plotting the background.
185		#' @param cex A [`numeric`] character expansion factor.
186		#' @param col The color to be used for the text.
187		#' @param bg The color to be used for the shadow.
188		#' @param font,vfont The font to be used (see [graphics::text()]).
189		#' @param ... Further parameters to be passed to [graphics::text()].
190		#' @return
191		#' `text_shadow()` is called it for its side-effects: it results in a graphic
192		#' being displayed.
193		#' @author N. Frerebeau
194		#' @family geometries
195		#' @keywords internal
196		#' @noRd
197		text_shadow <- function(x, y = NULL, labels = seq_along(x$x),
198		width = 1/10, theta = seq(0, 2 * pi, length.out = 50),
199		cex = graphics::par("cex"), col = graphics::par("fg"),
200		bg = graphics::par("bg"), font = NULL, vfont = NULL, ...) {
201
202	!	x <- grDevices::xy.coords(x = x, y = y)
203
204	!	xo <- width * graphics::strwidth("M", units = "user", cex = cex, font = font, vfont = vfont)
205	!	yo <- width * graphics::strheight("X", units = "user", cex = cex, font = font, vfont = vfont)
206
207	!	for (i in theta) {
208	!	graphics::text(x = x$x + cos(i) * xo, y = x$y + sin(i) * yo, labels = labels,
209	!	col = bg, cex = cex, font = font, vfont = vfont, ...)
210		}
211
212	!	graphics::text(x = x$x, y = x$y, labels = labels, col = col, cex = cex,
213	!	font = font, vfont = vfont, ...)
214
215	!	invisible(NULL)
216		}
217
218		#' Text with Halo Underneath
219		#'
220		#' @param x,y A [`numeric`] vector. If `y` is `NULL`, an attempt is made to
221		#' interpret `x` in a suitable way (see [grDevices::xy.coords()]).
222		#' @param labels A [`character`] vector specifying the text to be written.
223		#' @param padding A length-one [`numeric`] vector giving the amount of padding
224		#' around label.
225		#' @param rounding A length-one [`numeric`] vector giving the rounding of the
226		#' angles (see [rounded()]).
227		#' @param vertices A length-on [`integer`] vector specifying the number of
228		#' vertices to draw (see [rounded()]).
229		#' @param cex A numeric character expansion factor.
230		#' @param col The color to be used for the text.
231		#' @param bg The color to be used for the background.
232		#' @param font,vfont The font to be used (see [graphics::text()]).
233		#' @param ... Further parameters to be passed to [graphics::text()] (see details).
234		#' @details
235		#' Specifying `pos` and `offset` will currently change the position of the
236		#' text, but not of the field.
237		#' @return
238		#' `text_box()` is called it for its side-effects: it results in a graphic
239		#' being displayed.
240		#' @author N. Frerebeau
241		#' @family geometries
242		#' @keywords internal
243		#' @noRd
244		text_box <- function(x, y = NULL, labels = seq_along(x$x), padding = 1/3,
245		rounding = 0.2, vertices = 100,
246		cex = graphics::par("cex"), col = graphics::par("fg"),
247		bg = graphics::par("bg"), font = NULL, vfont = NULL, ...) {
248
249	!	x <- grDevices::xy.coords(x = x, y = y)
250	!	srt <- list(...)$srt %\|\|% graphics::par("srt")
251
252	!	em <- graphics::strwidth("M", units = "user", cex = cex, font = font, vfont = vfont)
253	!	ex <- graphics::strheight("X", units = "user", cex = cex, font = font, vfont = vfont)
254
255	!	xo <- padding * em
256	!	yo <- padding * ex
257
258	!	width <- graphics::strwidth(labels, units = "user", cex = cex, font = font, vfont = vfont)
259	!	height <- graphics::strheight(labels, units = "user", cex = cex, font = font, vfont = vfont)
260
261	!	.mapply(
262	!	FUN = function(x, y, w, h, r, n, col, border, rotate) {
263	!	rounded(
264	!	x0 = x - w - xo,
265	!	y0 = y - h - yo,
266	!	x1 = x + w + xo,
267	!	y1 = y + h + yo,
268	!	r = r,
269	!	n = n,
270	!	col = col,
271	!	border = border,
272	!	rotate = rotate,
273	!	aspect = TRUE
274		)
275		},
276	!	dots = list(x = x$x, y = x$y, w = width * 0.5, h = height * 0.5,
277	!	col = bg, border = col, rotate = srt),
278	!	MoreArgs = list(r = rounding, n = vertices)
279		)
280	!	graphics::text(x = x$x, y = x$y, labels = labels, col = col, cex = cex,
281	!	font = font, vfont = vfont, ...)
282
283	!	invisible(NULL)
284		}
285
286		# Shapes =======================================================================
287		#' Circle
288		#'
289		#' Draws a circle.
290		#' @param x,y A length-one [`numeric`] vector giving the coordinates of the
291		#' center of the circle.
292		#' @param radius A length-one [`numeric`] vector giving the radius of the
293		#' circle.
294		#' @param n A length-on [`integer`] vector specifying the number of vertices to
295		#' draw the circle.
296		#' @param ... Further parameters to be passed to [graphics::polygon()].
297		#' @return
298		#' `circle()` is called it for its side-effects: it results in a graphic
299		#' being displayed.
300		#' @author N. Frerebeau
301		#' @family shapes
302		#' @keywords internal
303		#' @noRd
304		circle <- function(x, y, radius, ..., n = 100) {
305	6x	angle.inc <- 2 * pi / n
306	6x	angles <- seq(0, 2 * pi - angle.inc, by = angle.inc)
307
308	6x	xv <- cos(angles) * radius + x
309	6x	yv <- sin(angles) * radius + y
310	6x	graphics::polygon(xv, yv, ...)
311		}
312
313		#' Rounded Rectangle
314		#'
315		#' Draws a rectangular box with rounded left and right edges.
316		#' @param x0,y0 A length-one [`numeric`] vector giving the coordinates of the
317		#' bottom left angle.
318		#' @param x1,y1 A length-one [`numeric`] vector giving the coordinates of the
319		#' top right angle.
320		#' @param r A length-one [`numeric`] vector giving the rounding of the edges.
321		#' @param n A length-on [`integer`] vector specifying the number of vertices to
322		#' draw.
323		#' @param rotate A [`numeric`] vector giving the angle of rotation, in degrees.
324		#' @param aspect A [`logical`] scalar: should the aspect ratio be kept during
325		#' rotation?
326		#' @param ... Further parameters to be passed to [graphics::polygon()].
327		#' @return
328		#' `rounded()` is called it for its side-effects: it results in a graphic
329		#' being displayed.
330		#' @author N. Frerebeau
331		#' @family shapes
332		#' @keywords internal
333		#' @noRd
334		rounded <- function(x0, y0, x1, y1, ..., r = 0.2, n = 100,
335		rotate = NULL, aspect = FALSE) {
336
337	!	XD <- YD <- min(c(x1 - x0, y1 - y0))
338	!	xi <- r * XD
339	!	yi <- r * YD
340
341		## Elliptic corners function
342	!	elx <- function(from, to) xi * cos(seq(from, to, length.out = n / 4))
343	!	ely <- function(from, to) yi * sin(seq(from, to, length.out = n / 4))
344
345		## Coordinates
346	!	x <- c(x1 - xi + elx(0, pi / 2),
347	!	x0 + xi + elx(pi / 2, pi),
348	!	x0 + xi + elx(pi, 3 * pi / 2),
349	!	x1 - xi + elx(3 * pi / 2, 2 * pi))
350	!	y <- c(y1 - yi + ely(0, pi / 2),
351	!	y1 - yi + ely(pi / 2, pi),
352	!	y0 + yi + ely(pi, 3 * pi / 2),
353	!	y0 + yi + ely(3 * pi / 2, 2 * pi))
354
355		## Rotate
356	!	xy <- list(x = x, y = y)
357	!	if (!is.null(rotate)) xy <- rotate(xy$x, xy$y, angle = rotate, aspect = aspect)
358
359	!	graphics::polygon(x = xy$x, y = xy$y, ...)
360		}
361
362		# Helpers ======================================================================
363		#' Rotation in Euclidean Space
364		#'
365		#' Rotates points in the `xy` plane counterclockwise.
366		#' @param x,y A [`numeric`] vector. If `y` is `NULL`, an attempt is made to
367		#' interpret `x` in a suitable way (see [grDevices::xy.coords()]).
368		#' @param angle A [`numeric`] vector giving the angle of rotation, in degrees.
369		#' @param center A length-two [`numeric`] vector giving the coordinates of the
370		#' rotation point. If `NULL`, defaults to centroid.
371		#' @param aspect A [`logical`] scalar: should aspect ratio be kept?
372		#' @return
373		#' Returns a [`list`] with two components `x` and `y`.
374		#' @example inst/examples/ex-rotate.R
375		#' @keywords internal
376		#' @noRd
377		rotate <- function(x, y = NULL, angle = 0, center = NULL, aspect = FALSE) {
378
379	!	xy <- grDevices::xy.coords(x = x, y = y)
380	!	if (is.null(center)) center <- c(mean(xy$x), mean(xy$y))
381
382	!	theta <- angle / 180 * pi
383	!	cos_theta <- cos(theta)
384	!	sin_theta <- sin(theta)
385
386	!	dx <- xy$x - center[[1L]]
387	!	dy <- xy$y - center[[2L]]
388
389	!	ex <- center[[1L]] + cos_theta * dx - sin_theta * dy
390	!	ey <- center[[2L]] + sin_theta * dx + cos_theta * dy
391
392	!	if (aspect) {
393	!	usr <- graphics::par("usr")
394	!	pin <- graphics::par("pin")
395	!	sy <- usr[[4L]] - usr[[3L]]
396	!	sx <- usr[[2L]] - usr[[1L]]
397	!	ey <- center[[2L]] + (ey - center[[2L]]) * sy / sx * pin[[1L]] / pin[[2L]]
398		}
399
400	!	list(x = ex, y = ey)
401		}

1		# EXPORT
2		#' @include AllGenerics.R
3		NULL
4
5		# The -r9X flags specify that the zip command should recursively search
6		# sub-directories, use maximum compression, and remove depreciated file fields.
7		# The -j flag allows the file names to be stored rather than the full file path.
8
9		#' @export
10		#' @rdname export
11		#' @aliases export,MultivariateAnalysis-method
12		setMethod(
13		f = "export",
14		signature = c(object = "MultivariateAnalysis"),
15		definition = function(object, file, flags = "-r9Xj", ...) {
16		## Create temporary directory
17	!	dir_path <- tempfile(pattern = "export_")
18	!	dir.create(path = dir_path)
19	!	on.exit(unlink(x = dir_path))
20
21		## Write results
22	!	utils::write.csv(
23	!	x = get_data(object),
24	!	file = make_file_name(dir_path, "data")
25		)
26	!	utils::write.csv(
27	!	x = get_eigenvalues(object),
28	!	file = make_file_name(dir_path, "eigenvalues")
29		)
30	!	export_results(object, path = dir_path, margin = 1)
31	!	export_results(object, path = dir_path, margin = 2)
32
33		## Zip
34	!	status <- utils::zip(zipfile = file, files = dir_path, flags = flags, ...)
35	!	invisible(status)
36		}
37		)
38
39		#' @export
40		#' @rdname export
41		#' @aliases export,PCOA-method
42		setMethod(
43		f = "export",
44		signature = c(object = "PCOA"),
45		definition = function(object, file, flags = "-r9Xj", ...) {
46		## Create temporary directory
47	!	dir_path <- tempfile(pattern = "export_")
48	!	dir.create(path = dir_path)
49	!	on.exit(unlink(x = dir_path))
50
51		## Write results
52	!	utils::write.csv(
53	!	x = get_coordinates(object),
54	!	file = make_file_name(dir_path, "coordinates")
55		)
56	!	utils::write.csv(
57	!	x = get_eigenvalues(object),
58	!	file = make_file_name(dir_path, "eigenvalues")
59		)
60
61		## Zip
62	!	status <- utils::zip(zipfile = file, files = dir_path, flags = flags, ...)
63	!	invisible(status)
64		}
65		)
66
67		export_results <- function(object, path, margin, sup_name = ".sup") {
68		## Coordinates
69	!	coords <- get_coordinates(
70	!	x = object,
71	!	margin = margin,
72	!	principal = TRUE,
73	!	sup_name = sup_name
74		)
75
76		## Contributions
77	!	contrib <- get_contributions(
78	!	x = object,
79	!	margin = margin
80		)
81
82		## cos2
83	!	cos2 <- get_cos2(
84	!	x = object,
85	!	margin = margin,
86	!	sup_name = sup_name
87		)
88
89		## Write
90	!	utils::write.csv(x = coords, file = make_file_name(path, "coordinates", margin))
91	!	utils::write.csv(x = contrib, file = make_file_name(path, "contributions", margin))
92	!	utils::write.csv(x = cos2, file = make_file_name(path, "cos2", margin))
93
94	!	invisible(NULL)
95		}
96
97		make_file_name <- function(path, name, margin = NULL) {
98	!	prefix <- ""
99	!	if (!is.null(margin) && margin == 1) prefix <- "row_"
100	!	if (!is.null(margin) && margin == 2) prefix <- "col_"
101
102	!	file_name <- paste0(prefix, name, ".csv")
103	!	file_path <- file.path(path, file_name)
104
105	!	file_path
106		}

1		# ELLIPSES
2		#' @include AllGenerics.R
3		NULL
4
5		# Confidence ===================================================================
6		#' @export
7		#' @rdname viz_confidence
8		#' @aliases wrap_confidence,numeric,numeric-method
9		setMethod(
10		f = "wrap_confidence",
11		signature = c(x = "numeric", y = "numeric"),
12		definition = function(x, y, group = NULL, level = 0.95) {
13		## Validation
14	1x	n <- length(x)
15	1x	arkhe::assert_length(y, n)
16	1x	arkhe::assert_type(level, "numeric")
17
18		## Add groups, if any
19	!	if (is.null(group)) group <- rep("", n)
20	1x	group <- as.character(group)
21	1x	arkhe::assert_length(group, n)
22
23		## Clean
24	1x	ok <- !is.na(x) & !is.na(y) & !is.na(group)
25	1x	x <- x[ok]
26	1x	y <- y[ok]
27	1x	group <- group[ok]
28
29		## Compute ellipse
30	1x	index <- split(seq_along(group), f = group)
31	1x	lapply(
32	1x	X = index,
33	1x	FUN = function(i) {
34	3x	xi <- x[i]
35	3x	yi <- y[i]
36	!	if (length(xi) < 3) return(NULL)
37
38	3x	df1 <- 1
39	3x	df2 <- length(xi) - 2
40	3x	radius <- sqrt(stats::qf(p = level, df1, df2) * df1 / df2)
41	3x	wrap_ellipse(xi, yi, radius = radius)
42		}
43		)
44		}
45		)
46
47		#' @export
48		#' @rdname viz_confidence
49		#' @aliases wrap_confidence,MultivariateAnalysis,missing-method
50		setMethod(
51		f = "wrap_confidence",
52		signature = c(x = "MultivariateAnalysis", y = "missing"),
53		definition = function(x, margin = 1, axes = c(1, 2), group = NULL,
54		level = 0.95, principal = TRUE) {
55		## Validation
56	!	arkhe::assert_scalar(margin, "numeric")
57	!	arkhe::assert_type(axes, "numeric")
58	!	arkhe::assert_length(axes, 2)
59
60		## Get coordinates
61	!	data <- get_coordinates(x, margin = margin, principal = principal)
62	!	data <- data[, axes]
63
64		## Add groups, if any
65	!	if (length(group) > 1) {
66	!	group <- group[get_order(x, margin = margin)]
67	!	} else if (length(group) == 1) {
68	!	group <- get_extra(x)[[group]]
69	!	} else if (has_groups(x, margin = margin)) {
70	!	group <- get_groups(x, margin = margin)
71		}
72
73		## Compute ellipse
74	!	methods::callGeneric(x = data[, 1], y = data[, 2],
75	!	group = group, level = level)
76		}
77		)
78
79		#' @export
80		#' @rdname viz_confidence
81		#' @aliases wrap_confidence,PCOA,missing-method
82		setMethod(
83		f = "wrap_confidence",
84		signature = c(x = "PCOA", y = "missing"),
85		definition = function(x, axes = c(1, 2), group = NULL, level = 0.95) {
86		## Validation
87	1x	arkhe::assert_type(axes, "numeric")
88	1x	arkhe::assert_length(axes, 2)
89
90		## Get coordinates
91	1x	data <- get_coordinates(x)
92	1x	data <- data[, axes]
93
94		## Compute ellipse
95	1x	methods::callGeneric(x = data[, 1], y = data[, 2],
96	1x	group = group, level = level)
97		}
98		)
99
100		# Tolerance ====================================================================
101		#' @export
102		#' @rdname viz_tolerance
103		#' @aliases wrap_tolerance,numeric,numeric-method
104		setMethod(
105		f = "wrap_tolerance",
106		signature = c(x = "numeric", y = "numeric"),
107		definition = function(x, y, group = NULL, level = 0.95) {
108		## Validation
109	2x	n <- length(x)
110	2x	arkhe::assert_length(y, n)
111	2x	arkhe::assert_type(level, "numeric")
112
113		## Add groups, if any
114	!	if (is.null(group)) group <- rep("", n)
115	2x	group <- as.character(group)
116	2x	arkhe::assert_length(group, n)
117
118		## Clean
119	2x	ok <- !is.na(x) & !is.na(y) & !is.na(group)
120	2x	x <- x[ok]
121	2x	y <- y[ok]
122	2x	group <- group[ok]
123
124		## Compute ellipse
125	2x	index <- split(seq_len(n), f = group)
126	2x	lapply(
127	2x	X = index,
128	2x	FUN = function(i) {
129	7x	xi <- x[i]
130	7x	yi <- y[i]
131	!	if (length(xi) < 3) return(NULL)
132
133	7x	df <- 1
134	7x	radius <- sqrt(stats::qchisq(p = level, df = df))
135	7x	wrap_ellipse(xi, yi, radius = radius)
136		}
137		)
138		}
139		)
140
141		#' @export
142		#' @rdname viz_tolerance
143		#' @aliases wrap_tolerance,MultivariateAnalysis,missing-method
144		setMethod(
145		f = "wrap_tolerance",
146		signature = c(x = "MultivariateAnalysis", y = "missing"),
147		definition = function(x, margin = 1, axes = c(1, 2), group = NULL,
148		level = 0.95, principal = TRUE) {
149		## Validation
150	1x	arkhe::assert_scalar(margin, "numeric")
151	1x	arkhe::assert_type(axes, "numeric")
152	1x	arkhe::assert_length(axes, 2)
153
154		## Get coordinates
155	1x	data <- get_coordinates(x, margin = margin, principal = principal)
156	1x	data <- data[, axes]
157
158		## Add groups, if any
159	1x	if (length(group) > 1) {
160	!	group <- group[get_order(x, margin = margin)]
161	1x	} else if (length(group) == 1) {
162	!	group <- get_extra(x)[[group]]
163	1x	} else if (has_groups(x, margin = margin)) {
164	1x	group <- get_groups(x, margin = margin)
165		}
166
167		## Compute ellipse
168	1x	methods::callGeneric(x = data[, 1], y = data[, 2],
169	1x	group = group, level = level)
170		}
171		)
172
173		#' @export
174		#' @rdname viz_tolerance
175		#' @aliases wrap_tolerance,PCOA,missing-method
176		setMethod(
177		f = "wrap_tolerance",
178		signature = c(x = "PCOA", y = "missing"),
179		definition = function(x, axes = c(1, 2), group = NULL, level = 0.95) {
180		## Validation
181	1x	arkhe::assert_type(axes, "numeric")
182	1x	arkhe::assert_length(axes, 2)
183
184		## Get coordinates
185	1x	data <- get_coordinates(x)
186	1x	data <- data[, axes]
187
188		## Compute ellipse
189	1x	methods::callGeneric(x = data[, 1], y = data[, 2],
190	1x	group = group, level = level)
191		}
192		)
193
194		# Helpers ======================================================================
195		wrap_ellipse <- function(x, y, radius = 1) {
196		## Compute ellipse
197	10x	xy <- cbind(x, y)
198	10x	mu <- colMeans(xy)
199	10x	sigma <- stats::cov(xy)
200		# rob <- robustbase::covMcd(xy)
201		# mu <- rob$center
202		# sigma <- rob$cov
203	10x	ellipse(sigma = sigma, mu = mu, radius = radius)
204		}
205
206		#' Computes an Ellipse
207		#'
208		#' @param sigma A square positive definite \eqn{2 \times 2}{2 x 2} covariance
209		#' or correlation `matrix`.
210		#' @param mu A length-two [`numeric`] vector giving the centre of the ellipse.
211		#' @param scale If `sigma` is a correlation matrix, then the standard deviations
212		#' of each parameter can be given in the scale parameter.
213		#' Defaults to `c(1, 1)`, so no rescaling will be done.
214		#' @param level A length-\eqn{k} [`numeric`] vector giving the confidence level
215		#' of a pairwise confidence region.
216		#' @param radius The size of the ellipse may also be controlled by specifying
217		#' the value of a t-statistic on its boundary.
218		#' @param n A length-one [`numeric`] vector specifying the number of points used
219		#' in the ellipse.
220		#' @param ... Currently not used.
221		#' @note Adapted from [ellipse::ellipse()].
222		#' @return
223		#' A [`list`] of \eqn{k} \eqn{n \times 2}{n x 2} `matrix`, suitable for
224		#' plotting.
225		#' @keywords internal
226		#' @noRd
227		ellipse <- function(sigma, ..., mu = c(0, 0), scale = c(1, 1), level = 0.95,
228		radius = sqrt(stats::qchisq(level, 2)), n = 100) {
229	10x	r <- sigma[1, 2]
230
231	10x	if (missing(scale)) {
232	10x	scale <- sqrt(diag(sigma))
233	10x	if (scale[1] > 0) r <- r / scale[1]
234	10x	if (scale[2] > 0) r <- r / scale[2]
235		}
236
237	10x	r <- min(max(r, -1), 1) # clamp to -1..1, in case of rounding errors
238	10x	d <- acos(r)
239	10x	a <- seq(0, 2 * pi, len = n)
240
241	10x	lapply(
242	10x	X = radius,
243	10x	FUN = function(x) {
244	14x	matrix(
245	14x	data = c(x * scale[1] * cos(a + d / 2) + mu[1],
246	14x	x * scale[2] * cos(a - d / 2) + mu[2]),
247	14x	nrow = n,
248	14x	ncol = 2,
249	14x	dimnames = list(NULL, c("x", "y"))
250		)
251		}
252		)
253		}

1		# BIPLOT
2		#' @include AllGenerics.R
3		NULL
4
5		# CA ===========================================================================
6		#' @export
7		#' @method biplot CA
8		biplot.CA <- function(x, ..., axes = c(1, 2),
9		type = c("symetric", "rows", "columns", "contributions"),
10		active = TRUE, sup = TRUE, labels = NULL,
11		col.rows = c("#E69F00", "#E69F00"),
12		col.columns = c("#56B4E9", "#56B4E9"),
13		pch.rows = c(16, 1), pch.columns = c(17, 2),
14		size = c(1, 3),
15		xlim = NULL, ylim = NULL, main = NULL, sub = NULL,
16		legend = list(x = "topleft")) {
17		## Validation
18	6x	type <- match.arg(type, several.ok = FALSE)
19
20		## Type of biplot
21	6x	if (type == "symetric") {
22	3x	princ_row <- TRUE
23	3x	princ_col <- TRUE
24		}
25	6x	if (type == "rows") {
26	1x	princ_row <- TRUE
27	1x	princ_col <- FALSE
28		}
29	6x	if (type == "columns") {
30	1x	princ_row <- FALSE
31	1x	princ_col <- TRUE
32		}
33	6x	if (type == "contributions") {
34	1x	princ_row <- FALSE
35	1x	princ_col <- TRUE
36	1x	sup <- FALSE # Override
37		}
38
39		## Get data
40	6x	coord_col <- prepare_plot(x, margin = 2, axes = axes, active = active, sup = sup,
41	6x	principal = princ_col, extra_quali = "observation",
42	6x	color = col.columns, symbol = pch.columns, line_type = 0)
43	6x	coord_row <- prepare_plot(x, margin = 1, axes = axes, active = active, sup = sup,
44	6x	principal = princ_row, extra_quali = "observation",
45	6x	color = col.rows, symbol = pch.rows, line_type = 0)
46
47		## Graphical parameters
48	6x	if (type == "contributions") {
49	1x	mass_row <- get_masses(x, margin = 1)
50	1x	mass_col <- get_masses(x, margin = 2)
51
52	1x	coord_row$x <- coord_row$x * sqrt(mass_row)
53	1x	coord_row$y <- coord_row$y * sqrt(mass_row)
54
55	1x	coord_row$cex <- khroma::palette_size_sequential(size)(mass_row)
56	1x	coord_col$cex <- khroma::palette_size_sequential(size)(mass_col)
57		}
58
59	6x	coord <- viz_biplot(
60	6x	coord_row, coord_col,
61	6x	rows = TRUE, columns = TRUE,
62	6x	labels = labels,
63	6x	xlim = xlim, ylim = ylim,
64	6x	main = main, sub = sub,
65	6x	xlab = print_variance(x, axes[[1]]),
66	6x	ylab = print_variance(x, axes[[2]]),
67	6x	legend = legend,
68		...
69		)
70
71		## Add legend
72	6x	prepare_legend(coord, legend, points = TRUE, lines = FALSE)
73
74	6x	invisible(x)
75		}
76
77		#' @export
78		#' @rdname biplot
79		#' @aliases biplot,CA-method
80		setMethod("biplot", c(x = "CA"), biplot.CA)
81
82		# PCA ==========================================================================
83		#' @export
84		#' @method biplot PCA
85		biplot.PCA <- function(x, ..., axes = c(1, 2), type = c("form", "covariance"),
86		active = TRUE, sup = TRUE, labels = "variables",
87		col.rows = c("#E69F00", "#E69F00"),
88		col.columns = c("#56B4E9", "#56B4E9"),
89		pch.rows = c(16, 1), lty.columns = c(1, 3),
90		xlim = NULL, ylim = NULL, main = NULL, sub = NULL,
91		legend = list(x = "topleft")) {
92		## Validation
93	4x	type <- match.arg(type, several.ok = FALSE)
94
95		## Type of biplot
96	4x	if (type == "form") {
97	1x	princ_row <- TRUE
98	1x	princ_col <- FALSE
99		}
100	4x	if (type == "covariance") {
101	3x	princ_row <- FALSE
102	3x	princ_col <- TRUE
103		}
104
105		## Get data
106	4x	coord_col <- prepare_plot(x, margin = 2, axes = axes, active = active, sup = sup,
107	4x	principal = princ_col, extra_quali = "observation",
108	4x	color = col.columns, symbol = NA,
109	4x	line_type = lty.columns, ...)
110	4x	coord_row <- prepare_plot(x, margin = 1, axes = axes, active = active, sup = sup,
111	4x	principal = princ_row, extra_quali = "observation",
112	4x	color = col.rows, symbol = pch.rows,
113	4x	line_type = NA, ...)
114
115	4x	arrows_col <- function() {
116	4x	graphics::arrows(
117	4x	x0 = 0, y0 = 0,
118	4x	x1 = coord_col$x, y1 = coord_col$y,
119	4x	length = 0.10, angle = 30,
120	4x	col = coord_col$col, lty = coord_col$lty, lwd = coord_col$lwd
121		)
122		}
123
124	4x	coord <- viz_biplot(
125	4x	coord_row, coord_col,
126	4x	rows = TRUE, columns = FALSE, labels = labels,
127	4x	xlim = xlim, ylim = ylim,
128	4x	main = main, sub = sub,
129	4x	xlab = print_variance(x, axes[[1]]),
130	4x	ylab = print_variance(x, axes[[2]]),
131	4x	panel.first = arrows_col(),
132	4x	legend = legend,
133		...
134		)
135
136		## Add legend
137	4x	prepare_legend(coord, legend, points = TRUE, lines = TRUE)
138
139	4x	invisible(x)
140		}
141
142		#' @export
143		#' @rdname biplot
144		#' @aliases biplot,PCA-method
145		setMethod("biplot", c(x = "PCA"), biplot.PCA)
146
147		# Helpers ======================================================================
148		#' Build a Biplot
149		#'
150		#' @param coord_row A [`data.frame`] returned by [prepare_plot()].
151		#' @param coord_col A [`data.frame`] returned by [prepare_plot()].
152		#' @param rows A [`logical`] scalar: should the rows be drawn?
153		#' @param columns A [`logical`] scalar: should the columns be drawn?
154		#' @param labels A [`character`] vector specifying whether
155		#' "`rows`"/"`individuals`" and/or "`columns`"/"`variables`" names must be
156		#' drawn. Any unambiguous substring can be given.
157		#' @param xlim A length-two [`numeric`] vector giving the x limits of the plot.
158		#' The default value, `NULL`, indicates that the range of the
159		#' [finite][is.finite()] values to be plotted should be used.
160		#' @param ylim A length-two [`numeric`] vector giving the y limits of the plot.
161		#' The default value, `NULL`, indicates that the range of the
162		#' [finite][is.finite()] values to be plotted should be used.
163		#' @param main A [`character`] string giving a main title for the plot.
164		#' @param sub A [`character`] string giving a subtitle for the plot.
165		#' @param xlab,ylab A [`character`] vector giving the x and y axis labels.
166		#' @param axes A [`logical`] scalar: should axes be drawn on the plot?
167		#' @param frame.plot A [`logical`] scalar: should a box be drawn around the
168		#' plot?
169		#' @param ann A [`logical`] scalar: should the default annotation (title and x
170		#' and y axis labels) appear on the plot?
171		#' @param panel.first An `expression` to be evaluated after the plot axes are
172		#' set up but before any plotting takes place. This can be useful for drawing
173		#' background grids.
174		#' @param panel.last An `expression` to be evaluated after plotting has taken
175		#' place but before the axes, title and box are added.
176		#' @return A [`data.frame`] to be passed to [prepare_legend()].
177		#' @author N. Frerebeau
178		#' @keywords internal
179		#' @noRd
180		viz_biplot <- function(coord_row, coord_col, ..., rows = TRUE, columns = TRUE,
181		labels = c("rows", "columns", "individuals", "variables"),
182		xlim = NULL, ylim = NULL, main = NULL, sub = NULL,
183		xlab = NULL, ylab = NULL, axes = TRUE, frame.plot = axes,
184		ann = graphics::par("ann"),
185		panel.first = NULL, panel.last = NULL) {
186
187		## Save and restore graphical parameters
188		## pty: square plotting region, independent of device size
189	10x	old_par <- graphics::par(pty = "s", no.readonly = TRUE)
190	10x	on.exit(graphics::par(old_par), add = TRUE)
191
192		## Open new window
193	10x	grDevices::dev.hold()
194	10x	on.exit(grDevices::dev.flush(), add = TRUE)
195	10x	graphics::plot.new()
196
197		## Set plotting coordinates
198	10x	xlim <- xlim %\|\|% range(coord_row$x, coord_col$x, na.rm = TRUE, finite = TRUE)
199	10x	ylim <- ylim %\|\|% range(coord_row$y, coord_col$y, na.rm = TRUE, finite = TRUE)
200	10x	graphics::plot.window(xlim = xlim, ylim = ylim, asp = 1)
201
202		## Evaluate pre-plot expressions
203	10x	panel.first
204
205		## Plot
206	10x	graphics::abline(h = 0, lty = "dashed", lwd = 1, col = graphics::par("fg"))
207	10x	graphics::abline(v = 0, lty = "dashed", lwd = 1, col = graphics::par("fg"))
208	10x	if (rows) {
209	10x	graphics::points(x = coord_row$x, y = coord_row$y, col = coord_row$col,
210	10x	pch = coord_row$pch, cex = coord_row$cex)
211		}
212	10x	if (columns) {
213	6x	graphics::points(x = coord_col$x, y = coord_col$y, col = coord_col$col,
214	6x	pch = coord_col$pch, cex = coord_col$cex)
215		}
216
217		## Labels
218	10x	if (!is.null(labels)) {
219	!	labels <- match.arg(labels, several.ok = TRUE)
220	!	if (any(labels == "rows") \| any(labels == "individuals")) {
221	!	viz_labels(coord_row, filter = NULL)
222		}
223	!	if (any(labels == "columns") \| any(labels == "variables")) {
224	!	viz_labels(coord_col, filter = NULL)
225		}
226		}
227
228		## Evaluate post-plot and pre-axis expressions
229	10x	panel.last
230
231		## Construct axis
232	10x	if (axes) {
233	10x	graphics::axis(side = 1, las = 1)
234	10x	graphics::axis(side = 2, las = 1)
235		}
236
237		## Plot frame
238	10x	if (frame.plot) {
239	10x	graphics::box()
240		}
241
242		## Add annotation
243	10x	if (ann) {
244	10x	graphics::title(main = main, sub = sub, xlab = xlab, ylab = ylab)
245		}
246
247		## Legend
248	10x	coord_row$extra_quali <- paste(coord_row$extra_quali, "ind.", sep = " ")
249	10x	coord_col$extra_quali <- paste(coord_col$extra_quali, "var.", sep = " ")
250	10x	rbind(coord_row, coord_col)
251		}

1		# PREDICT
2		#' @include AllGenerics.R
3		NULL
4
5		# CA ===========================================================================
6		#' @export
7		#' @rdname predict
8		#' @aliases predict,CA-method
9		setMethod(
10		f = "predict",
11		signature = c(object = "CA"),
12		definition = function(object, newdata, margin = 1) {
13		## Coerce to matrix
14	4x	if (missing(newdata)) {
15	!	data <- object@data
16	!	data <- data[!object@rows@supplement, !object@columns@supplement, drop = FALSE]
17		} else {
18	4x	data <- as.matrix(newdata)
19		}
20
21		## TODO: keep only matching rows/columns
22
23		## Get standard coordinates
24	4x	if (margin == 1) {
25	2x	data <- data / rowSums(data)
26	2x	std <- object@columns@standard
27		}
28	4x	if (margin == 2) {
29	2x	data <- t(data) / colSums(data)
30	2x	std <- object@rows@standard
31		}
32
33		## Compute principal coordinates
34	4x	coords <- crossprod(t(data), std)
35	4x	coords <- as.data.frame(coords)
36	4x	colnames(coords) <- paste0("F", seq_along(coords))
37	4x	return(coords)
38		}
39		)
40
41		# MCA ==========================================================================
42		#' @export
43		#' @rdname predict
44		#' @aliases predict,MCA-method
45		setMethod(
46		f = "predict",
47		signature = c(object = "MCA"),
48		definition = function(object, newdata, margin = 1) {
49		## Coerce to matrix
50	2x	if (missing(newdata)) {
51	!	data <- object@data
52	!	data <- data[!object@rows@supplement, !object@columns@supplement, drop = FALSE]
53		} else {
54		## Complete disjunctive table
55	2x	data <- cdt(newdata)
56		}
57
58	2x	methods::callNextMethod(object = object, newdata = data, margin = margin)
59		}
60		)
61
62		# PCA ==========================================================================
63		#' @export
64		#' @rdname predict
65		#' @aliases predict,PCA-method
66		setMethod(
67		f = "predict",
68		signature = c(object = "PCA"),
69		definition = function(object, newdata, margin = 1) {
70		## Coerce to matrix
71	2x	if (missing(newdata)) {
72	!	data <- object@data
73	!	data <- data[!object@rows@supplement, !object@columns@supplement]
74		} else {
75	2x	data <- as.matrix(newdata)
76		}
77
78		## Get standard coordinates
79	2x	var_mean <- object@center
80	2x	var_sd <- object@scale
81
82	2x	if (margin == 1) {
83	1x	std <- object@columns@standard
84	1x	w <- object@columns@weights
85
86	1x	newdata <- (t(newdata) - var_mean) * w / var_sd
87		}
88	2x	if (margin == 2) {
89	1x	std <- object@rows@standard
90	1x	w <- object@rows@weights
91	1x	j <- ncol(newdata)
92
93	1x	X <- if (all(var_mean == 0)) rep(0, j) else weighted_mean(newdata, w)
94	1x	newdata <- t(t(newdata) - X)
95	1x	Y <- if (all(var_sd == 1)) rep(1, j) else weighted_sd(newdata, w)
96	1x	newdata <- t(t(newdata) / Y)
97	1x	newdata <- newdata * w
98		}
99
100		## Compute principal coordinates
101	2x	coords <- crossprod(newdata, std)
102	2x	coords <- as.data.frame(coords)
103	2x	colnames(coords) <- paste0("F", seq_along(coords))
104	2x	return(coords)
105		}
106		)

1		# SCREEPLOT
2		#' @include AllGenerics.R
3		NULL
4
5		# Screeplot ====================================================================
6		#' @export
7		#' @method screeplot MultivariateAnalysis
8		screeplot.MultivariateAnalysis <- function(x, ..., eigenvalues = FALSE, cumulative = FALSE,
9		labels = TRUE, limit = 10,
10		col = "grey90", border = "grey10",
11		col.cumulative = "red", lty.cumulative = "solid",
12		lwd.cumulative = 2) {
13		## TODO
14	8x	horiz <- FALSE
15
16		## Save and restore graphical parameters
17	8x	old_par <- graphics::par(mar = c(5, 4, 4, 2 + 2 * cumulative) + 0.1,
18	8x	no.readonly = TRUE)
19	8x	on.exit(graphics::par(old_par), add = TRUE)
20
21		## Prepare data
22	8x	data <- get_eigenvalues(x)
23	8x	data$x <- seq_len(nrow(data))
24	8x	data$z <- data[[3L]]
25
26		## Subset
27	8x	if (!is.null(limit)) {
28	8x	limit <- min(nrow(data), limit)
29	8x	data <- data[seq_len(limit), , drop = FALSE]
30		}
31
32	8x	if (eigenvalues) {
33	4x	data$y <- data[[1L]]
34	4x	data$labels <- round(data$y, digits = 1)
35	4x	ylab <- tr_("Eigenvalues")
36		} else {
37	4x	data$y <- data[[2L]]
38	4x	data$labels <- paste0(round(data$y, digits = 1), "%")
39	4x	if (methods::is(x, "CA")) {
40	2x	ylab <- tr_("Proportion of inertia (%)")
41		} else {
42	2x	ylab <- tr_("Explained variance (%)")
43		}
44		}
45
46	8x	k <- max(data$y) / max(data$z)
47	8x	data$k <- data$z * k
48
49		## Bar plot
50	8x	mid <- graphics::barplot(
51	8x	height = data$y,
52	8x	names.arg = data$x,
53	8x	horiz = horiz,
54	8x	xlab = if (horiz) ylab else NULL,
55	8x	ylab = if (horiz) NULL else ylab,
56	8x	ylim = c(0, max(data$k)) * 1.05,
57	8x	col = col,
58	8x	border = border,
59	8x	las = 1,
60		...
61		)
62
63	8x	if (labels) {
64	8x	graphics::text(
65	8x	x = mid,
66	8x	y = data$y,
67	8x	labels = data$labels,
68	8x	pos = 3
69		)
70		}
71
72	8x	if (cumulative && !horiz) {
73	4x	if (methods::is(x, "CA")) {
74	2x	ylab2 <- tr_("Cumulative inertia (%)")
75		} else {
76	2x	ylab2 <- tr_("Cumulative variance (%)")
77		}
78	4x	tick_labels <- seq(from = 0, to = 100, by = 20)
79	4x	tick_at <- tick_labels * k
80	4x	graphics::lines(
81	4x	x = mid,
82	4x	y = data$k,
83	4x	type = "b",
84	4x	pch = 16,
85	4x	lty = lty.cumulative,
86	4x	lwd = lwd.cumulative,
87	4x	col = col.cumulative
88		)
89	4x	graphics::axis(side = 4, at = tick_at, labels = tick_labels,
90	4x	col = col.cumulative, col.ticks = col.cumulative,
91	4x	col.axis = col.cumulative, las = 1)
92	4x	graphics::mtext(
93	4x	text = ylab2,
94	4x	side = 4, line = 3, col = col.cumulative
95		)
96		}
97
98	8x	invisible(x)
99		}
100
101		#' @export
102		#' @rdname screeplot
103		#' @aliases screeplot,MultivariateAnalysis-method
104		setMethod("screeplot", c(x = "MultivariateAnalysis"), screeplot.MultivariateAnalysis)
105
106		#' @export
107		#' @method screeplot PCOA
108		screeplot.PCOA <- function(x, ..., labels = FALSE, limit = NULL,
109		col = "grey90", border = "grey10") {
110		## TODO
111	1x	horiz <- FALSE
112
113		## Prepare data
114	1x	data <- get_eigenvalues(x)
115	1x	data$x <- seq_len(nrow(data))
116	1x	data$y <- data[[1L]]
117	1x	data$labels <- round(data$y, digits = 1)
118
119		## Subset
120	1x	if (!is.null(limit)) {
121	!	limit <- min(nrow(data), limit)
122	!	data <- data[seq_len(limit), , drop = FALSE]
123		}
124
125		## Bar plot
126	1x	ylab <- tr_("Eigenvalues")
127	1x	mid <- graphics::barplot(
128	1x	height = data$y,
129	1x	names.arg = data$x,
130	1x	horiz = horiz,
131	1x	xlab = if (horiz) ylab else NULL,
132	1x	ylab = if (horiz) NULL else ylab,
133	1x	ylim = c(0, max(data$y)) * 1.05,
134	1x	col = col,
135	1x	border = border,
136	1x	las = 1,
137		...
138		)
139
140	1x	if (labels) {
141	!	graphics::text(
142	!	x = mid,
143	!	y = data$y,
144	!	labels = data$labels,
145	!	pos = 3
146		)
147		}
148
149	1x	invisible(x)
150		}
151
152		#' @export
153		#' @rdname screeplot
154		#' @aliases screeplot,PCOA-method
155		setMethod("screeplot", c(x = "PCOA"), screeplot.PCOA)

1		# SVD
2		#' @include AllGenerics.R
3		NULL
4
5		#' Singular Value Decomposition of a Matrix
6		#'
7		#' @param x A \eqn{m \times p}{m x p} numeric [`matrix`].
8		#' @param rank An [`integer`] value specifying the maximal number of components
9		#' to be kept in the results.
10		#' @return
11		#' A [`list`] with the following elements:
12		#' \describe{
13		#' \item{`d`}{A vector containing the singular values of `x`, of length
14		#' `rank`, sorted decreasingly.}
15		#' \item{`u`}{A matrix whose columns contain the left singular vectors of
16		#' `x`. Dimension `c(m, rank)`.}
17		#' \item{`v`}{A matrix whose columns contain the right singular vectors of
18		#' `x`. Dimension `c(p, rank)`.}
19		#' }
20		#' @note
21		#' In both PCA and PCA-cor whitening there is a sign-ambiguity in the
22		#' eigenvector matrices. In order to resolve the sign-ambiguity we use
23		#' eigenvector matrices with a positive diagonal. This has the effect to make
24		#' cross-correlations and cross-correlations positive diagonal for PCA.
25		#' @keywords internal
26		svd2 <- function(x, rank = Inf) {
27	26x	D <- svd(x, nu = rank, nv = rank)
28
29	26x	keep <- seq_len(rank)
30	26x	sv <- D$d[keep]
31
32	26x	U <- D$u
33	26x	V <- D$v
34
35		# Fix sign for consistency with FactoMineR
36	26x	if (rank > 1) {
37	26x	mult <- sign(as.vector(crossprod(rep(1, nrow(V)), as.matrix(V))))
38	26x	mult[mult == 0] <- 1
39
40		# Build matrix
41		# matrix * vector is faster (!) than:
42		# matrix %*% t(vector)
43		# t(t(matrix) * vector)
44	26x	mult_U <- matrix(mult, nrow = nrow(U), ncol = rank, byrow = TRUE)
45	26x	mult_V <- matrix(mult, nrow = nrow(V), ncol = rank, byrow = TRUE)
46
47	26x	U <- U * mult_U
48	26x	V <- V * mult_V
49		}
50
51	26x	names(sv) <- paste0("F", keep)
52	26x	list(
53	26x	d = sv,
54	26x	u = U,
55	26x	v = V
56		)
57		}

1		# PLOT ELLIPSE
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname viz_ellipses
7		#' @aliases viz_ellipses,numeric,numeric-method
8		setMethod(
9		f = "viz_ellipses",
10		signature = c(x = "numeric", y = "numeric"),
11		definition = function(x, y, ..., group = NULL,
12		type = c("tolerance", "confidence"), level = 0.95,
13		color = NULL, fill = FALSE, symbol = FALSE) {
14	!	type <- match.arg(type, several.ok = FALSE)
15	!	fun <- switch(
16	!	type,
17	!	tolerance = wrap_tolerance,
18	!	confidence = wrap_confidence
19		)
20	!	ell <- fun(x, y, group = group, level = level)
21	!	.viz_ellipses(ell, color = color, fill = fill, symbol = symbol, ...)
22
23	!	invisible(list(x = x, y = y))
24		}
25		)
26
27		#' @export
28		#' @rdname viz_ellipses
29		#' @aliases viz_ellipses,MultivariateAnalysis,missing-method
30		setMethod(
31		f = "viz_ellipses",
32		signature = c(x = "MultivariateAnalysis", y = "missing"),
33		definition = function(x, ..., group = NULL,
34		type = c("tolerance", "confidence"), level = 0.95,
35		color = NULL, fill = FALSE, symbol = FALSE) {
36	1x	type <- match.arg(type, several.ok = FALSE)
37	1x	fun <- switch(
38	1x	type,
39	1x	tolerance = wrap_tolerance,
40	1x	confidence = wrap_confidence
41		)
42	1x	ell <- fun(x, margin = get_margin(), axes = get_axes(),
43	1x	group = group, level = level, principal = get_principal())
44	1x	.viz_ellipses(ell, color = color, fill = fill, symbol = symbol, ...)
45
46	1x	invisible(x)
47		}
48		)
49
50		#' @export
51		#' @rdname viz_ellipses
52		#' @aliases viz_ellipses,PCOA,missing-method
53		setMethod(
54		f = "viz_ellipses",
55		signature = c(x = "PCOA", y = "missing"),
56		definition = function(x, ..., group = NULL,
57		type = c("tolerance", "confidence"), level = 0.95,
58		color = NULL, fill = FALSE, symbol = FALSE) {
59	2x	type <- match.arg(type, several.ok = FALSE)
60	2x	fun <- switch(
61	2x	type,
62	2x	tolerance = wrap_tolerance,
63	2x	confidence = wrap_confidence
64		)
65	2x	ell <- fun(x, axes = get_axes(), group = group, level = level)
66	2x	.viz_ellipses(ell, color = color, fill = fill, symbol = symbol, ...)
67
68	2x	invisible(x)
69		}
70		)
71
72
73		#' @param x A `list` of `matrix` returned by [wrap_ellipse()].
74		#' @noRd
75		.viz_ellipses <- function(x, ..., color = NULL, fill = FALSE, symbol = FALSE) {
76	3x	n <- length(x)
77
78		## Recycle graphical parameters if of length one
79	3x	dots <- list(...)
80	3x	col <- recycle(dots$border %\|\|% graphics::par("fg"), n)
81	3x	bg <- recycle(dots$col %\|\|% NA, n)
82	3x	lty <- recycle(dots$lty %\|\|% graphics::par("lty"), n)
83	3x	lwd <- recycle(dots$lwd %\|\|% graphics::par("lwd"), n)
84
85	3x	if (n > 1) {
86		## Discrete scales
87	3x	extra_quali <- names(x)
88	3x	if (is.null(dots$border) && !isFALSE(color))
89	3x	col <- khroma::palette_color_discrete(colors = color)(extra_quali)
90	3x	if (is.null(dots$col) && !isFALSE(fill))
91	!	bg <- khroma::palette_color_discrete(colors = fill)(extra_quali)
92	3x	if (is.null(dots$lty) && !isFALSE(symbol))
93	!	lty <- khroma::palette_line(types = symbol)(extra_quali)
94		}
95
96	3x	for (i in seq_along(x)) {
97	10x	lvl <- x[[i]]
98	10x	for (j in seq_along(lvl)) {
99	14x	graphics::polygon(
100	14x	x = lvl[[j]],
101	14x	border = col[i],
102	14x	col = bg[i],
103	14x	lty = lty[i],
104	14x	lwd = lwd[i]
105		)
106		}
107		}
108
109	3x	invisible(x)
110		}
111
112		# Tolerance ====================================================================
113		#' @export
114		#' @rdname viz_tolerance
115		#' @aliases viz_tolerance,numeric,numeric-method
116		setMethod(
117		f = "viz_tolerance",
118		signature = c(x = "numeric", y = "numeric"),
119		definition = function(x, y, ..., group = NULL, level = 0.95,
120		color = NULL, fill = FALSE, symbol = FALSE) {
121	!	viz_ellipses(x, y, group = group, type = "tolerance", level = level,
122	!	color = color, fill = fill, symbol = symbol, ...)
123	!	invisible(list(x = x, y = y))
124		}
125		)
126
127		#' @export
128		#' @rdname viz_tolerance
129		#' @aliases viz_tolerance,MultivariateAnalysis,missing-method
130		setMethod(
131		f = "viz_tolerance",
132		signature = c(x = "MultivariateAnalysis", y = "missing"),
133		definition = function(x, ..., group = NULL, level = 0.95,
134		color = NULL, fill = FALSE, symbol = FALSE) {
135	!	viz_ellipses(x, group = group, type = "tolerance", level = level,
136	!	color = color, fill = fill, symbol = symbol, ...)
137	!	invisible(x)
138		}
139		)
140
141		#' @export
142		#' @rdname viz_tolerance
143		#' @aliases viz_tolerance,MultivariateBootstrap,missing-method
144		setMethod(
145		f = "viz_tolerance",
146		signature = c(x = "MultivariateBootstrap", y = "missing"),
147		definition = function(x, ..., level = 0.95,
148		color = FALSE, fill = FALSE, symbol = FALSE) {
149	1x	viz_ellipses(x, group = NULL, type = "tolerance", level = level,
150	1x	color = color, fill = fill, symbol = symbol, ...)
151	1x	invisible(x)
152		}
153		)
154
155		#' @export
156		#' @rdname viz_tolerance
157		#' @aliases viz_tolerance,PCOA,missing-method
158		setMethod(
159		f = "viz_tolerance",
160		signature = c(x = "PCOA", y = "missing"),
161		definition = function(x, ..., group = NULL, level = 0.95,
162		color = NULL, fill = FALSE, symbol = FALSE) {
163	!	viz_ellipses(x, group = group, type = "tolerance", level = level,
164	!	color = color, fill = fill, symbol = symbol, ...)
165	!	invisible(x)
166		}
167		)
168
169		# Confidence ===================================================================
170		#' @export
171		#' @rdname viz_confidence
172		#' @aliases viz_confidence,numeric,numeric-method
173		setMethod(
174		f = "viz_confidence",
175		signature = c(x = "numeric", y = "numeric"),
176		definition = function(x, y, ..., group = NULL, level = 0.95,
177		color = NULL, fill = FALSE, symbol = FALSE) {
178	!	viz_ellipses(x, y, group = group, type = "confidence", level = level,
179	!	color = color, fill = fill, symbol = symbol, ...)
180	!	invisible(list(x = x, y = y))
181		}
182		)
183
184		#' @export
185		#' @rdname viz_confidence
186		#' @aliases viz_confidence,MultivariateAnalysis,missing-method
187		setMethod(
188		f = "viz_confidence",
189		signature = c(x = "MultivariateAnalysis", y = "missing"),
190		definition = function(x, ..., group = NULL, level = 0.95,
191		color = NULL, fill = FALSE, symbol = FALSE) {
192	!	viz_ellipses(x, group = group, type = "confidence", level = level,
193	!	color = color, fill = fill, symbol = symbol, ...)
194	!	invisible(x)
195		}
196		)
197
198		#' @export
199		#' @rdname viz_confidence
200		#' @aliases viz_confidence,MultivariateBootstrap,missing-method
201		setMethod(
202		f = "viz_confidence",
203		signature = c(x = "MultivariateBootstrap", y = "missing"),
204		definition = function(x, ..., level = 0.95,
205		color = FALSE, fill = FALSE, symbol = FALSE) {
206	!	viz_ellipses(x, group = NULL, type = "confidence", level = level,
207	!	color = color, fill = fill, symbol = symbol, ...)
208	!	invisible(x)
209		}
210		)
211
212		#' @export
213		#' @rdname viz_confidence
214		#' @aliases viz_confidence,PCOA,missing-method
215		setMethod(
216		f = "viz_confidence",
217		signature = c(x = "PCOA", y = "missing"),
218		definition = function(x, ..., axes = c(1, 2), group = NULL, level = 0.95,
219		color = NULL, fill = FALSE, symbol = FALSE) {
220	!	viz_ellipses(x, group = group, type = "confidence", level = level,
221	!	color = color, fill = fill, symbol = symbol, ...)
222	!	invisible(x)
223		}
224		)

1		# BOOTSTRAP
2		#' @include AllGenerics.R
3		NULL
4
5		# CA ===========================================================================
6		#' @export
7		#' @rdname bootstrap
8		#' @aliases bootstrap,CA-method
9		setMethod(
10		f = "bootstrap",
11		signature = c(object = "CA"),
12		definition = function(object, n = 30) {
13		## Data replication
14	1x	n <- as.integer(n)
15	1x	arkhe::assert_scalar(n, "integer")
16
17	1x	data <- object@data
18	1x	data <- data[!object@rows@supplement, !object@columns@supplement]
19	1x	repl <- stats::rmultinom(n = n, size = sum(data), prob = data)
20
21	1x	i <- nrow(data)
22	1x	j <- ncol(data)
23
24	1x	k_n <- seq_len(n)
25	1x	k_i <- seq_len(i)
26	1x	k_j <- seq_len(j)
27
28	1x	new_row <- matrix(data = NA_integer_, nrow = i * n, ncol = j)
29	1x	new_col <- matrix(data = NA_integer_, nrow = i, ncol = j * n)
30	1x	for (p in k_n) {
31	30x	m_i <- k_i + i * (p - 1)
32	30x	m_j <- k_j + j * (p - 1)
33	30x	new_row[m_i, ] <- repl[, p]
34	30x	new_col[, m_j] <- repl[, p]
35		}
36
37	1x	res_row <- ca(rbind(data, new_row), sup_row = 1:(i * n) + i)
38	1x	res_col <- ca(cbind(data, new_col), sup_col = 1:(j * n) + j)
39
40		## Set names
41	1x	names_row <- rep_len(object@rows@names, i * (n + 1))
42	1x	names_col <- rep_len(object@columns@names, j * (n + 1))
43	1x	res_row@rows@names <- make.unique(names_row, sep = "_")
44	1x	res_col@columns@names <- make.unique(names_col, sep = "_")
45
46		## Set groups
47	1x	res_row@rows@groups <- names_row
48	1x	res_col@columns@groups <- names_col
49
50	1x	.BootstrapCA(
51	1x	object,
52	1x	rows = res_row@rows,
53	1x	columns = res_col@columns,
54	1x	replications = n
55		)
56		}
57		)
58
59		# PCA ==========================================================================
60		#' @export
61		#' @rdname bootstrap
62		#' @aliases bootstrap,PCA-method
63		setMethod(
64		f = "bootstrap",
65		signature = c(object = "PCA"),
66		definition = function(object, n = 30) {
67		## Get data
68	1x	n <- as.integer(n)
69	1x	arkhe::assert_scalar(n, "integer")
70
71	1x	data <- object@data
72	1x	data <- data[!object@rows@supplement, !object@columns@supplement]
73	1x	U <- object@rows@standard
74	1x	w <- object@rows@weights
75	1x	i <- nrow(data)
76	1x	j <- ncol(data)
77
78	1x	k_n <- seq_len(n)
79	1x	k_i <- seq_len(i)
80	1x	k_j <- seq_len(j)
81
82		## Data replication
83	1x	new_coord <- matrix(data = NA_integer_, nrow = j * n, ncol = ncol(U))
84	1x	new_dist <- vector(mode = "numeric", length = j * n)
85	1x	for (p in k_n) {
86	30x	m_j <- k_j + j * (p - 1)
87	30x	z <- sample(i, size = i, replace = TRUE)
88	30x	w_i <- w[z]
89	30x	new_data <- data[z, ]
90
91		## Principal coordinates
92		# Center and scale
93	30x	if (is_centered(object)) {
94	30x	new_data <- t(t(new_data) - weighted_mean(new_data, w_i))
95		}
96	30x	if (is_scaled(object)) {
97	30x	new_data <- t(t(new_data) / weighted_sd(new_data, w_i))
98		}
99	30x	var_sup <- new_data * w_i
100	30x	new_coord[m_j, ] <- crossprod(var_sup, U[z, ])
101
102		## Squared distance to centroide
103	30x	new_dist[m_j] <- colSums(new_data^2 * w_i)
104		}
105
106		## Squared cosine
107	1x	new_cos <- new_coord^2 / new_dist
108
109		## Set names
110	1x	names_col <- rep_len(object@columns@names, j * (n + 1))
111
112	1x	new_col <- build_results(
113	1x	names = make.unique(names_col, sep = "_"),
114	1x	principal = rbind(object@columns@principal, new_coord),
115	1x	standard = object@columns@standard,
116	1x	contributions = object@columns@contributions,
117	1x	distances = c(object@columns@distances, new_dist),
118	1x	cosine = rbind(object@columns@cosine, new_cos),
119	1x	weights = object@columns@weights,
120	1x	supplement = c(object@columns@supplement, !logical(j * n)),
121	1x	groups = names_col
122		)
123
124	1x	.BootstrapPCA(
125	1x	object,
126	1x	columns = new_col,
127	1x	replications = n
128		)
129		}
130		)

1		# AUGMENT
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname tidy
7		#' @aliases augment,MultivariateAnalysis-method
8		setMethod(
9		f = "augment",
10		signature = c(x = "MultivariateAnalysis"),
11		definition = function(x, ..., margin = 1, axes = c(1, 2), principal = TRUE) {
12		## Validation
13	54x	arkhe::assert_scalar(margin, "numeric")
14	54x	arkhe::assert_scalar(principal, "logical")
15	54x	arkhe::assert_type(axes, "numeric")
16	54x	arkhe::assert_length(axes, 2)
17
18		## Get data
19	54x	coords <- get_coordinates(x, margin = margin, principal = principal)
20
21	54x	mass <- contrib <- rep(NA_real_, nrow(coords))
22	54x	mass[!coords$.sup] <- get_masses(x, margin = margin)
23	54x	contrib[!coords$.sup] <- joint_contributions(x, margin = margin, axes = axes)
24	54x	sum <- joint_coordinates(x, margin = margin, axes = axes, principal = principal)
25	54x	cos2 <- joint_cos2(x, margin = margin, axes = axes)
26
27	54x	res <- data.frame(
28	54x	coords[, axes, drop = FALSE],
29	54x	label = rownames(coords),
30	54x	supplementary = coords$.sup,
31	54x	mass = mass,
32	54x	sum = sum,
33	54x	contribution = contrib,
34	54x	cos2 = cos2,
35	54x	row.names = NULL
36		)
37
38	54x	if (!methods::is(x, "MultivariateBootstrap")) {
39		## Reorder
40		## /!\ see build_results() /!\
41	51x	origin <- get_order(x, margin = margin)
42	51x	res <- res[origin, , drop = FALSE]
43		}
44
45	54x	res
46		}
47		)
48
49		#' Joint
50		#'
51		#' @param object A [`CA-class`] or [`PCA-class`] object.
52		#' @param what A [`character`] string.
53		#' @param margin A length-one [`numeric`] vector giving the subscript
54		#' which the data will be returned: `1` indicates individuals/rows (the
55		#' default), `2` indicates variables/columns.
56		#' @param axes A length-two [`numeric`] vector giving the dimensions
57		#' to be for which to compute results.
58		#' @param sup A [`logical`] scalar: should supplementary points be
59		#' returned?
60		#' @param ... Extra parameters to be passed to internal methods.
61		#' @seealso \link[=mutator]{get_*()}
62		#' @example inst/examples/ex-joint.R
63		#' @author N. Frerebeau
64		#' @docType methods
65		#' @family summary
66		#' @name joint
67		#' @rdname joint
68		#' @noRd
69		NULL
70
71		joint <- function(object, what, ...) {
72	6x	choices <- c("coordinates", "contributions", "cos2")
73	6x	what <- match.arg(what, choices = choices, several.ok = FALSE)
74
75	6x	fun <- switch (
76	6x	what,
77	6x	coordinates = joint_coordinates,
78	6x	contributions = joint_contributions,
79	6x	cos2 = joint_cos2
80		)
81
82	6x	fun(object, ...)
83		}
84
85		joint_coordinates <- function(object, ..., margin = 1, axes = c(1, 2),
86		principal = TRUE) {
87	56x	axes <- axes[c(1, 2)]
88	56x	coord <- get_coordinates(object, margin = margin, principal = principal)
89	56x	rowSums(coord[, axes]^2)
90		}
91
92		joint_contributions <- function(object, ..., margin = 1, axes = c(1, 2)) {
93	58x	axes <- axes[c(1, 2)]
94	58x	contrib <- get_contributions(object, margin = margin)
95	58x	eig <- matrix(
96	58x	data = object@singular_values[axes]^2,
97	58x	nrow = nrow(contrib),
98	58x	ncol = 2,
99	58x	byrow = TRUE
100		)
101	58x	rowSums(contrib[, axes] * eig)
102		}
103
104		joint_cos2 <- function(object, ..., margin = 1, axes = c(1, 2)) {
105	56x	axes <- axes[c(1, 2)]
106	56x	cos2 <- get_cos2(object, margin = margin)
107	56x	rowSums(cos2[, axes])
108		}

1		# CONVEX HULL
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname viz_hull
7		#' @aliases wrap_hull,numeric,numeric-method
8		setMethod(
9		f = "wrap_hull",
10		signature = c(x = "numeric", y = "numeric"),
11		definition = function(x, y, group = NULL) {
12		## Validation
13	6x	n <- length(x)
14	6x	arkhe::assert_length(y, n)
15
16		## Add groups, if any
17	!	if (is.null(group)) group <- rep("", n)
18	6x	group <- as.character(group)
19	6x	arkhe::assert_length(group, n)
20
21		## Clean
22	6x	ok <- !is.na(x) & !is.na(y) & !is.na(group)
23	6x	x <- x[ok]
24	6x	y <- y[ok]
25	6x	group <- group[ok]
26
27		## Compute convex hulls
28	6x	index <- split(seq_along(group), f = group)
29	6x	lapply(
30	6x	X = index,
31	6x	FUN = function(i) {
32	20x	xi <- x[i]
33	20x	yi <- y[i]
34	!	if (length(xi) < 3) return(NULL)
35
36	20x	i <- grDevices::chull(xi, yi)
37	20x	cbind(xi, yi)[c(i, i[1]), , drop = FALSE]
38		}
39		)
40		}
41		)
42
43		#' @export
44		#' @rdname viz_hull
45		#' @aliases wrap_hull,MultivariateAnalysis,missing-method
46		setMethod(
47		f = "wrap_hull",
48		signature = c(x = "MultivariateAnalysis", y = "missing"),
49		definition = function(x, margin = 1, axes = c(1, 2), group = NULL,
50		principal = TRUE) {
51		## Validation
52	5x	arkhe::assert_scalar(margin, "numeric")
53	5x	arkhe::assert_type(axes, "numeric")
54	5x	arkhe::assert_length(axes, 2)
55
56		## Get coordinates
57	5x	data <- get_coordinates(x, margin = margin, principal = principal)
58	5x	data <- data[, axes]
59
60		## Add groups, if any
61	5x	if (length(group) > 1) {
62	3x	group <- group[get_order(x, margin = margin)]
63	2x	} else if (length(group) == 1) {
64	!	group <- get_extra(x)[[group]]
65	2x	} else if (has_groups(x, margin = margin)) {
66	2x	group <- get_groups(x, margin = margin)
67		}
68
69		## Compute convex hulls
70	5x	methods::callGeneric(x = data[, 1], y = data[, 2], group = group)
71		}
72		)
73
74		#' @export
75		#' @rdname viz_hull
76		#' @aliases wrap_hull,PCOA,missing-method
77		setMethod(
78		f = "wrap_hull",
79		signature = c(x = "PCOA", y = "missing"),
80		definition = function(x, axes = c(1, 2), group = NULL) {
81		## Validation
82	1x	arkhe::assert_type(axes, "numeric")
83	1x	arkhe::assert_length(axes, 2)
84
85		## Get coordinates
86	1x	data <- get_coordinates(x)
87	1x	data <- data[, axes]
88
89		## Compute convex hulls
90	1x	methods::callGeneric(x = data[, 1], y = data[, 2], group = group)
91		}
92		)

1		# HELPERS
2
3		## https://michaelchirico.github.io/potools/articles/developers.html
4		tr_ <- function(...) {
5	71x	enc2utf8(gettext(paste0(...), domain = "R-dimensio"))
6		}
7
8		recycle <- function(x, n) {
9	!	if (length(x) == 1) rep(x, n) else x
10		}
11
12		print_variance <- function(object, axis) {
13	76x	v <- get_variance(object, digits = 1) # Get percentage of variance
14	76x	sprintf("%s (%g%%)", names(v)[[axis]], v[[axis]])
15		}
16
17		#' Weighted Column Means and Standard Deviations
18		#'
19		#' @param x A [`numeric`] matrix.
20		#' @param w An [`numeric`] vector.
21		#' @return A [`numeric`] vector.
22		#' @keywords internal
23		#' @noRd
24		weighted_mean <- function(x, w) {
25	42x	as.vector(crossprod(w, x))
26		}
27		weighted_sd <- function(x, w) {
28	37x	sqrt(as.vector(crossprod(w, x^2)))
29		}
30
31		#' Column Index
32		#'
33		#' @param index A [`numeric`] vector.
34		#' @param n An [`integer`] value.
35		#' @param names A [`character`] vector.
36		#' @return A [`logical`] vector.
37		#' @keywords internal
38		#' @noRd
39		find_variable <- function(index, n, names = NULL) {
40	128x	x <- logical(n)
41
42	99x	if (is.null(index)) return(x)
43
44	29x	if (is.logical(index)) {
45	!	arkhe::assert_length(index, n)
46	!	return(index)
47		}
48
49	29x	if (is.character(index)) {
50	!	index <- match(index, names)
51	!	index <- index[!is.na(index)]
52	!	if (length(index) == 0) return(x)
53		}
54
55	29x	if (is.numeric(index)) {
56	29x	x[index] <- TRUE
57	29x	return(x)
58		}
59
60	!	arkhe::assert_type(index, "numeric")
61		}
62
63		#' Remove Columns Using a Predicate
64		#'
65		#' @param x A [`data.frame`].
66		#' @param f A predicate [`function`].
67		#' @param negate A [`logical`] scalar: should the negation of `f` be used
68		#' instead of `f`?
69		#' @param sup A `vector` specifying the indices of the supplementary columns.
70		#' @param extra A `vector` specifying the indices of the extra columns.
71		#' @param auto A [`logical`] scalar: should invalid variables be automatically
72		#' removed?
73		#' @param what A [`character`] string to be used in the message.
74		#' @param verbose A [`logical`] scalar: should \R report extra information on
75		#' progress?
76		#' @details
77		#' Side effect: move `sup` and `extra` columns at the end of `x`.
78		#' @return A `list` with the following elements: `data` (a `matrix`),
79		#' `sup` (an `integer` vector) and `extra` (a `data.frame` or `NULL`).
80		#' @keywords internal
81		#' @noRd
82		drop_variable <- function(x, f, negate = FALSE, sup = NULL, extra = NULL,
83		auto = TRUE, what = "extra",
84		verbose = getOption("dimensio.verbose")) {
85		## Check variables
86	31x	if (negate) f <- Negate(f)
87	33x	not_ok <- vapply(x, FUN = f, FUN.VALUE = logical(1))
88
89		## Get extra variables
90	33x	is_extra <- find_variable(extra, ncol(x), names = colnames(x))
91	33x	is_sup <- find_variable(sup, ncol(x), names = colnames(x))
92
93		## Quit
94	33x	if (!auto && any(not_ok & !is_extra)) {
95	2x	msg <- tr_("Some variables are invalid: %s.")
96	2x	col <- paste(colnames(x)[not_ok & !is_extra], collapse = ", ")
97	2x	stop(sprintf(msg, col), call. = FALSE)
98		}
99
100		## Extract extra variables, if any
101	31x	if (any(is_extra)) {
102	8x	extra <- x[, is_extra, drop = FALSE]
103		}
104
105		## Remove supplementary/extra variables, if any
106	31x	tmp <- x
107	31x	x <- x[, !(not_ok \| is_sup \| is_extra), drop = FALSE]
108
109		## Move supplementary variables at the end, if any
110	31x	is_sup_ok <- is_sup & !not_ok
111	31x	if (any(is_sup_ok)) {
112	7x	sup <- seq_len(sum(is_sup_ok)) + ncol(x)
113	7x	x <- cbind(x, tmp[, is_sup_ok, drop = FALSE])
114		} else {
115		# warning("!", call. = FALSE)
116	24x	sup <- NULL
117		}
118
119		## Generate message
120	31x	if (any(not_ok)) {
121	12x	not_ok[is_sup \| is_extra] <- FALSE
122	12x	if (any(not_ok) && verbose) {
123	1x	tot <- sum(not_ok)
124	1x	msg <- ngettext(tot, "%d %s variable was removed: %s.",
125	1x	"%d %s variables were removed: %s.")
126	1x	col <- paste(colnames(tmp)[not_ok], collapse = ", ")
127	1x	message(sprintf(msg, tot, what, col))
128		}
129		}
130
131	31x	list(
132	31x	data = as.matrix(x),
133	31x	sup = sup,
134	31x	extra = extra
135		)
136		}

1		# TOOLS
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname cdt
7		#' @aliases cdt,matrix-method
8		setMethod(
9		f = "cdt",
10		signature = c(object = "matrix"),
11		definition = function(object, exclude = NULL, abbrev = TRUE) {
12		## Fix colnames
13	8x	if (is.null(colnames(object))) {
14	!	colnames(object) <- paste0("V", seq_len(ncol(object)))
15		}
16
17	8x	d <- apply(
18	8x	X = object,
19	8x	MARGIN = 2,
20	8x	FUN = function(cl, exclude) {
21	24x	cl <- factor(x = cl, exclude = exclude)
22	24x	n <- length(cl)
23	24x	z <- matrix(0, nrow = n, ncol = nlevels(cl))
24	24x	z[seq_len(n) + n * (unclass(cl) - 1)] <- 1
25	24x	dimnames(z) <- list(names(cl), levels(cl))
26	24x	z
27		},
28	8x	exclude = exclude,
29	8x	simplify = FALSE
30		)
31	8x	mtx <- do.call(cbind, d)
32
33	8x	if (!abbrev) {
34	3x	n <- vapply(X = d, FUN = ncol, FUN.VALUE = integer(1))
35	3x	colnames(mtx) <- paste(rep(colnames(object), n), colnames(mtx), sep = "_")
36		}
37
38	8x	mtx
39		}
40		)
41
42		#' @export
43		#' @rdname cdt
44		#' @aliases cdt,data.frame-method
45		setMethod(
46		f = "cdt",
47		signature = c(object = "data.frame"),
48		definition = function(object, exclude = NULL, abbrev = TRUE) {
49	6x	object <- as.matrix(object)
50	6x	methods::callGeneric(object, exclude = exclude, abbrev = abbrev)
51		}
52		)
53
54		#' @export
55		#' @rdname burt
56		#' @aliases burt,data.frame-method
57		setMethod(
58		f = "burt",
59		signature = c(object = "data.frame"),
60		definition = function(object, exclude = NULL, abbrev = TRUE) {
61	1x	x <- cdt(object, exclude = exclude, abbrev = abbrev)
62	1x	crossprod(x, x)
63		}
64		)

1		# SHOW
2		#' @include AllGenerics.R
3		NULL
4
5		setMethod(
6		f = "show",
7		signature = "CA",
8		definition = function(object) {
9	1x	cat(
10	1x	tr_("Correspondence Analysis (CA):"),
11	1x	utils::capture.output(describe(object)),
12	1x	sep = "\n"
13		)
14	1x	invisible(object)
15		}
16		)
17
18		setMethod(
19		f = "show",
20		signature = "MCA",
21		definition = function(object) {
22	1x	cat(
23	1x	tr_("Multiple Correspondence Analysis (MCA):"),
24	1x	utils::capture.output(describe(object)),
25	1x	sep = "\n"
26		)
27	1x	invisible(object)
28		}
29		)
30
31		setMethod(
32		f = "show",
33		signature = "PCA",
34		definition = function(object) {
35	1x	cat(
36	1x	tr_("Principal Components Analysis (PCA):"),
37	1x	utils::capture.output(describe(object)),
38	1x	sep = "\n"
39		)
40	1x	invisible(object)
41		}
42		)
43
44		setMethod(
45		f = "show",
46		signature = "PCOA",
47		definition = function(object) {
48	!	cat(
49	!	tr_("Principal Coordinate Analysis (PCoA):"),
50	!	sprintf(tr_("* Method: %s."), object@method),
51	!	sep = "\n"
52		)
53	!	invisible(object)
54		}
55		)
56
57		setMethod(
58		f = "show",
59		signature = "MultivariateSummary",
60		definition = function(object) {
61		## Get options
62	6x	n_dig <- getOption("dimensio.digits")
63	6x	n_max <- getOption("dimensio.max.print")
64
65	6x	if (methods::is(object, "SummaryCA")) {
66	3x	active <- c(tr_("Active rows"), tr_("Active columns"))
67	3x	suppl <- c(tr_("Supplementary rows"), tr_("Supplementary columns"))
68	3x	title <- tr_("Correspondence Analysis (CA)")
69		}
70	6x	if (methods::is(object, "SummaryPCA")) {
71	3x	active <- c(tr_("Active individuals"), tr_("Active variables"))
72	3x	suppl <- c(tr_("Supplementary individuals"), tr_("Supplementary variables"))
73	3x	title <- tr_("Principal Components Analysis (PCA)")
74		}
75
76		## Get data
77	6x	eig <- round(object@eigenvalues, digits = n_dig)
78	6x	res <- round(object@results, digits = n_dig)
79
80		## Prepare data
81	6x	is_sup <- object@supplement
82	6x	eigen <- c(paste0("\n## ", tr_("Eigenvalues")), "",
83	6x	utils::capture.output(format_table(eig)))
84
85		## Supplementary points
86	6x	sum_sup <- extra_sup <- NULL
87	6x	if (any(is_sup)) {
88	4x	res_sup <- res[is_sup, ]
89	4x	n_sup <- nrow(res_sup)
90	4x	if (n_sup > n_max) {
91	!	res_sup <- res_sup[seq_len(n_max), ]
92	!	extra_sup <- sprintf("(%s more)", n_sup - n_max)
93		}
94	4x	is_na <- apply(X = res_sup, MARGIN = 2, FUN = anyNA)
95	4x	res_sup <- res_sup[, !is_na]
96	4x	sum_sup <- c(paste0("\n## ", suppl[[object@margin]]), "",
97	4x	utils::capture.output(format_table(res_sup)))
98		}
99
100		## Active points
101	6x	sum_act <- extra_act <- NULL
102	6x	if (any(!is_sup)) {
103	4x	res_act <- res[!is_sup, ]
104	4x	n_act <- nrow(res_act)
105	4x	if (n_act > n_max) {
106	4x	res_act <- res_act[seq_len(n_max), ]
107	4x	extra_act <- sprintf("(%s more)", n_act - n_max)
108		}
109	4x	sum_act <- c(paste0("\n## ", active[[object@margin]]), "",
110	4x	utils::capture.output(format_table(res_act)))
111		}
112
113		## Print
114	6x	header <- paste0("# ", title)
115	6x	cat(header, eigen, sum_act, extra_act, sum_sup, extra_sup, sep = "\n")
116	6x	invisible(object)
117		}
118		)
119
120
121		format_table <- function(x) {
122	14x	val <- rbind(colnames(x), format_head(colnames(x), left = FALSE), x)
123	14x	val <- apply(X = val, MARGIN = 2, FUN = format_col, left = FALSE)
124	14x	row_names <- c("", format_head(rownames(x))[which.max(nchar(rownames(x)))], rownames(x))
125	14x	val <- cbind(format_col(row_names), val)
126	14x	val <- apply(X = val, MARGIN = 1, FUN = format_row)
127	14x	cat(val, sep = "\n")
128		}
129
130		vec_rep <- function(x, times) {
131	28x	force(x)
132	28x	vapply(
133	28x	X = times,
134	28x	FUN = function(i) paste0(rep(x, i), collapse = ""),
135	28x	FUN.VALUE = character(1)
136		)
137		}
138		format_head <- function(x, left = TRUE) {
139	28x	n <- nchar(x) - 1
140	28x	d <- vec_rep("-", n)
141	14x	if (left) paste0(":", d) else paste0(d, ":")
142		}
143		format_col <- function(x, left = TRUE) {
144	80x	n <- max(nchar(x))
145	80x	d <- vapply(
146	80x	X = n - nchar(x),
147	80x	FUN = function(i) ifelse(i == 0, "", paste0(rep(" ", i), collapse = "")),
148	80x	FUN.VALUE = character(1)
149		)
150	14x	if (left) paste0(x, d) else paste0(d, x)
151		}
152		format_row <- function(x) {
153	116x	paste0("\| ", paste0(x, collapse = " \| "), " \|")
154		}

1		# PLOT CONTRIBUTIONS
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname viz_contributions
7		#' @aliases viz_contributions,MultivariateAnalysis-method
8		setMethod(
9		f = "viz_contributions",
10		signature = c(x = "MultivariateAnalysis"),
11		definition = function(x, ..., margin = 2, axes = 1,
12		sort = TRUE, decreasing = TRUE, limit = 10,
13		horiz = FALSE, col = "grey90", border = "grey10") {
14		## Prepare data
15	4x	data <- prepare_contrib(x, margin = margin, axes = axes, sort = sort,
16	4x	decreasing = decreasing, limit = limit)
17
18		## Expected average contribution
19	4x	theo <- 100 / length(data$y)
20	4x	if (length(axes) > 1) {
21	2x	eig <- get_eigenvalues(x)[axes, 1]
22	2x	theo <- sum(theo * eig) / sum(eig)
23		}
24
25		## Bar plot
26	4x	msg <- tr_("Contribution to %s (%%)")
27	4x	ylab <- sprintf(msg, paste0("F", axes, collapse = "-"))
28	4x	mid <- graphics::barplot(
29	4x	height = data$y,
30	4x	names.arg = data$x,
31	4x	horiz = horiz,
32	4x	xlab = if (horiz) ylab else NULL,
33	4x	ylab = if (horiz) NULL else ylab,
34	4x	col = col,
35	4x	border = border,
36	4x	las = 1,
37		...
38		)
39	4x	graphics::abline(h = theo, lty = 2, col = "red")
40
41	4x	invisible(x)
42		}
43		)
44
45		# Must return a data.frame (`x`, `y`, `label`)
46		prepare_contrib <- function(object, margin, axes, sort = TRUE,
47		decreasing = TRUE, limit = 10) {
48		## Get data
49	4x	contrib <- get_contributions(object, margin = margin)
50	4x	if (length(axes) > 1) {
51	2x	values <- joint_contributions(object, margin = margin, axes = axes)
52		} else {
53	2x	values <- contrib[[axes[[1]]]]
54		}
55
56		## Prepare data
57	4x	data <- data.frame(
58	4x	x = rownames(contrib),
59	4x	y = values,
60	4x	label = round(values, digits = 2)
61		)
62
63		## Sort data
64	4x	if (sort) {
65	4x	data <- data[order(data$y, decreasing = decreasing), ]
66		}
67
68		## Subset
69	4x	if (!is.null(limit)) {
70	4x	limit <- min(nrow(data), limit)
71	4x	data <- data[seq_len(limit), , drop = FALSE]
72		}
73
74		## Prevent reordering
75	4x	data$x <- factor(data$x, levels = unique(data$x))
76
77	4x	data
78		}

1		# GET DISTANCES
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname get_eigenvalues
7		#' @aliases get_distances,MultivariateAnalysis-method
8		setMethod(
9		f = "get_distances",
10		signature = c(x = "MultivariateAnalysis"),
11		definition = function(x, margin = 1) {
12	12x	arkhe::assert_scalar(margin, "numeric")
13
14	12x	if (margin == 1) {
15	9x	d2 <- x@rows@distances
16	9x	names(d2) <- x@rows@names
17	9x	suppl <- x@rows@supplement
18		}
19	12x	if (margin == 2) {
20	3x	d2 <- x@columns@distances
21	3x	names(d2) <- x@columns@names
22	3x	suppl <- x@columns@supplement
23		}
24
25	12x	d2
26		}
27		)

1		# GET COORDINATES
2		#' @include AllGenerics.R
3		NULL
4
5		# Coordinates ==================================================================
6		#' @export
7		#' @rdname get_coordinates
8		#' @aliases get_coordinates,MultivariateAnalysis-method
9		setMethod(
10		f = "get_coordinates",
11		signature = c(x = "MultivariateAnalysis"),
12		definition = function(x, margin = 1, principal = TRUE, sup_name = ".sup") {
13	152x	arkhe::assert_scalar(margin, "numeric")
14	152x	arkhe::assert_scalar(principal, "logical")
15	152x	arkhe::assert_scalar(sup_name, "character")
16
17	152x	if (margin == 1) {
18	84x	coords <- x@rows@principal
19	84x	suppl <- x@rows@supplement
20	84x	id <- x@rows@names
21		}
22	152x	if (margin == 2) {
23	68x	coords <- x@columns@principal
24	68x	suppl <- x@columns@supplement
25	68x	id <- x@columns@names
26		}
27
28		# P = sqrt(eigenvalue) X S
29	152x	if (!principal) {
30	20x	coords <- t(t(coords) / x@singular_values)
31		}
32
33	152x	coords <- as.data.frame(coords, row.names = id)
34	152x	coords[[sup_name]] <- suppl
35
36	152x	coords
37		}
38		)
39
40		#' @export
41		#' @rdname get_coordinates
42		#' @aliases get_coordinates,PCOA-method
43		setMethod(
44		f = "get_coordinates",
45		signature = c(x = "PCOA"),
46		definition = function(x) {
47	9x	as.data.frame(x@points)
48		}
49		)
50
51		# Replications =================================================================
52		#' @export
53		#' @rdname get_coordinates
54		#' @aliases get_replications,MultivariateBootstrap-method
55		setMethod(
56		f = "get_replications",
57		signature = c(x = "MultivariateBootstrap"),
58		definition = function(x, margin = 1) {
59	3x	coords <- get_coordinates(x = x, margin = margin)
60
61	3x	k <- x@replications
62	3x	i <- nrow(coords) / (k + 1)
63	3x	j <- ncol(coords) - 1
64
65		## Drop the original data and the last column
66	3x	repl_coords <- coords[-seq_len(i), seq_len(j)]
67	3x	repl <- split(x = repl_coords, f = rep(seq_len(k), each = i))
68	3x	repl <- array(data = unlist(repl), dim = c(i, j, k))
69	3x	rownames(repl) <- rownames(coords)[seq_len(i)]
70	3x	colnames(repl) <- colnames(repl_coords)
71	3x	repl
72		}
73		)
74
75		#' @export
76		#' @rdname get_coordinates
77		#' @aliases get_replications,BootstrapPCA-method
78		setMethod(
79		f = "get_replications",
80		signature = c(x = "BootstrapPCA"),
81		definition = function(x) {
82	1x	methods::callNextMethod(x = x, margin = 2)
83		}
84		)

1		# GET EIGENVALUES
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname get_eigenvalues
7		#' @aliases get_eigenvalues,MultivariateAnalysis-method
8		setMethod(
9		f = "get_eigenvalues",
10		signature = c(x = "MultivariateAnalysis"),
11		definition = function(x) {
12	19x	eig <- x@singular_values^2 # Eigenvalues
13	19x	pvar <- eig / sum(eig) * 100 # Percentage
14	19x	cvar <- cumsum(pvar) # Cumulative percentage
15
16	19x	z <- data.frame(eig, pvar, cvar)
17	19x	colnames(z) <- c("eigenvalues", "variance", "cumulative")
18	19x	z
19		}
20		)
21
22		#' @export
23		#' @rdname get_eigenvalues
24		#' @aliases get_eigenvalues,PCOA-method
25		setMethod(
26		f = "get_eigenvalues",
27		signature = c(x = "PCOA"),
28		definition = function(x) {
29	1x	eig <- x@eigenvalues# Eigenvalues
30	1x	pvar <- eig / sum(eig) * 100 # Percentage
31	1x	cvar <- cumsum(pvar) # Cumulative percentage
32
33	1x	z <- data.frame(eig, pvar, cvar)
34	1x	colnames(z) <- c("eigenvalues", "variance", "cumulative")
35	1x	z
36		}
37		)

1		# PLOT COORDINATES
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @method plot PCOA
7		plot.PCOA <- function(x, ..., axes = c(1, 2), labels = FALSE,
8		extra_quali = NULL, extra_quanti = NULL,
9		ellipse = NULL, hull = FALSE,
10		color = NULL, fill = FALSE, symbol = FALSE, size = c(1, 6),
11		xlim = NULL, ylim = NULL, main = NULL, sub = NULL,
12		ann = graphics::par("ann"), frame.plot = TRUE,
13		panel.first = NULL, panel.last = NULL,
14		legend = list(x = "topleft")) {
15		## Set axes
16	5x	arkhe::assert_type(axes, "numeric")
17	5x	arkhe::assert_length(axes, 2)
18	5x	assign("axes", value = axes, envir = the)
19
20		## Prepare data
21	5x	coord <- get_coordinates(x)
22	5x	coord$x <- coord[[axes[[1L]]]]
23	5x	coord$y <- coord[[axes[[2L]]]]
24	5x	n <- NROW(coord)
25
26		## Set graphical parameters
27		## (recycle if of length one)
28	5x	dots <- list(...)
29	5x	col <- recycle(dots$col %\|\|% graphics::par("col"), n)
30	5x	bg <- recycle(dots$bg %\|\|% graphics::par("bg"), n)
31	5x	pch <- recycle(dots$pch %\|\|% 16, n)
32	5x	cex <- recycle(dots$cex %\|\|% graphics::par("cex"), n)
33
34		## Highlight quantitative information
35	5x	if (length(extra_quanti) > 0) {
36	1x	arkhe::assert_type(extra_quanti, "numeric")
37	1x	arkhe::assert_length(extra_quanti, n)
38		## Continuous scales
39		## (ignored if col, bg and cex are set by user)
40	1x	if (is.null(dots$col) && !isFALSE(color))
41	1x	col <- khroma::palette_color_continuous(colors = color)(extra_quanti)
42	1x	if (is.null(dots$bg) && !isFALSE(fill))
43	!	bg <- khroma::palette_color_continuous(colors = fill)(extra_quanti)
44	1x	if (is.null(dots$cex) && !isFALSE(size))
45	1x	cex <- khroma::palette_size_sequential(range = size)(extra_quanti)
46		}
47		## Highlight qualitative information
48	5x	if (length(extra_quali) > 0) {
49	4x	arkhe::assert_length(extra_quali, n)
50		## Discrete scales
51		## (ignored if col, bg and pch are set by user)
52	4x	if (is.null(dots$col) && !isFALSE(color))
53	4x	col <- khroma::palette_color_discrete(colors = color)(extra_quali)
54	4x	if (is.null(dots$bg) && !isFALSE(fill))
55	!	bg <- khroma::palette_color_discrete(colors = fill)(extra_quali)
56	4x	if (is.null(dots$pch) && !isFALSE(symbol))
57	!	pch <- khroma::palette_shape(symbols = symbol)(extra_quali)
58		}
59
60		## Save and restore graphical parameters
61		## pty: square plotting region, independent of device size
62	5x	old_par <- graphics::par(pty = "s", no.readonly = TRUE)
63	5x	on.exit(graphics::par(old_par), add = TRUE)
64
65		## Open new window
66	5x	grDevices::dev.hold()
67	5x	on.exit(grDevices::dev.flush(), add = TRUE)
68	5x	graphics::plot.new()
69
70		## Set plotting coordinates
71	5x	xlim <- xlim %\|\|% range(coord$x, na.rm = TRUE, finite = TRUE)
72	5x	ylim <- ylim %\|\|% range(coord$y, na.rm = TRUE, finite = TRUE)
73	5x	graphics::plot.window(xlim = xlim, ylim = ylim, asp = 1)
74
75		## Evaluate pre-plot expressions
76	5x	panel.first
77
78		## Plot
79	5x	graphics::abline(h = 0, lty = "dashed", lwd = 1, col = graphics::par("fg"))
80	5x	graphics::abline(v = 0, lty = "dashed", lwd = 1, col = graphics::par("fg"))
81	5x	graphics::points(x = coord$x, y = coord$y,
82	5x	col = col, bg = bg, pch = pch, cex = cex)
83
84		## Labels
85	5x	if (isTRUE(labels)) {
86	!	label(
87	!	x = coord$x,
88	!	y = coord$y,
89	!	labels = rownames(coord),
90	!	type = "shadow",
91	!	col = col,
92	!	cex = cex,
93	!	xpd = TRUE
94		)
95		}
96
97	5x	if (length(extra_quali) > 0) {
98		## Add ellipse
99	4x	if (is.list(ellipse) && length(ellipse) > 0) {
100	2x	args_ell <- list(x = x, group = extra_quali, axes = axes,
101	2x	color = color, fill = FALSE, symbol = FALSE)
102	2x	ellipse <- modifyList(args_ell, val = ellipse)
103	2x	do.call(viz_ellipses, ellipse)
104		}
105		## Add convex hull
106	4x	if (isTRUE(hull)) {
107	1x	args_hull <- list(x = x, group = extra_quali, axes = axes,
108	1x	color = color, fill = FALSE, symbol = FALSE)
109	1x	do.call(viz_hull, args_hull)
110		}
111		}
112
113		## Evaluate post-plot and pre-axis expressions
114	5x	panel.last
115
116		## Construct axis (axes)
117	5x	if (TRUE) {
118	5x	graphics::axis(side = 1, las = 1)
119	5x	graphics::axis(side = 2, las = 1)
120		}
121
122		## Plot frame
123	5x	if (frame.plot) {
124	5x	graphics::box()
125		}
126
127		## Add annotation
128	5x	if (ann) {
129	5x	graphics::title(
130	5x	main = main, sub = sub,
131	5x	xlab = colnames(coord)[axes[[1]]],
132	5x	ylab = colnames(coord)[axes[[2]]]
133		)
134		}
135
136		## Legend
137	5x	coord <- data.frame(
138	5x	extra_quanti = if (length(extra_quanti) > 0) extra_quanti else rep(NA, n),
139	5x	extra_quali = if (length(extra_quali) > 0) extra_quali else rep(NA, n),
140	5x	cex = cex, col = col, bg = bg, pch = pch, lty = rep(NA, n)
141		)
142	5x	prepare_legend(coord, legend, points = TRUE, lines = FALSE)
143
144	5x	invisible(x)
145		}
146
147		#' @export
148		#' @rdname plot
149		#' @aliases plot,PCOA,missing-method
150		setMethod("plot", c(x = "PCOA", y = "missing"), plot.PCOA)

1		# MUTATORS
2		#' @include AllGenerics.R
3		NULL
4
5		# Non exported =================================================================
6		is_centered <- function(x) {
7	31x	!all(x@center == 0)
8		}
9		is_scaled <- function(x) {
10	49x	!all(x@scale == 1)
11		}
12
13		get_masses <- function(x, margin = 1) {
14	56x	margin <- margin[[1L]]
15	30x	if (margin == 1) mass <- x@rows@weights
16	26x	if (margin == 2) mass <- x@columns@weights
17	56x	mass
18		}
19
20		get_order <- function(x, margin = 1) {
21	58x	margin <- margin[[1L]]
22	35x	if (margin == 1) ord <- x@rows@order
23	23x	if (margin == 2) ord <- x@columns@order
24	58x	ord
25		}
26
27		# Groups =======================================================================
28		get_groups <- function(x, margin = 1) {
29	6x	margin <- margin[[1L]]
30	2x	if (margin == 1) grp <- x@rows@groups
31	4x	if (margin == 2) grp <- x@columns@groups
32	6x	grp
33		}
34
35		`set_groups<-` <- function(x, margin = 1, value) {
36	!	if (is.null(value)) value <- character(0)
37	!	margin <- margin[[1L]]
38	!	if (margin == 1) x@rows@groups <- value
39	!	if (margin == 2) x@columns@groups <- value
40	!	methods::validObject(x)
41	!	x
42		}
43
44		has_groups <- function(x, margin = 1) {
45	13x	margin <- margin[[1L]]
46	6x	if (margin == 1) grp <- x@rows@groups
47	7x	if (margin == 2) grp <- x@columns@groups
48	13x	length(grp) > 0
49		}
50
51		# Dimensions ===================================================================
52		#' @export
53		#' @method dim MultivariateAnalysis
54		dim.MultivariateAnalysis <- function(x) {
55	2x	x@dimension
56		}
57
58		#' @export
59		#' @rdname dimnames
60		#' @aliases dim,MultivariateAnalysis-method
61		setMethod("dim", "MultivariateAnalysis", dim.MultivariateAnalysis)
62
63		#' @export
64		#' @method rownames MultivariateAnalysis
65		rownames.MultivariateAnalysis <- function(x, do.NULL = TRUE, prefix = "row") {
66	3x	dn <- dimnames(x)
67	3x	if (!is.null(dn[[1L]]))
68	3x	dn[[1L]]
69		else {
70	!	nr <- NROW(x@rows@principal)
71	!	if (do.NULL)
72	!	NULL
73	!	else if (nr > 0L)
74	!	paste0(prefix, seq_len(nr))
75	!	else character()
76		}
77		}
78
79		#' @export
80		#' @rdname dimnames
81		#' @aliases rownames,MultivariateAnalysis-method
82		setMethod("rownames", "MultivariateAnalysis", rownames.MultivariateAnalysis)
83
84		#' @export
85		#' @method colnames MultivariateAnalysis
86		colnames.MultivariateAnalysis <- function(x, do.NULL = TRUE, prefix = "col") {
87	2x	dn <- dimnames(x)
88	2x	if (!is.null(dn[[2L]]))
89	2x	dn[[2L]]
90		else {
91	!	nc <- NROW(x@columns@principal)
92	!	if (do.NULL)
93	!	NULL
94	!	else if (nc > 0L)
95	!	paste0(prefix, seq_len(nc))
96	!	else character()
97		}
98		}
99
100		#' @export
101		#' @rdname dimnames
102		#' @aliases colnames,MultivariateAnalysis-method
103		setMethod("colnames", "MultivariateAnalysis", colnames.MultivariateAnalysis)
104
105		#' @export
106		#' @method dimnames MultivariateAnalysis
107		dimnames.MultivariateAnalysis <- function(x) {
108	7x	list(x@rows@names, x@columns@names)
109		}
110
111		#' @export
112		#' @rdname dimnames
113		#' @aliases dimnames,MultivariateAnalysis-method
114		setMethod("dimnames", "MultivariateAnalysis", dimnames.MultivariateAnalysis)

1		# GET CORRELATIONS
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname get_contributions
7		#' @aliases get_correlations,PCA-method
8		setMethod(
9		f = "get_correlations",
10		signature = c(x = "PCA"),
11		definition = function(x, sup_name = ".sup") {
12	1x	arkhe::assert_scalar(sup_name, "character")
13
14	1x	corr <- x@columns@principal / x@columns@distances
15	1x	suppl <- x@columns@supplement
16
17	1x	corr <- as.data.frame(corr)
18	1x	corr[[sup_name]] <- suppl
19
20	1x	corr
21		}
22		)

1		# CLASSES DEFINITION
2
3		# Register S3 classes ==========================================================
4		setOldClass("dist")
5
6		# MultivariateAnalysis =========================================================
7		## Results ---------------------------------------------------------------------
8		#' Multivariate Data Analysis Results
9		#'
10		#' An S4 class to store the results of a multivariate data analysis.
11		#' @slot names A [`character`] vector specifying the row names.
12		#' @slot principal A [`numeric`] [`matrix`] giving the principal coordinates.
13		#' @slot standard A [`numeric`] [`matrix`] giving the standard coordinates.
14		#' @slot contributions A [`numeric`] [`matrix`] giving the contributions to the
15		#' definition of the dimensions.
16		#' @slot cosine A [`numeric`] [`matrix`] giving the \eqn{cos^2}{cos2} values.
17		#' @slot distances A [`numeric`] vector giving the distances to centroid.
18		#' @slot weights A [`numeric`] vector giving the masses/weights.
19		#' @slot supplement A [`logical`] vector specifying the supplementary points.
20		#' @slot order An [`integer`] vector giving the original indices of the data
21		#' (computation moves all supplementary points at the end of the results).
22		#' @slot groups A [`character`] vector specifying the class for each
23		#' observation.
24		#' @author N. Frerebeau
25		#' @family class
26		#' @docType class
27		#' @name MultivariateResults
28		#' @aliases MultivariateResults-class
29		#' @keywords internal
30		.MultivariateResults <- setClass(
31		Class = "MultivariateResults",
32		slots = c(
33		names = "character",
34		principal = "matrix",
35		standard = "matrix",
36		contributions = "matrix",
37		cosine = "matrix",
38		distances = "numeric",
39		weights = "numeric",
40		supplement = "logical",
41		order = "integer",
42		groups = "character"
43		)
44		)
45
46		## Output ----------------------------------------------------------------------
47		#' Output of Multivariate Data Analysis
48		#'
49		#' A virtual S4 class to store the output of a multivariate data analysis.
50		#' @slot data A [`numeric`] [`matrix`].
51		#' @slot dimension An [`integer`] giving the dimension of the solution.
52		#' @slot singular_values A [`numeric`] vector giving the singular values.
53		#' @slot rows A [`MultivariateResults-class`] object.
54		#' @slot columns A [`MultivariateResults-class`] object.
55		#' @slot extra A [`list`] of extra variables.
56		#' @section Subset:
57		#' In the code snippets below, `x` is a `MultivariateAnalysis` object.
58		#' \describe{
59		#' \item{`x[[i]]`}{Extracts information from a slot selected by subscript `i`.
60		#' `i` is a length-one [`character`] vector.}
61		#' }
62		#' @author N. Frerebeau
63		#' @family class
64		#' @docType class
65		#' @name MultivariateAnalysis
66		#' @aliases MultivariateAnalysis-class
67		#' @keywords internal
68		.MultivariateAnalysis <- setClass(
69		Class = "MultivariateAnalysis",
70		slots = c(
71		data = "matrix",
72		dimension = "integer",
73		singular_values = "numeric",
74		rows = "MultivariateResults",
75		columns = "MultivariateResults",
76		extra = "list"
77		),
78		contains = "VIRTUAL"
79		)
80
81		## Bootstrap -------------------------------------------------------------------
82		#' Output of Bootstrap Replications
83		#'
84		#' A virtual S4 class to store the output of a bootstrap analysis.
85		#' @slot replications An [`integer`] giving the number of bootstrap
86		#' replications.
87		#' @author N. Frerebeau
88		#' @family class
89		#' @docType class
90		#' @name MultivariateBootstrap
91		#' @aliases MultivariateBootstrap-class
92		#' @keywords internal
93		.MultivariateBootstrap <- setClass(
94		Class = "MultivariateBootstrap",
95		slots = c(
96		replications = "integer"
97		),
98		contains = "VIRTUAL"
99		)
100
101		## Summary ---------------------------------------------------------------------
102		#' Summary of Multivariate Data Analysis
103		#'
104		#' A virtual S4 class to store the summary of a multivariate data analysis.
105		#' @slot data A [`numeric`] [`matrix`].
106		#' @slot eigenvalues A [`numeric`] [`matrix`].
107		#' @slot results A [`numeric`] [`matrix`].
108		#' @slot supplement A [`logical`] vector specifying the supplementary points.
109		#' @slot margin An [`integer`].
110		#' @author N. Frerebeau
111		#' @family class
112		#' @docType class
113		#' @name MultivariateSummary
114		#' @aliases MultivariateSummary-class
115		#' @keywords internal
116		.MultivariateSummary <- setClass(
117		Class = "MultivariateSummary",
118		slots = c(
119		data = "matrix",
120		eigenvalues = "matrix",
121		results = "matrix",
122		supplement = "logical",
123		margin = "integer"
124		),
125		contains = "VIRTUAL"
126		)
127
128		#' @rdname MultivariateSummary
129		#' @aliases SummaryCA-class
130		.SummaryCA <- setClass(
131		Class = "SummaryCA",
132		contains = "MultivariateSummary"
133		)
134
135		#' @rdname MultivariateSummary
136		#' @aliases SummaryPCA-class
137		.SummaryPCA <- setClass(
138		Class = "SummaryPCA",
139		contains = "MultivariateSummary"
140		)
141
142		# CA ===========================================================================
143		#' CA Results
144		#'
145		#' An S4 class to store the results of a simple correspondence analysis.
146		#' @note
147		#' This class inherits from [`MultivariateAnalysis-class`].
148		#' @example inst/examples/ex-ca.R
149		#' @author N. Frerebeau
150		#' @family class
151		#' @docType class
152		#' @exportClass CA
153		#' @aliases CA-class
154		#' @keywords internal
155		.CA <- setClass(
156		Class = "CA",
157		contains = "MultivariateAnalysis"
158		)
159
160		#' Bootstrap CA Results
161		#'
162		#' An S4 class to store the bootstrap of a correspondence analysis.
163		#' @note
164		#' This class inherits from [`CA-class`] and [`MultivariateBootstrap-class`].
165		#' @example inst/examples/ex-bootstrap.R
166		#' @author N. Frerebeau
167		#' @family class
168		#' @docType class
169		#' @aliases BootstrapCA-class
170		#' @keywords internal
171		.BootstrapCA <- setClass(
172		Class = "BootstrapCA",
173		contains = c("MultivariateBootstrap", "CA")
174		)
175
176		# MCA ==========================================================================
177		#' MCA Results
178		#'
179		#' An S4 class to store the results of a multiple correspondence analysis.
180		#' @note
181		#' This class inherits from [`CA-class`].
182		# @example inst/examples/ex-mca.R
183		#' @author N. Frerebeau
184		#' @family class
185		#' @docType class
186		#' @exportClass MCA
187		#' @aliases MCA-class
188		#' @keywords internal
189		.MCA <- setClass(
190		Class = "MCA",
191		contains = "CA"
192		)
193
194		# PCA ==========================================================================
195		#' PCA Results
196		#'
197		#' An S4 class to store the results of a principal components analysis.
198		#' @slot center A [`numeric`] vector giving the column mean of the initial
199		#' dataset (active individuals only).
200		#' @slot scale A [`numeric`] vector giving the column standard deviations of the
201		#' initial dataset (active individuals only).
202		#' @note
203		#' This class inherits from [`MultivariateAnalysis-class`].
204		#' @example inst/examples/ex-pca.R
205		#' @author N. Frerebeau
206		#' @family class
207		#' @docType class
208		#' @exportClass PCA
209		#' @aliases PCA-class
210		#' @keywords internal
211		.PCA <- setClass(
212		Class = "PCA",
213		slots = c(
214		center = "numeric",
215		scale = "numeric"
216		),
217		contains = "MultivariateAnalysis"
218		)
219
220		#' Bootstrap PCA Results
221		#'
222		#' An S4 class to store the bootstrap of a principal components analysis.
223		#' @note
224		#' This class inherits from [`PCA-class`] and [`MultivariateBootstrap-class`].
225		#' @example inst/examples/ex-bootstrap.R
226		#' @author N. Frerebeau
227		#' @family class
228		#' @docType class
229		#' @aliases BootstrapPCA-class
230		#' @keywords internal
231		.BootstrapPCA <- setClass(
232		Class = "BootstrapPCA",
233		contains = c("MultivariateBootstrap", "PCA")
234		)
235
236		# PCOA =========================================================================
237		#' PCoA Results
238		#'
239		#' An S4 class to store the results of a principal coordinates analysis.
240		#' @slot points A `numeric` matrix whose rows give the coordinates of the points
241		#' chosen to represent the dissimilarities.
242		#' @slot eigenvalues A [`numeric`] vector giving the eigenvalues computed during
243		#' the scaling process.
244		#' @slot method A [`character`] string giving the distance that has been used to
245		#' create the distance structure.
246		#' @slot GOF A length-two [`numeric`] vector.
247		#' @slot groups A [`character`] vector specifying the class for each
248		#' observation.
249		#' @example inst/examples/ex-pcoa.R
250		#' @author N. Frerebeau
251		#' @family class
252		#' @docType class
253		#' @exportClass PCOA
254		#' @aliases PCOA-class
255		#' @keywords internal
256		.PCOA <- setClass(
257		Class = "PCOA",
258		slots = c(
259		points = "matrix",
260		eigenvalues = "numeric",
261		GOF = "numeric",
262		method = "character",
263		groups = "character"
264		)
265		)
266
267		# Initialize ===================================================================
268		build_results <- function(names, principal, standard, contributions,
269		distances, cosine, weights, supplement,
270		groups = NULL) {
271		## /!\ Reorder active/supplementary points /!\
272		## Computation moves all supplementary points at the end of the results
273	53x	new_i <- seq_len(nrow(principal))
274	53x	sup_i <- new_i * -1
275	53x	if (any(supplement)) {
276	13x	sup_i <- utils::tail(new_i, n = sum(supplement))
277	13x	new_i <- c(new_i[!supplement], new_i[supplement])
278	13x	names <- names[new_i]
279	13x	if (length(groups) > 0) {
280	1x	groups <- groups[new_i]
281		}
282		}
283
284		## Prepare names
285		# names <- rep(names, length.out = length(supplement))
286	53x	col_names <- paste0("F", seq_len(ncol(principal)))
287	53x	dim_names0 <- list(names[-sup_i], col_names)
288	53x	dim_names1 <- list(names, col_names)
289
290		## Set names
291	53x	dimnames(principal) <- dimnames(cosine) <- dim_names1
292	53x	dimnames(standard) <- dimnames(contributions) <- dim_names0
293	53x	names(distances) <- names
294	53x	names(weights) <- names[!supplement]
295
296	53x	.MultivariateResults(
297	53x	names = names,
298	53x	principal = principal,
299	53x	standard = standard,
300	53x	contributions = contributions,
301	53x	cosine = cosine,
302	53x	distances = distances,
303	53x	weights = weights,
304	53x	supplement = sort(supplement),
305	53x	order = new_i,
306	53x	groups = groups %\|\|% character(0)
307		)
308		}

1		# GET INERTIA
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname get_eigenvalues
7		#' @aliases get_inertia,MultivariateAnalysis-method
8		setMethod(
9		f = "get_inertia",
10		signature = c(x = "MultivariateAnalysis"),
11		definition = function(x, margin = 1) {
12	7x	arkhe::assert_scalar(margin, "numeric")
13
14	7x	if (margin == 1) {
15	4x	masses <- x@rows@weights
16	4x	d2 <- x@rows@distances
17	4x	suppl <- x@rows@supplement
18	4x	name <- x@rows@names
19		}
20	7x	if (margin == 2) {
21	3x	masses <- x@columns@weights
22	3x	d2 <- x@columns@distances
23	3x	suppl <- x@columns@supplement
24	3x	name <- x@columns@names
25		}
26
27	7x	i <- masses * d2[!suppl]
28	7x	names(i) <- name[!suppl]
29	7x	i
30		}
31		)

1		# PLOT COS2
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname viz_contributions
7		#' @aliases viz_cos2,MultivariateAnalysis-method
8		setMethod(
9		f = "viz_cos2",
10		signature = c(x = "MultivariateAnalysis"),
11		definition = function(x, ..., margin = 2, axes = 1, active = TRUE,
12		sup = TRUE, sort = TRUE, decreasing = TRUE,
13		limit = 10, horiz = FALSE,
14		col = "grey90", border = "grey10") {
15		## Prepare data
16	2x	data <- prepare_cos2(x, margin = margin, axes = axes,
17	2x	active = active, sup = sup, sort = sort,
18	2x	decreasing = decreasing, limit = limit)
19
20	2x	xx <- paste0("(F", axes, ")", collapse = "-")
21	2x	ylab <- bquote(paste(plain(cos)^2~.(xx)))
22
23		## Bar plot
24	2x	mid <- graphics::barplot(
25	2x	height = data$y,
26	2x	names.arg = data$x,
27	2x	horiz = horiz,
28	2x	xlab = if (horiz) ylab else NULL,
29	2x	ylab = if (horiz) NULL else ylab,
30	2x	col = col,
31	2x	border = border,
32	2x	las = 1,
33		...
34		)
35
36	2x	invisible(x)
37		}
38		)
39
40		# Must return a data.frame (`x`, `y`, `label`)
41		prepare_cos2 <- function(object, margin, axes, active = TRUE, sup = TRUE,
42		sort = TRUE, decreasing = TRUE, limit = 10) {
43		## Get data
44	2x	cos2 <- get_cos2(object, margin = margin)
45	2x	if (length(axes) > 1) {
46	!	values <- joint_cos2(object, margin = margin, axes = axes)
47		} else {
48	2x	values <- cos2[[axes[[1]]]]
49		}
50
51		## Prepare data
52	2x	data <- data.frame(
53	2x	x = rownames(cos2),
54	2x	y = values,
55	2x	label = round(values, digits = 2)
56		)
57
58		## Subset
59	!	if (!active & sup) data <- data[cos2$.sup, ]
60	!	if (active & !sup) data <- data[!cos2$.sup, ]
61
62		## Sort data
63	2x	if (sort) {
64	2x	data <- data[order(data$y, decreasing = decreasing), ]
65		}
66
67		## Subset
68	2x	if (!is.null(limit)) {
69	2x	limit <- min(nrow(data), limit)
70	2x	data <- data[seq_len(limit), , drop = FALSE]
71		}
72
73		## Prevent reordering
74	2x	data$x <- factor(data$x, levels = unique(data$x))
75
76	2x	data
77		}

1		# MULTIPLE CORRESPONDENCE ANALYSIS
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname mca
7		#' @aliases mca,data.frame-method
8		setMethod(
9		f = "mca",
10		signature = c(object = "data.frame"),
11		definition = function(object, rank = NULL, sup_row = NULL, sup_col = NULL,
12		sup_quanti = NULL, autodetect = FALSE) {
13		## Remove numeric variables, if any
14	2x	clean <- drop_variable(object, f = is.numeric, negate = FALSE,
15	2x	sup = sup_col, extra = sup_quanti, auto = autodetect,
16	2x	what = "quantitative")
17
18		## Compute MCA
19	2x	results <- methods::callGeneric(object = clean$data, rank = rank,
20	2x	sup_row = sup_row, sup_col = clean$sup)
21
22		## Add supplementary quantitative variables
23	!	if (!is.null(clean$extra)) set_extra(results) <- clean$extra
24
25	2x	results
26		}
27		)
28
29		#' @export
30		#' @rdname mca
31		#' @aliases mca,matrix-method
32		setMethod(
33		f = "mca",
34		signature = c(object = "matrix"),
35		definition = function(object, rank = NULL, sup_row = NULL, sup_col = NULL) {
36		## Subset
37	2x	is_row_sup <- find_variable(sup_row, nrow(object), names = rownames(object))
38	2x	is_col_sup <- find_variable(sup_col, ncol(object), names = colnames(object))
39	2x	N <- object[, !is_col_sup, drop = FALSE]
40
41		## Complete disjunctive table
42	2x	Z <- cdt(N)
43
44		## Check missing values
45	2x	arkhe::assert_missing(Z)
46
47		## Get supplementary columns
48	2x	Z_tot <- Z
49	2x	sup_col <- NULL
50	2x	if (any(is_col_sup)) {
51	!	Z_sup <- cdt(object[, is_col_sup, drop = FALSE])
52	!	Z_tot <- cbind(Z, Z_sup)
53	!	sup_col <- seq_len(ncol(Z_sup)) + ncol(Z)
54		}
55
56		## Compute
57	2x	ndim <- min(rank, ncol(Z_tot) - sum(!is_col_sup))
58	2x	results <- ca(Z_tot, rank = ndim, sup_row = sup_row, sup_col = sup_col)
59
60	2x	.MCA(results)
61		}
62		)

1		# TIDY DATA
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname tidy
7		#' @aliases tidy,MultivariateAnalysis-method
8		setMethod(
9		f = "tidy",
10		signature = c(x = "MultivariateAnalysis"),
11		definition = function(x, ..., margin = 1, principal = TRUE) {
12		## Validation
13	6x	arkhe::assert_length(margin, 1)
14
15		## Get data
16	6x	coords <- get_coordinates(x, margin = margin, principal = principal)
17	6x	coords_long <- cbind(rownames(coords), coords[, ncol(coords)],
18	6x	utils::stack(coords[, -ncol(coords)]))
19	6x	colnames(coords_long) <- c("label", "supplementary", "coordinate", "component")
20
21	6x	contrib <- get_contributions(x, margin = margin)
22	6x	contrib_long <- cbind(rownames(contrib), utils::stack(contrib))
23	6x	colnames(contrib_long) <- c("label", "contribution", "component")
24
25	6x	cos2 <- get_cos2(x, margin = margin)
26	6x	cos2_long <- cbind(rownames(cos2), utils::stack(cos2[, -ncol(cos2)]))
27	6x	colnames(cos2_long) <- c("label", "cos2", "component")
28
29		## Join data
30	6x	Reduce(
31	6x	f = function(df1, df2) {
32	12x	merge(df1, df2, by = c("label", "component"), all = TRUE, sort = TRUE)
33		},
34	6x	x = list(coords_long, contrib_long, cos2_long)
35		)
36		}
37		)

1		# PRINCIPAL COORDINATES ANALYSIS
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname pcoa
7		#' @aliases pcoa,dist-method
8		setMethod(
9		f = "pcoa",
10		signature = c(object = "dist"),
11		definition = function(object, rank = 2) {
12		## Multidimensional scaling
13	1x	res <- stats::cmdscale(
14	1x	d = object,
15	1x	k = rank,
16	1x	eig = TRUE,
17	1x	add = FALSE,
18	1x	list. = TRUE
19		)
20
21	1x	points <- res$points
22	1x	colnames(points) <- paste0("F", seq_len(NCOL(points)))
23
24	1x	.PCOA(
25	1x	points = points,
26	1x	eigenvalues = res$eig,
27	1x	GOF= res$GOF,
28	1x	method = attr(object, "method") %\|\|% character(0)
29		)
30		}
31		)

1		# GET VARIANCE
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname get_eigenvalues
7		#' @aliases get_variance,MultivariateAnalysis-method
8		setMethod(
9		f = "get_variance",
10		signature = c(x = "MultivariateAnalysis"),
11		definition = function(x, digits = 2) {
12	76x	eig <- x@singular_values^2
13	76x	pc <- round(eig / sum(eig) * 100, digits = digits)
14	76x	return(pc)
15		}
16		)

1		# GET DATA
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname get_data
7		#' @aliases get_data,MultivariateAnalysis-method
8		setMethod(
9		f = "get_data",
10		signature = c(x = "MultivariateAnalysis"),
11		definition = function(x) {
12	2x	as.data.frame(x@data)
13		}
14		)
15
16		# Supplementary variables ======================================================
17		is_supplementary <- function(x, margin = 1) {
18	!	margin <- margin[[1L]]
19	!	if (margin == 1) supp <- x@rows@supplement
20	!	if (margin == 2) supp <- x@columns@supplement
21	!	supp
22		}
23
24		has_supplementary <- function(x, margin = 1) {
25	!	any(is_supplementary(x, margin = margin))
26		}
27
28		get_extra <- function(x) {
29	39x	as.data.frame(x@extra)
30		}
31
32		has_extra <- function(x) {
33	!	all(lengths(x@extra) > 0)
34		}
35
36		`set_extra<-` <- function(x, value) {
37	4x	value <- lapply(
38	4x	X = value,
39	4x	FUN = function(val, i) { val[i] },
40	4x	i = get_order(x, margin = 1)
41		)
42	4x	x@extra <- value
43	4x	methods::validObject(x)
44	4x	x
45		}