R/exclude-data.R

In houyunhuang/ggtriangle: Fast processing of matrix heatmap

#' Helper function to extract subsets of matrix_tbl.
#' @description These functions are used to quickly obtain the upper
#'     trig, lower trig of the square matrix.
#' @param .data a matrix_tbl object.
#' @param show.diag a logical value indicating whether keep the diagonal.
#' @return a modified matrix_tbl object.
#' @rdname exclude_data
#' @export
exclude_upper <- function(.data, show.diag = FALSE) {
  if(!inherits(.data, "matrix_tbl")) {
    stop("Need a matrix tbl.", call. = FALSE)
  }
  col.name <- attr(.data, ".col.names")
  row.name <- attr(.data, ".row.names")
  if(length(col.name) != length(row.name)) {
    stop("Rows must be same as columns.", call. = FALSE)
  }
  n <- length(col.name)
  if(isTRUE(show.diag)) {
    .data <- with(.data, subset(.data, .row.id + .col.id <= n + 1))
  } else {
    .data <- with(.data, subset(.data, .row.id + .col.id < n + 1))
  }
  .data
}
#' @rdname exclude_data
#' @export
exclude_lower <- function(.data, show.diag = FALSE) {
  if(!inherits(.data, "matrix_tbl")) {
    stop("Need a matrix tbl.", call. = FALSE)
  }
  col.name <- attr(.data, ".col.names")
  row.name <- attr(.data, ".row.names")
  if(length(col.name) != length(row.name)) {
    stop("Rows must be same as columns.", call. = FALSE)
  }
  n <- length(col.name)
  if(isTRUE(show.diag)) {
    .data <- with(.data, subset(.data, .row.id + .col.id >= n + 1))
  } else {
    .data <- with(.data, subset(.data, .row.id + .col.id > n + 1))
  }
  .data
}