R/pc_flip.R

In nzilbb.vowels: Vowel Covariation Tools

#' Flip PC loadings
#'
#' The sign of the loadings and scores generated by PCA is arbitrary. Sometimes
#' it is convenient to flip them so that all positive loadings/scores become
#' negative (and vice versa). Sometimes one direction leads to a more natural
#' interpretation. It is also useful when comparing the results of PCA across
#' multiple data sets. This function will flip loadings and scores for PCA
#' analyses carried out by the base R [prcomp()] and [princomp()] functions and
#' for the [pca_test()] function from this package. If you specify only `pc_no`
#' you will flip the loadings and scores for that PC. You can also specify a
#' variable which you would like to have a positive loading in the resulting
#' PCA.
#'
#' @param pca_obj The result of a call to `prcomp()`, `princomp()` or `pca_test`.
#' @param pc_no An integer, indicating which PC is to be flipped.
#' @param flip_var An optional name of a variable which will become positive
#'  in the PC indicated by `pc_no`.
#'
#' @importFrom dplyr pull
#' @importFrom purrr pluck
#' @importFrom rlang .data
#'
#' @return An object matching the class of `pca_obj` with relevant PC modified.
#' @export
#'
#' @examples
#'   pca_obj <- prcomp(onze_intercepts |> dplyr::select(-speaker), scale=TRUE)
#'
#'   # flip the second PC
#'   flipped_pca <- pc_flip(pca_obj, pc_no = 2)
#'
#'   # flip (if necessary) the third PC, so that the "F1_GOOSE" variable has
#'   # a positive loading
#'   flipped_pca <- pc_flip(pca_obj, pc_no = 3, flip_var = "F1_GOOSE")
pc_flip <- function(pca_obj, pc_no, flip_var = NULL) {

  # This test could be a little more strict.
  stopifnot("`pc_no` must have a numeric value." = is.numeric(pc_no))

  if (inherits(pca_obj, "prcomp")) {
    scores_var <- "x"
    loadings_var <- "rotation"
  } else if (inherits(pca_obj, "princomp")) {
    scores_var <- "scores"
    loadings_var <- "loadings"
  }

  if (inherits(pca_obj, c("prcomp", "princomp"))) {

    if (!is.null(flip_var)) {
      stopifnot(
        "Invalid variable name in `flip`" =
          flip_var %in% rownames(pca_obj[[loadings_var]])
      )

      flip = sign(pca_obj[[loadings_var]][flip_var, pc_no])
    } else {
      flip = -1
    }

    # flip scores
    pca_obj[[scores_var]][, pc_no] <- pca_obj[[scores_var]][, pc_no] * flip

    # flip loadings
    pca_obj[[loadings_var]][, pc_no] <- pca_obj[[loadings_var]][, pc_no] * flip

    } else if (inherits(pca_obj, "pca_test_results")) {

      if (!is.null(flip_var)) {
        stopifnot(
          "Invalid variable name in `flip`" =
            flip_var %in% unique(pca_obj$loadings$variable)
        )

        # flip for loadings
        flip <- pca_obj$loadings |>
          filter(
            .data$PC == paste0('PC', pc_no), .data$variable == flip_var
          ) |>
          pull(.data$loading) |>
          pluck(1) |>
          sign()

      } else {
        flip = -1
      }

      # modify loadings
      pca_obj$loadings <- pca_obj$loadings |>
        mutate(
          loading = if_else(
            .data$PC == paste0('PC', pc_no),
            .data$loading * flip,
            .data$loading
          )
        )

      # modify 'raw data' for 'original', i.e., PCA applied to full data set.
      pca_obj$raw_data <- pca_obj$raw_data |>
        mutate(
          loading = if_else(
            .data$PC == paste0('PC', pc_no) & .data$source == "original",
            .data$loading * flip,
            .data$loading
          )
        )

    }
  # return modified pca object
  pca_obj
}