add geom_corr and minor improve (fed6a6ff) · Commits · github_fork / LinkET

NAMESPACE

+2 −0

Original line number	Diff line number	Diff line
		@@ -72,6 +72,7 @@ export("%>%")
		export("col_names<-")
		export("row_names<-")
		export(DoughnutGrob)
		export(GeomCorr)
		export(GeomCurve2)
		export(GeomDoughnut)
		export(GeomHalfcircle)
		@@ -102,6 +103,7 @@ export(fast_correlate)
		export(fast_correlate2)
		export(filter_func)
		export(gdist)
		export(geom_corr)
		export(geom_couple)
		export(geom_curve2)
		export(geom_diag_label)

R/experimental-fun.R

+145 −13

Original line number	Diff line number	Diff line
		@@ -152,6 +152,11 @@ ggplot_add.geom_pairs <- function(object, plot, object_name) {
		}
		}

		if ("corr" %in% ptype && type != "cc") {
		warning("'corr' can only be applied to continuous variables.", call. = FALSE)
		ptype[which(ptype == "corr")] <- "blank"
		}

		if (any(c("histogram", "density", "bar") %in% ptype)) {
		if (pos == "diag") {
		p <- plot + ggplot2::scale_x_discrete(expand = expansion$discrete)
		@@ -182,9 +187,9 @@ ggplot_add.geom_pairs <- function(object, plot, object_name) {
		)
		}
		layers <- .get_layer(ptype)
		id <- which(ptype == "bar")
		if (length(id) > 0) {
		for (i in id) {
		id_bar <- which(ptype == "bar")
		if (length(id_bar) > 0) {
		for (i in id_bar) {
		if (type == "dc") {
		layers[[i]]$mapping <- aes_modify(layers[[i]]$mapping, aes_string(x = "..count.."))
		} else {
		@@ -193,6 +198,17 @@ ggplot_add.geom_pairs <- function(object, plot, object_name) {
		}
		}

		id_corr <- which(ptype == "corr")
		if (length(id_corr) > 0) {
		for (i in id_corr) {
		mp <- aes_modify(plot$mapping, layers[[i]]$mapping)
		if ("colour" %in% names(mp)) {
		mp$label <- mp$colour
		}
		layers[[i]]$mapping <- mp
		}
		}

		for (i in seq_along(layers)) {
		plot <- plot + layers[[i]]
		}
		@@ -219,7 +235,9 @@ register_pairs_plot <- function(...) {
		"path" = ggplot2::geom_path(),
		"line" = ggplot2::geom_line(),
		"hex" = ggplot2::geom_hex(),
		"blank" = ggplot2::geom_blank())
		"blank" = ggplot2::geom_blank(),
		"jitter" = ggplot2::geom_jitter(),
		"corr" = geom_corr())
		ll <- utils::modifyList(ll, list(...))
		ll <- utils::modifyList(options("linkET.pairs.plot"), ll)
		options("linkET.pairs.plot" = ll)
		@@ -287,19 +305,19 @@ plot_type <- function(...) {
		#' @noRd
		.default_plot_type <- list(diag = plot_type(dd = "bar",
		cc = "density"),
		full = plot_type(dd = "bar",
		full = plot_type(dd = "jitter",
		cc = "point",
		cd = "boxplot",
		dc = "boxplot"),
		lower = plot_type(dd = "bar",
		cc = "point",
		lower = plot_type(dd = "jitter",
		cc = "corr",
		cd = "boxplot",
		dc = "boxplot"),
		upper = plot_type(dd = "bar",
		upper = plot_type(dd = "jitter",
		cc = "point",
		cd = "boxplot",
		dc = "boxplot"),
		dd = "point",
		dd = "jitter",
		cc = "point",
		cd = "boxplot",
		dc = "boxplot")
		@@ -1004,9 +1022,123 @@ plot.gggplot <- print.gggplot
		plot
		}

		#' @noRd
		#' @title Correlation Layer
		#' @description This function can be used to add corrlation marker on a pairs plot.
		#' @inheritParams ggplot2::layer
		#' @param ... other parameters passed to layer function.
		#' @param na.rm if FALSE, the default, missing values are removed with a warning,
		#' and if TRUE, missing values are silently removed.
		#' @param method method of correlation.
		#' @param digits,nsmall a positive integer to format correlation.
		#' @param nudge_x,nudge_y horizontal and vertical adjustment to nudge labels by.
		#' @return a layer object.
		#' @author Hou Yun
		#' @rdname geom_corr
		#' @export
		## TODO: add layer function to draw correlation
		# geom_corr <- function(...) {
		# NULL
		# }
		geom_corr <- function(mapping = NULL,
		data = NULL,
		stat = "identity",
		position = "identity",
		...,
		method = "pearson",
		digits = 2,
		nsmall = 2,
		nudge_x = 0,
		nudge_y = 0,
		na.rm = FALSE,
		show.legend = NA,
		inherit.aes = TRUE)
		{
		layer(
		data = data,
		mapping = mapping,
		stat = stat,
		geom = GeomCorr,
		position = position,
		show.legend = show.legend,
		inherit.aes = inherit.aes,
		params = list(
		method = method,
		digits = digits,
		nsmall = nsmall,
		nudge_x = nudge_x,
		nudge_y = nudge_y,
		na.rm = na.rm,
		...
		)
		)
		}

		#' @rdname geom_corr
		#' @format NULL
		#' @usage NULL
		#' @export
		GeomCorr <- ggproto(
		"GeomCorr", GeomText,
		required_aes = c("x", "y"),

		default_aes = aes(label = "", colour = "black", size = 3.88, alpha = NA,
		hjust = 0, angle = 0, vjust = 0.5, family = "",
		fontface = 1, lineheight = 1.2),

		draw_panel = function(data,
		panel_params,
		coord,
		method = method,
		digits = 2,
		nsmall = 2,
		nudge_x = 0,
		nudge_y = 0,
		na.rm = FALSE) {
		if (empty(data) \|\| any(!is.numeric(data$x), !is.numeric(data$y))) {
		return(grid::nullGrob())
		}


		ll <- split(data, data$colour)
		ll <- c(list(Corr = data), ll)
		less_than_three <- vapply(ll, nrow, numeric(1)) < 3
		ll <- ll[!less_than_three]

		if (length(ll) < 1) return(grid::nullGrob())

		nm <- names(ll)
		corr <- purrr::map2_chr(ll, nm, function(.data, .nm) {
		label <- if (.nm == "Corr") "Corr: " else paste0(.data$label[1], ": ")
		if (label == ": ") label <- ""
		r <- as.vector(stats::cor(x = .data$x, y = .data$y, method = method))
		p <- stats::cor.test(x = .data$x, y = .data$y, method = method)$p.value
		mark <- sig_mark(p)
		if (mark != "") {
		mark <- paste0("\\", unlist(strsplit(mark, split = "")),
		collapse = "")
		}
		text <- paste(format(r, nsmall = nsmall, digits = digits),
		mark, sep = "")
		col <- if (.nm == "Corr") "black" else .nm
		paste("<span style='color:", col, "'>", paste0(label, text),
		"</span>", sep = "")
		})

		first_row <- data[1, , drop = FALSE]
		first_row$x <- panel_params$x.range[1] + 0.1 * diff(panel_params$x.range) +
		nudge_x
		first_row$y <- mean(panel_params$y.range) + nudge_y
		first_row <- coord$transform(first_row, panel_params)

		richtext_grob <- get_function("gridtext", "richtext_grob")
		richtext_grob(text = paste(corr, collapse = "<br>"),
		x = first_row$x,
		y = first_row$y,
		hjust = first_row$hjust,
		vjust = first_row$vjust,
		rot = first_row$angle,
		gp = gpar(fontsize = first_row$size * ggplot2::.pt,
		fontfamily = first_row$family,
		fontface = first_row$fontface,
		lineheight = first_row$lineheight))
		},
		draw_key = ggplot2::draw_key_point
		)

man/geom_corr.Rd

0 → 100644

+83 −0

Original line number	Diff line number	Diff line
		% Generated by roxygen2: do not edit by hand
		% Please edit documentation in R/experimental-fun.R
		\docType{data}
		\name{geom_corr}
		\alias{geom_corr}
		\alias{GeomCorr}
		\title{Correlation Layer}
		\usage{
		geom_corr(
		mapping = NULL,
		data = NULL,
		stat = "identity",
		position = "identity",
		...,
		method = "pearson",
		digits = 2,
		nsmall = 2,
		nudge_x = 0,
		nudge_y = 0,
		na.rm = FALSE,
		show.legend = NA,
		inherit.aes = TRUE
		)
		}
		\arguments{
		\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}} or
		\code{\link[ggplot2:aes_]{aes_()}}. If specified and \code{inherit.aes = TRUE} (the
		default), it is combined with the default mapping at the top level of the
		plot. You must supply \code{mapping} if there is no plot mapping.}

		\item{data}{The data to be displayed in this layer. There are three
		options:

		If \code{NULL}, the default, the data is inherited from the plot
		data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}.

		A \code{data.frame}, or other object, will override the plot
		data. All objects will be fortified to produce a data frame. See
		\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created.

		A \code{function} will be called with a single argument,
		the plot data. The return value must be a \code{data.frame}, and
		will be used as the layer data. A \code{function} can be created
		from a \code{formula} (e.g. \code{~ head(.x, 10)}).}

		\item{stat}{The statistical transformation to use on the data for this
		layer, as a string.}

		\item{position}{Position adjustment, either as a string, or the result of
		a call to a position adjustment function.}

		\item{...}{other parameters passed to layer function.}

		\item{method}{method of correlation.}

		\item{digits, nsmall}{a positive integer to format correlation.}

		\item{nudge_x, nudge_y}{horizontal and vertical adjustment to nudge labels by.}

		\item{na.rm}{if FALSE, the default, missing values are removed with a warning,
		and if TRUE, missing values are silently removed.}

		\item{show.legend}{logical. Should this layer be included in the legends?
		\code{NA}, the default, includes if any aesthetics are mapped.
		\code{FALSE} never includes, and \code{TRUE} always includes.
		It can also be a named logical vector to finely select the aesthetics to
		display.}

		\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics,
		rather than combining with them. This is most useful for helper functions
		that define both data and aesthetics and shouldn't inherit behaviour from
		the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.}
		}
		\value{
		a layer object.
		}
		\description{
		This function can be used to add corrlation marker on a pairs plot.
		}
		\author{
		Hou Yun
		}
		\keyword{datasets}

Admin message