R/plots.R

In snystrom/memes: motif matching, comparison, and de novo discovery using the MEME Suite

#' Add title to complex plot with cowplot
#'
#' @param plot plot object to add title to
#' @param title text of title
#' @param ... passed to [cowplot::draw_text()]
#'
#' @return
#'
#' @noRd
#'
cowplot_title <- function(plot, title, ...){
  title <- cowplot::ggdraw() +
    cowplot::draw_text(title, ...)
  cowplot::plot_grid(plotlist = list(title, plot), ncol = 1, rel_heights = c(0.1, 1))
}

#' Compare top tomtom hits to original motif
#'
#' Although TomTom does a good job of matching unknown motifs to known motifs,
#' sometimes the top hit is not the correct assignment. It can be useful to
#' manually inspect the hits. This function provides a quick utility to compare
#' matches.
#'
#' This is intended to be a function used interactively and may not always be
#' the best tool for creating publication-quality figures. Results with matches
#' return ggseqlogo outputs which can be further manipulated using
#' [ggplot2::theme()] calls, but results containing no matches are static plots.
#'
#' @param results results data.frame from [runTomTom()]
#' @param top_n number of matched motifs to return in plot (default: "all")
#'
#' @return plot of input motif vs the top n number of tomtom matched motifs. If
#'   no match found, will plot "No Match". Note: the "No Match" plots are not
#'   amenable to ggplot theme() manipulations, while all others are.
#' @export
#'
#' @examples
#' results <- importTomTomXML(system.file("extdata", "tomtom.xml", package = "memes"))
#' # show top 3 hits
#' view_tomtom_hits(results, top_n = 3)
view_tomtom_hits <- function(results, top_n = "all"){
  # TODO: if tomtom is empty, return NONE as plot below??
  purrr::map2(results$motif, results$tomtom, ~{

    if (is.null(.y)) {
      return(view_tomtom_nomatch(.x))
    }

    # Needed to handle when tomtom discovers no hits for any motifs, in which case
    # tomtom is NA instead of NULL so the column is kept in the dataframe
    if (all(is.na(.y))) {
      return(view_tomtom_nomatch(.x))
    }

    if (top_n == "all") {select <- seq_len(length(.y$match_motif))}
    else if (is.numeric(top_n)) {select <- seq_len(top_n)}
    else {
      stop("n must be either 'all' or a number.")
    }
    
    if (length(select) > length(.y$match_motif)){
      # If top_n > number of hits, just show all hits
      select <- seq_len(length(.y$match_motif))
    }

    # TODO: check that motifList below doesn't have AsIs?
    #motifList <- c(list(.x), .y$match_motif[select]) %>%
    #edit_motif <- function(x){
    #  class(x) <- NULL
    #  x
    #}
    motifList <- c(list(.x), .y$match_motif[select]) %>%
      purrr::discard(is.null)

    universalmotif::view_motifs(motifList)
  })
}

#' Plot motif with "No Match" below.
#'
#' NOTE: this doesn't do any checking, and is not meant to be called directly by
#' user. Used internally in [view_tomtom_hits()]
#'
#' @param motif universalmotif
#' @param ... passed to [universalmotif::view_motifs()]
#'
#' @return
#'
#' @importFrom ggplot2 ggtitle theme element_text
#'
#' @noRd
view_tomtom_nomatch <- function(motif){
  # Thanks, Hadley: http://r-pkgs.had.co.nz/description.html
  if (!requireNamespace("ggplot2", quietly = TRUE)) {
    stop("Package \"ggplot2\" needed for this function to work. Please install it.",
         call. = FALSE)
  }
  motif_logo <- universalmotif::view_motifs(motif)

  motif_logo <- motif_logo +
    ggtitle(motif@name) +
    theme(plot.title = element_text(hjust = 0.5))

  nomatch_logo <- nomatch_logo()

  cowplot::plot_grid(motif_logo, nomatch_logo, ncol = 1, rel_heights = c(1,0.6))
}


#' Returns motif matrix of "NO MATCH"
#'
#' To use ggseqlogo to render the "NO MATCH" text,
#' I need to build a matrix with custom alphabet
#'
#' In matrix form NO MATCH is a matrix with diagonal all 1,
#' except at "space" position where all values are 1
#'
#' This is a very silly hack, and I love it.
#'
#' @return
#'
#' @noRd
nomatch_matrix <- function(){
  m <- matrix(0,
              nrow = 7,
              ncol = 7)
  diag(m) <- 1
  n <- c("N", "O", "M", "A", "T", "C", "H")
  rownames(m) <- c("N", "O", "M", "A", "T", "C", "H")
  no <- m[,c(1,2)]
  match <- m[,c(3:7)]
  space <- matrix(1, nrow = 7, ncol = 1)
  mat <- cbind(no, space, match)

  return(mat)
}

#' Returns "NO MATCH" ggseqlogo
#'
#' @return

#' @importFrom ggplot2 element_text
#' @importFrom ggseqlogo make_col_scheme ggseqlogo
#' @noRd
nomatch_logo <- function(){
  mat <- nomatch_matrix()
  alph <- rownames(mat)
  col <- ggseqlogo::make_col_scheme(chars = alph, cols = rep("#333333", length(alph)))

  ggseqlogo::ggseqlogo(mat,
                       namespace = alph,
                       method = "bits",
                       col_scheme = col) +
    ggplot2::theme(axis.text = element_text(color = "white"),
                   axis.text.x = element_text(color = "white"),
                   axis.text.y = element_text(color = "white"),
                   axis.title = element_text(color = "white"))
}