R/ord-format.r

In ordr: A 'tidyverse' Extension for Ordinations and Biplots

#' @title Format a tbl_ord for printing
#'
#' @description These methods of [base::format()] and [base::print()] render a
#'   (usually more) tidy readout of a [tbl_ord] that is consistent across all
#'   original ordination classes.
#'
#' @details
#'
#' The `format` and `print` methods for class 'tbl_ord' are adapted from those
#' for class '[tbl_df][tibble::tbl_df]' and for class 'tbl_graph' from the
#' **tidygraph** package.
#'
#' **Note:** The `format()` function is tedius but cannot be easily modularized
#' without invoking [recoverers], [annotation], and [augmentation] multiple
#' times, thereby significantly reducing performance.
#' 

#' @name format
#' @importFrom rlang "%||%"
#' @param x A [tbl_ord].
#' @inheritParams tibble::format.tbl
#' @param ... Additional arguments.
#' @return The `format()` method returns a vector of strings that are more
#'   elegantly printed by the `print()` method, which itself returns the tbl_ord
#'   invisibly.

#' @rdname format
#' @export
format.tbl_ord <- function(
  x, width = NULL, ..., n = NULL,
  max_extra_cols = NULL, max_footer_lines = NULL
) {
  
  # raw components and parameters
  dims <- get_factor(x, .matrix = "dims")
  n_dims <- sapply(dims, nrow)
  coord <- get_coord(x)
  rk <- length(coord)
  dims_ann <- mapply(
    bind_cols,
    annotation_factor(x, .matrix = "dims"),
    #recover_aug_factor(x, .matrix = "dims"),
    SIMPLIFY = FALSE
  )
  names(dims_ann) <- c("rows", "cols")
  n_ann <- sapply(dims_ann, ncol)
  if (is.null(n)) {
    n <- ifelse(
      n_dims > tbl_ord_opt("print_max"),
      tbl_ord_opt("print_min"),
      n_dims
    )
  }
  width <- width %||% tbl_ord_opt("width") %||% getOption("width")
  
  # headers!
  prev_class <- setdiff(class(x), "tbl_ord")[1]
  tbl_ord_header <- paste0(
    "# A tbl_ord",
    if (!is.null(prev_class) && prev_class != "list") {
      paste0(" of class '", prev_class, "'")
    },
    ": (", n_dims[1], " x ", rk, ") x (", n_dims[2], " x ", rk, ")'"
  )
  coord_header <- paste0(
    "# ", rk,
    " coordinate", if(rk == 1) "" else "s",
    ": ",
    print_reps(coord)
  )
  supp_header <- if (! is.null(attr(x, "rows_supplement")) |
                     ! is.null(attr(x, "rows_supplement"))) {
    paste0(
      "# ",
      if (! is.null(attr(x, "rows_supplement"))) {
        paste0(nrow(attr(x, "rows_supplement")), " supplementary rows")
      },
      if (! is.null(attr(x, "rows_supplement")) &
          ! is.null(attr(x, "cols_supplement"))) {
        " and "
      },
      if (! is.null(attr(x, "cols_supplement"))) {
        paste0(nrow(attr(x, "cols_supplement")), " supplementary columns")
      }
    )
  } else NULL
  x_inertia <- get_conference(x)
  inertia_name <- function(p) {
    if (p == 0) return("standard")
    if (p == 1) return("principal")
    if (p == 0.5) return("symmetric")
    paste0(round(100 * p, digits = 0L), "% inertia")
  }
  dims_inertia <- if (is.null(x_inertia)) NULL else {
    paste0(" (", vapply(x_inertia, inertia_name, ""), ")")
  }
  dims_headers <- paste0(
    "# ", c("Rows", "Columns"),
    dims_inertia,
    ": [ ", n_dims, " x ", rk, " | ", n_ann, " ]"
  )
  names(dims_headers) <- c("rows", "cols")
  
  # format rows and columns separately
  # (should format together, then split, in order to sync coordinates)
  fmt_coord_rows <- format(
    as_tibble(dims$rows)[seq(n[1]), seq(min(rk, 3)), drop = FALSE],
    n = n[1], width = width / 2
  )
  fmt_coord_cols <- format(
    as_tibble(dims$cols)[seq(n[2]), seq(min(rk, 3)), drop = FALSE],
    n = n[2], width = width / 2
  )
  fmt_coord <- list(
    rows = unname(c(
      dims_headers["rows"],
      fmt_coord_rows[2],
      stringr::str_pad("", nchar(fmt_coord_rows[2])),
      fmt_coord_rows[seq(4, length(fmt_coord_rows))]
    )),
    cols = unname(c(
      dims_headers["cols"],
      fmt_coord_cols[2],
      stringr::str_pad("", nchar(fmt_coord_cols[2])),
      fmt_coord_cols[seq(4, length(fmt_coord_cols))]
    ))
  )
  
  # footers?
  dims_footers <- n_dims - n > 0
  fmt_ann <- lapply(seq(2), function(i) {
    if (ncol(dims_ann[[i]]) == 0) return("")
    # dodge `format.pillar_shaft_decimal()` errors
    wid_try <- (width - 7) / 2
    #wid_try <- width - 7
    fmt_try <- try(
      c("", format(dims_ann[[i]], n = n[i], width = wid_try)[-1]),
      silent = TRUE
    )
    while (class(fmt_try) == "try-error") {
      wid_try <- wid_try - 1
      fmt_try <- c("", format(dims_ann[[i]], n = n[i], width = wid_try)[-1])
    }
    fmt_try
  })
  names(fmt_ann) <- c("rows", "cols")
  # -+- allow additional rows/variables statement to fill horizontal space -+-
  
  # separate coordinates from annotations
  seps <- if (rk > 3) c("    ", " ...") else c("", "")
  fmt_seps <- mapply(
    function(x, y) {
      sep_dots_rows <- ceiling(c(2, (y - 2) / 2 + 2))
      c(paste(rep(" ", times = max(0, x)), collapse = ""),
        paste0(ifelse(seq(2, y) %in% sep_dots_rows, seps[2], seps[1]), " | "))
    },
    x = 3 + nchar(seps) -
      sapply(fmt_coord, function(z) nchar(z[1])),
    y = sapply(fmt_coord, length),
    SIMPLIFY = FALSE
  )
  
  # paste together, with attention to footers
  for (i in seq(2L)) {
    if (dims_footers[i]) {
      fmt_coord[[i]] <- c(fmt_coord[[i]], "")
      fmt_seps[[i]] <- c(fmt_seps[[i]], "")
    }
  }
  # add blank lines if necessary to allow footers
  for (i in seq(2)) {
    len_coord <- length(fmt_coord[[i]])
    len_seps <- length(fmt_seps[[i]])
    len_ann <- length(fmt_ann[[i]])
    stopifnot(len_coord == len_seps)
    if (len_coord < len_ann) {
      fmt_coord[[i]][seq(len_coord + 1L, len_ann)] <- ""
      fmt_seps[[i]][seq(len_seps + 1L, len_ann)] <- ""
    }
  }
  fmt_dims <- mapply(
    paste0,
    fmt_coord, fmt_seps, fmt_ann,
    SIMPLIFY = FALSE
  )
  
  c(
    tbl_ord_header,
    coord_header,
    supp_header,
    "# ", fmt_dims[[1L]], "# ", fmt_dims[[2L]]
  )
}

#' @rdname format
#' @export
print.tbl_ord <- function(
  x, width = NULL, ..., n = NULL,
  max_extra_cols = NULL, max_footer_lines = NULL
) {
  fmt <- format(
    x, width = width, ..., n = n,
    max_extra_cols = max_extra_cols, max_footer_lines = max_footer_lines
  )
  cat(paste(fmt, collapse = "\n"), "\n", sep = "")
  invisible(x)
}

#`%||%` <- rlang::`%||%`

# this trick is borrowed from *tibble*
op.tbl_ord <- list(
  tbl_ord.print_max = 10L,
  tbl_ord.print_min = 5L,
  tbl_ord.width = NULL,
  tbl_ord.max_extra_cols = 50L
)

tbl_ord_opt <- function(x) {
  x_tbl_ord <- paste0("tbl_ord.", x)
  res <- getOption(x_tbl_ord)
  if (!is.null(res)) {
    return(res)
  }
  
  x_tibble <- paste0("tibble.", x)
  res <- getOption(x_tibble)
  if (!is.null(res)) {
    return(as.integer(res / 2))
  }
  
  op.tbl_ord[[x_tbl_ord]]
}

print_reps <- function(x) {
  x <- as.character(x)
  switch(
    min(length(x), 4),
    "1" = x,
    "2" = paste(x, collapse = " and "),
    "3" = paste(x, collapse = ", "),
    "4" = paste0(paste(x[seq(2)], collapse = ", "), ", ..., ", x[length(x)])
  )
}