R/04_Visual_CoRanking.R

In davnovak/SingleBench: Framework for benchmarking and optimising dimension-reduction and clustering pipelines in expression data analysis

#' Plot collapsed co-ranking matrix for heatmap for projection in a benchmark
#'
#' Creates plot showing collapsed co-ranking matrix of a dimension-reduction layout as a heatmap.
#'
#' @param benchmark an object of class \code{Benchmark}, as generated by the constructor \code{Benchmark} and evaluated using \code{Evaluate.Benchmark}
#' @param idx.subpipeline integer value: index of subpipeline that includes a projection step
#' @param idx.n_param optional integer value: index of subpipeline n-parameter iteration. Default value is \code{NULL}
#'
#' @export
PlotCoRanking <- function(
  benchmark,
  idx.subpipeline,
  idx.n_param = NULL,
  log = TRUE
) {
  
  .PlotProjection.ValidityChecks(environment())
  
  res <- GetCoRanking(benchmark, idx.subpipeline, idx.n_param)
  Q <- res$Matrix
  collapsed <- res$Collapsed
  if (collapsed) {
    PlotCollapsedCorankingMatrix(Q, log = log)
  } else {
    PlotFullCorankingMatrix(Q, res$K)
  }
}

PlotFullCorankingMatrix <- function(Q, k) {
  
  ## Full (non-truncated) co-ranking matrix (joint histogram of rank
  ## errors for a lower-dimensional projection of data, versus original)
  
  line_val <- max(Q) + 10
  dQ <- rbind(Q[1:k, ], line_val, Q[(k+1):nrow(Q), ])
  dQ <- cbind(dQ[, 1:k], line_val, dQ[, (k+1):nrow(Q)])
  d <- log(dQ[, ncol(dQ):1])
  image(d, axes = FALSE, main = 'Co-ranking matrix', sub = paste0('Min=', min(Q), ', Mean=', round(mean(Q), 2), ', Median=', median(Q),', Max=', max(Q)), col = hcl.colors(12, 'viridis', rev = TRUE))
}

PlotCollapsedCorankingMatrix <- function(cQ, log = TRUE) {
  
  ## Truncated (collapsed) co-ranking matrix (joint histogram of rank errors
  ## for a lower-dimensional projection of data, versus original). This version
  ## does not quantify the size of hard-k intrusions and extrusions
  
  n <- nrow(cQ)
  extruders <- data.frame(cQ[, n][-n])
  intruders <- data.frame(cQ[n, ][-n])
  cQ <- cQ[-n, -n]
  colnames(cQ) <- rownames(cQ) <- rownames(extruders) <- rownames(intruders) <- 1:(n - 1)
  colnames(extruders) <- 'extruders'
  colnames(intruders) <- 'intruders'
  if (log) {
    cQ[cQ == 0] <- 0.9
    cQ <- log(cQ)
  }
  p <- pheatmap::pheatmap(
    cQ, cluster_rows = FALSE, cluster_cols = FALSE,
    annotation_row = extruders, annotation_col = intruders,
    silent = TRUE, show_rownames = FALSE, show_colnames = FALSE,
    main = paste0('Collapsed co-ranking matrix of k-ary point neighbourhoods (log scale)')
  )
  p$gtable$layout[which(p$gtable$layout$name == 'row_annotation'), 1:5] <- c('t' = 4, 'l' = 4, 'b' = 4, 'r' = 5, 'z'= 4)
  p$gtable$layout[which(p$gtable$layout$name == 'col_annotation'), 1:5] <- c('t' = 2, 'l' = 3, 'b' = 5, 'r' = 3, 'z'= 3)
  
  p$gtable$grobs[[which(p$gtable$layout$name == 'row_annotation')]]$x <- p$gtable$grobs[[which(p$gtable$layout$name == 'row_annotation')]]$x - grid::unit(2.5, 'bigpts')
  p$gtable$grobs[[which(p$gtable$layout$name == 'row_annotation')]]$width <- p$gtable$grobs[[which(p$gtable$layout$name == 'row_annotation')]]$width * 3
  p$gtable$grobs[[which(p$gtable$layout$name == 'col_annotation')]]$y <- p$gtable$grobs[[which(p$gtable$layout$name == 'col_annotation')]]$y + grid::unit(20, 'bigpts')
  p$gtable$grobs[[which(p$gtable$layout$name == 'col_annotation')]]$height <- p$gtable$grobs[[which(p$gtable$layout$name == 'col_annotation')]]$height * 3
  
  p$gtable$grobs[[which(p$gtable$layout$name == 'annotation_legend')]]$children[[1]]$label <-
    p$gtable$grobs[[which(p$gtable$layout$name == 'annotation_legend')]]$children[[5]]$label <- ''
  for (idx in 1:8)
    p$gtable$grobs[[which(p$gtable$layout$name == 'annotation_legend')]]$children[[idx]]$x <- 
    p$gtable$grobs[[which(p$gtable$layout$name == 'annotation_legend')]]$children[[idx]]$x + grid::unit(15, 'bigpts')
  p$gtable$grobs[[which(p$gtable$layout$name == 'legend')]]$children[[1]]$x <-
    p$gtable$grobs[[which(p$gtable$layout$name == 'legend')]]$children[[1]]$x + grid::unit(45, 'bigpts')
  p$gtable$grobs[[which(p$gtable$layout$name == 'legend')]]$children[[2]]$x <-
    p$gtable$grobs[[which(p$gtable$layout$name == 'legend')]]$children[[2]]$x + grid::unit(45, 'bigpts')
  p$gtable$grobs[[which(p$gtable$layout$name == 'legend')]]$children[[1]]$y <-
    p$gtable$grobs[[which(p$gtable$layout$name == 'legend')]]$children[[1]]$y - grid::unit(180, 'bigpts')
  p$gtable$grobs[[which(p$gtable$layout$name == 'legend')]]$children[[2]]$y <-
    p$gtable$grobs[[which(p$gtable$layout$name == 'legend')]]$children[[2]]$y - grid::unit(180, 'bigpts')
  p$gtable$grobs[[which(p$gtable$layout$name == 'main')]]$y <-
    p$gtable$grobs[[which(p$gtable$layout$name == 'main')]]$y - grid::unit(10, 'bigpts')
  p$gtable$grobs[[which(p$gtable$layout$name == 'matrix')]]$children[[1]]$gp$col <-
    p$gtable$grobs[[which(p$gtable$layout$name == 'matrix')]]$children[[1]]$gp$fill
  p$gtable$grobs[[which(p$gtable$layout$name == 'row_annotation')]]$gp$col <-
    p$gtable$grobs[[which(p$gtable$layout$name == 'row_annotation')]]$gp$fill
  p$gtable$grobs[[which(p$gtable$layout$name == 'col_annotation')]]$gp$col <-
    p$gtable$grobs[[which(p$gtable$layout$name == 'col_annotation')]]$gp$fill
  p$gtable$grobs[[which(p$gtable$layout$name == 'col_annotation_names')]]$label <-
    p$gtable$grobs[[which(p$gtable$layout$name == 'row_annotation_names')]]$label <- ''
  
  p
}