R/print_cttab.R

In shug0131/cctu: In-House Functions for Report Writing at Cambridge Clinical Trials Unit

#' Print
#'
#' Print method for `cttab`
#'
#' @param x Table generated by \code{cttab}.
#' @param indent Indent string, default is two space.
#' @param ... Not used.
#'
#' @export
print.cttab <- function(x, indent = "  ", ...) {
  # Extract the span positions
  rowclass <- attr(x, "position")

  # Extract align
  if (is.null(attr(x, "align"))) {
    align <- rep("l", ncol(x))
  }

  if (inherits(x, "matrix")) {
    align <- c("l", rep("c", ncol(x))) # Row names left align
    # Row names to column
    col.names <- colnames(x)
    x <- cbind(" " = rownames(x), x)
    colnames(x) <- c("", col.names)
  }

  # Add indents
  x[rowclass == 3, 1] <- paste0(indent, x[rowclass == 3, 1])

  # Calculate the widths of the column with colnames excluding the span rows
  l_h <- nchar(colnames(x), type = "width")
  l <- vapply(
    as.data.frame(x[!rowclass %in% c(0, 2), ]),
    function(z) max(c(nchar(z, type = "width"), 0), na.rm = TRUE), numeric(1)
  )

  l <- apply(rbind(l_h, l), 2, max)

  # If span row larger than all combined, expand width
  l_row <- vapply(
    as.data.frame(x[rowclass %in% c(0, 2), ]),
    function(z) max(c(nchar(z, type = "width"), 0), na.rm = TRUE), numeric(1)
  )
  if (l_row[1] > sum(l)) {
    add_l <- ceiling((l_row[1] - sum(l)) / length(l))
    l <- l + add_l
  }


  # Create heading
  th <- mapply(
    FUN = pad_width,
    x = colnames(x),
    width = l,
    align = rep("c", ncol(x))
  )
  th <- paste(th, collapse = "\u2502")
  th <- sprintf("|%s|", th)

  # Create borders
  th0 <- paste(strrep("\u2500", l), collapse = "\u252c")
  th1 <- paste(strrep("\u2500", l), collapse = "\u2534")

  tb_tp <- paste0("\u250c", th0, "\u2510")
  tb_lmd <- paste0("\u251c", th0, "\u2524")

  tb_bt <- paste0("\u2514", th1, "\u2518")
  tb_umd <- paste0("\u251c", th1, "\u2524")

  # Tabel body
  tb <- rep("", nrow(x))
  for (i in seq_len(nrow(x))) {
    if (rowclass[i] %in% c(0, 2)) {
      tb[i] <- pad_width(x[i, 1], sum(l) + ncol(x) - 1, "l")
    } else {
      tb[i] <- paste(pad_width(x[i, ], l, align), collapse = "\u2502")
    }
  }
  tb <- sprintf("|%s|", tb)
  tb <- unname(split(
    tb,
    cumsum(seq_along(tb) %in% which(rowclass %in% c(0, 2)))
  ))
  tb <- lapply(tb, function(x) c(x, tb_umd))
  tb <- lapply(tb, function(x) c(x[1], tb_lmd, x[2:length(x)]))
  tb <- unlist(tb)
  tb[length(tb)] <- tb_bt

  tab <- c(tb_tp, th, tb_umd, tb)

  cat(tab, sep = "\n")
}

# pad a character vector to width
#' @keywords internal
pad_width <- function(x, width, align) {
  side <- c(l = "right", c = "both", r = "left")[align]
  w <- width - nchar(x, "width")
  w1 <- floor(w / 2)
  s1 <- strrep(" ", w * (side == "left") + w1 * (side == "both"))
  s2 <- strrep(" ", w * (side == "right") + (w - w1) * (side == "both"))
  paste0(s1, x, s2)
}