Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
245 lines (226 sloc) 7.81 KB
#' Correlation circle plot for dimensionality reduction techniques.
#'
#' This creates a ggplot2 layer that plots the correlation values of the
#' scores for components against the real values, as obtained from
#' dimensionality reduction methods. These methods include principal components
#' analysis and partial least squares.
#'
#' @inheritParams ggplot2::layer
#' @inheritParams ggplot2::geom_point
#' @param center.linetype,center.linecolour,center.linesize The line type,
#' colour, and size for the two center lines.
#' @param inner.linetype,inner.linecolour,inner.linesize The line type,
#' colour, and size for the inner circle line.
#' @param outer.linetype,outer.linecolour,outer.linesize The line type,
#' colour, and size for the outer circle line.
#'
#' @return Adds a ggplot2 geom layer.
#' @export
#'
#' @examples
#'
#' library(ggplot2)
#' library(broom)
#' library(pls)
#' data(yarn)
#'
#' # Set up data to plot.
#' fit <- plsr(density ~ NIR, 6, data = yarn, validation = "CV")
#' fit <- cor(model.matrix(fit), scores(fit)[, 1:2, drop = FALSE])
#' fit <- as.data.frame(fit)
#' fit$Variables <- rownames(fit)
#' rownames(fit) <- NULL
#' colnames(fit)[1:2] <- c("Comp1", "Comp2")
#' fit$Groups <- as.factor(sample.int(2, nrow(fit), replace = TRUE))
#'
#' p <- ggplot(fit, aes(x = Comp1, y = Comp2))
#' p + geom_corr_circle()
#' p + geom_corr_circle(outer.linetype = "dotted")
#' p + geom_corr_circle(inner.linecolour = "blue")
#' p + geom_corr_circle(center.linesize = 1)
#' p + geom_corr_circle(center.linecolour = "grey50", size = 3)
#'
#' # If you want to remove the circle or center lines, use 0.
#' p + geom_corr_circle(center.linetype = 0)
#' p + geom_corr_circle(outer.linetype = 0)
#'
#' # With grouping
#' p + geom_corr_circle(aes(colour = Groups))
#' p + geom_corr_circle(aes(colour = Groups), size = 3) +
#' scale_colour_brewer()
#' p + geom_corr_circle(aes(alpha = Groups))
#' p + geom_corr_circle(aes(size = Groups))
#' p + geom_corr_circle(aes(shape = Groups), size = 2)
#'
#' # With facets
#' p + geom_corr_circle() +
#' facet_grid(~ Groups)
#'
geom_corr_circle <- function(mapping = NULL,
data = NULL,
stat = "identity",
position = "identity",
...,
na.rm = FALSE,
show.legend = NA,
outer.linetype = "solid",
outer.linecolour = "black",
outer.linesize = 0.5,
inner.linetype = "dotted",
inner.linecolour = "black",
inner.linesize = 0.5,
center.linetype = "solid",
center.linecolour = "grey50",
center.linesize = 0.3,
inherit.aes = TRUE) {
layer(
data = data,
mapping = mapping,
stat = stat,
geom = GeomCorrcircle,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
na.rm = na.rm,
outer.linetype = outer.linetype,
outer.linecolour = outer.linecolour,
outer.linesize = outer.linesize,
inner.linetype = inner.linetype,
inner.linecolour = inner.linecolour,
inner.linesize = inner.linesize,
center.linetype = center.linetype,
center.linecolour = center.linecolour,
center.linesize = center.linesize,
...
)
)
}
#' @rdname ggepi-geoms
#' @format NULL
#' @usage NULL
#' @export
GeomCorrcircle <- ggproto(
"GeomCorrcircle",
Geom,
default_aes = aes(
colour = "black",
size = 0.5,
linetype = 1,
alpha = NA,
fill = NA,
shape = 19,
stroke = 0.5
),
required_aes = c("y", "x"),
draw_key = draw_key_point,
setup_data = function(data, params) {
data$outer.linetype <- data$outer.linetype %||%
params$outer.linetype %||% "solid"
data$outer.linecolour <- data$outer.linecolour %||%
params$outer.linecolour %||% "black"
data$outer.linesize <- data$outer.linesize %||%
params$outer.linesize %||% 0.5
data$inner.linetype <- data$inner.linetype %||%
params$inner.linetype %||% "dotted"
data$inner.linecolour <- data$inner.linecolour %||%
params$inner.linecolour %||% "black"
data$inner.linesize <- data$inner.linesize %||%
params$inner.linesize %||% 0.5
data$center.linetype <- data$center.linetype %||%
params$center.linetype %||% "solid"
data$center.linecolour <- data$center.linecolour %||%
params$center.linecolour %||% "grey50"
data$center.linesize <- data$center.linesize %||%
params$center.linesize %||% 0.3
data
},
draw_panel = function(data,
panel_params,
coord,
outer.linetype = NA,
outer.linecolour = NA,
outer.linesize = NA,
inner.linetype = NA,
inner.linecolour = NA,
inner.linesize = NA,
center.linetype = NA,
center.linecolour = NA,
center.linesize = NA
) {
outer_circle <- util_circle_data(1, npoints = nrow(data))
data_outer_circle <- transform(
data,
group = -1,
x = outer_circle$x,
y = outer_circle$y,
linetype = data$outer.linetype,
alpha = NA,
colour = data$outer.linecolour,
size = data$outer.linesize
)
inner_circle <- util_circle_data(sqrt(1 / 2), npoints = nrow(data))
data_inner_circle <- transform(
data,
group = -1,
x = inner_circle$x,
y = inner_circle$y,
linetype = data$inner.linetype,
alpha = NA,
colour = data$inner.linecolour,
size = data$inner.linesize
)
data_hline <- transform(
data,
group = -1,
x = -1,
y = 0,
xend = 1,
yend = 0,
alpha = NA,
linetype = data$center.linetype,
colour = data$center.linecolour,
size = data$center.linesize
)
data_hline <- unique(data_hline)
data_vline <- transform(
data,
group = -1,
x = 0,
y = -1,
xend = 0,
yend = 1,
alpha = NA,
linetype = data$center.linetype,
colour = data$center.linecolour,
size = data$center.linesize
)
data_vline <- unique(data_vline)
ggplot2:::ggname(
"geom_corr_circle",
grid::grobTree(
GeomPoint$draw_panel(data, panel_params, coord),
GeomSegment$draw_panel(data_hline, panel_params, coord),
GeomSegment$draw_panel(data_vline, panel_params, coord),
GeomPath$draw_panel(data_inner_circle, panel_params, coord),
GeomPath$draw_panel(data_outer_circle, panel_params, coord)
)
)
}
)
# ggrepel::geom_text_repel(
# data = fit,
# aes(label = xvariables),
# size = 2.5,
# box.padding = 0.4,
# segment.alpha = 0.3
# )
util_circle_data <-
function(radius = 1,
center = c(0, 0),
npoints = 100) {
tt <- seq(0, 2 * pi, length.out = npoints)
xvalues <- center[1] + radius * cos(tt)
yvalues <- center[2] + radius * sin(tt)
return(data.frame(x = xvalues, y = yvalues))
}
You can’t perform that action at this time.