R/geom-diag-label.R

In Hy4m/linkET: Everything is Linkable

#' Add diagonal label on hyplot
#' @description \code{geom_panel_grid} is mainly used with \code{hyplot()}.
#'     function to add a panel grid line on plot region.
#' Add diagnoal labels on correlation plot
#' @description \code{geom_diag_label} is mainly used with \code{hyplot()} and
#'     \code{qcorrplot()} functions to add diagnoal labels on correct position
#'     base on different type of cor_tbl object.
#' @param parse logical or function generated by \code{parse_func()}.
#' @param geom one of "text", "label" or "richtext" (needs `ggtext` package).
#' @param ... extra parameters.
#' @importFrom ggplot2 aes_ geom_label
#' @rdname geom_diag_label
#' @author Hou Yun
#' @export
#' @examples
#' qcorrplot(correlate(mtcars)) + geom_diag_label()

geom_diag_label <- function(..., parse = FALSE, geom = NULL)
{
  structure(.Data = list(parse = parse, geom = geom, params = list(...)),
            class = "geom_diag_label")
}

#' @importFrom ggplot2 ggplot_add
#' @export
ggplot_add.geom_diag_label <- function(object, plot, object_name) {
  stopifnot(is_hyplot(plot))
  md <- plot$data
  row_names <- row_names(md)
  col_names <- col_names(md)
  if(!identical(row_names, col_names)) {
    stop("`geom_diag_label()` just support for symmetric matrices.", call. = FALSE)
  }

  label <- col_names
  parse <- object$parse
  need_parse <- isTRUE(parse) || is.function(parse)
  parse_fun <- parse
  if (need_parse) {
    if (isTRUE(parse)) {
      if (is_richtext(col_names)) {
        parse_fun <- parse_func(output = "richtext")
      } else {
        parse_fun <- parse_func(output = "character")
      }
    }
  }
  if (is.function(parse_fun)) {
    label <- parse_fun(label)
    if (!is_richtext(label)) {
      label <- parse_safe(label)
    }
  }

  if(is.null(object$geom)) {
    if(is_richtext(label)) {
      if(requireNamespace("ggtext", quietly = TRUE)) {
        object$geom <- "richtext"
      } else {
        message("It looks like the label is richtext\n",
                "you can install the ggtext package to add richtext.\n")
        object$geom <- "text"
      }
    } else {
      object$geom <- "text"
    }
  }

  if(object$geom == "richtext") {
    geom_richtext <- get_function("ggtext", "geom_richtext")
  }

  data <- tibble::tibble(.x = seq_along(col_names),
                         .y = rev(seq_along(row_names)),
                         .label = label)
  params <- object$params
  params$data <- data
  params$mapping <- aes_modify(aes_(x = ~.x, y = ~.y, label = ~.label),
                               params$mapping)
  params$inherit.aes <- FALSE
  geom <- paste0("geom_", object$geom)
  if(geom == "geom_richtext") {
    if(!"fill" %in% names(params)) {
      params$fill <- NA
    }
    if(!"label.colour" %in% names(params)) {
      params$label.colour <- NA
    }
  }
  if (need_parse && !is_richtext(label)) {
    object$parse <- TRUE
  }
  object <- do.call(geom, params)
  ggplot_add(object, plot, object_name)
}