Skip to content

Commit

Permalink
fixed filled/empty ellipses, added convex hulls
Browse files Browse the repository at this point in the history
  • Loading branch information
@fawda123
fawda123 committed Jul 3, 2017
1 parent eed1a42 commit 8ab5c56
Show file tree
Hide file tree
Showing 30 changed files with 180 additions and 62 deletions.
84 changes: 59 additions & 25 deletions R/ggord.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -14,6 +14,7 @@
#' @param ellipse logical if confidence ellipses are shown for each group, method from the ggbiplot package
#' @param ellipse_pro numeric indicating confidence value for the ellipses
#' @param poly logical if confidence ellipses are filled polygons, otherwise they are shown as empty ellipses
#' @param hull logical if convex hull is drawn around points or groups if provided
#' @param arrow numeric indicating length of the arrow heads on the vectors, use \code{NULL} to suppress arrows
#' @param ext numeric indicating scalar distance of the labels from the arrow ends
#' @param vec_ext numeric indicating a scalar extension for the ordination vectors
Expand All @@ -24,7 +25,7 @@
#' @param addpch numeric indicating point type of the species points if addpts is not \code{NULL}
#' @param txt numeric indicating size of the text labels for the vectors, use \code{NULL} to suppress labels
#' @param alpha numeric transparency of points and ellipses from 0 to 1
#' @param alpha_el numeric transparency for confidence ellipses
#' @param alpha_el numeric transparency for confidence ellipses, also applies to filled convex hulls
#' @param xlims two numeric values indicating x-axis limits
#' @param ylims two numeric values indicating y-axis limits
#' @param var_sub chr string indcating which labels to show. Regular expression matching is used.
Expand Down Expand Up @@ -175,8 +176,8 @@ ggord <- function(...) UseMethod('ggord')
#'
#' @method ggord default
ggord.default <- function(obs, vecs, axes = c('1', '2'), cols = NULL, addpts = NULL, obslab = FALSE,
ptslab = FALSE, ellipse = TRUE, ellipse_pro = 0.95, poly = TRUE, arrow = 0.4, ext = 1.2,
vec_ext = 1, vec_lab = NULL, size = 4, addsize = size/2, addcol = 'blue',
ptslab = FALSE, ellipse = TRUE, ellipse_pro = 0.95, poly = TRUE, hull = FALSE, arrow = 0.4,
ext = 1.2, vec_ext = 1, vec_lab = NULL, size = 4, addsize = size/2, addcol = 'blue',
addpch = 19, txt = 4, alpha = 1, alpha_el = 0.4, xlims = NULL, ylims = NULL, var_sub = NULL,
coord_fix = TRUE, parse = FALSE, ...){

Expand Down Expand Up @@ -253,33 +254,66 @@ ggord.default <- function(obs, vecs, axes = c('1', '2'), cols = NULL, addpts = N
# concentration ellipse if there are groups, from ggbiplot
if(!is.null(obs$Groups) & ellipse) {

theta <- c(seq(-pi, pi, length = 50), seq(pi, -pi, length = 50))
circle <- cbind(cos(theta), sin(theta))

ell <- ddply(obs, 'Groups', function(x) {
if(nrow(x) <= 2) {
return(NULL)
}
sigma <- var(cbind(x$one, x$two))
mu <- c(mean(x$one), mean(x$two))
ed <- sqrt(qchisq(ellipse_pro, df = 2))
data.frame(sweep(circle %*% chol(sigma) * ed, 2, mu, FUN = '+'))
})
names(ell)[2:3] <- c('one', 'two')

# get convex hull for ell object, this is a hack to make it work with geom_polygon
ell <- ddply(ell, .(Groups), function(x) x[chull(x$one, x$two), ])

if(poly){

p <- p + stat_ellipse(
aes_string(fill = 'Groups', colour = NULL, group = 'Groups'),
geom = 'polygon',
alpha = alpha_el,
type = 'norm',
level = ellipse_pro
)
p <- p + geom_polygon(data = ell, aes(group = Groups, fill = Groups), alpha = alpha_el)

} else {

theta <- c(seq(-pi, pi, length = 50), seq(pi, -pi, length = 50))
circle <- cbind(cos(theta), sin(theta))

ell <- ddply(obs, 'Groups', function(x) {
if(nrow(x) <= 2) {
return(NULL)
}
sigma <- var(cbind(x$one, x$two))
mu <- c(mean(x$one), mean(x$two))
ed <- sqrt(qchisq(ellipse_pro, df = 2))
data.frame(sweep(circle %*% chol(sigma) * ed, 2, mu, FUN = '+'))
})
names(ell)[2:3] <- c('one', 'two')

p <- p + geom_path(data = ell, aes_string(color = 'Groups', group = 'Groups'), alpha = alpha)
p <- p + geom_polygon(data = ell, aes_string(color = 'Groups', group = 'Groups'), fill = NA, alpha = alpha)

}

}

# add convex hull if true
if(hull){

if(!is.null(obs$Groups)){

# get convex hull
chulls <- ddply(obs, .(Groups), function(x) x[chull(x$one, x$two), ])

if(poly){

p <- p + geom_polygon(data = chulls, aes(group = Groups, fill = Groups), alpha = alpha_el)

} else {

p <- p + geom_polygon(data = chulls, aes(group = Groups, colour = Groups), fill = NA, alpha = alpha)

}

} else {

chulls <- obs[chull(obs$one, obs$two), ]

if(poly){

p <- p + geom_polygon(data = chulls, alpha = alpha_el)

} else {

p <- p + geom_polygon(data = chulls, alpha = alpha, fill = NA)

}

}

Expand Down
8 changes: 8 additions & 0 deletions README.Rmd
View file
Original file line number Diff line number Diff line change
Expand Up @@ -42,6 +42,14 @@ p + scale_shape_manual('Groups', values = c(1, 2, 3))
p + theme_classic()
p + theme(legend.position = 'top')
# transparent ellipses
p <- ggord(ord, iris$Species, poly = FALSE)
p
# convex hulls
p <- ggord(ord, iris$Species, ellipse = FALSE, hull = TRUE)
p
# change the vector labels with vec_lab
new_lab <- list(Sepal.Length = 'SL', Sepal.Width = 'SW', Petal.Width = 'PW',
Petal.Length = 'PL')
Expand Down
44 changes: 26 additions & 18 deletions README.html
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,7 @@

<head>

<meta charset="utf-8">
<meta charset="utf-8" />
<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
<meta name="generator" content="pandoc" />

Expand Down Expand Up @@ -152,38 +152,46 @@ <h4><em>Marcus W. Beck, <a href="mailto:[email protected]">[email protected]
<p><img src="README_files/figure-html/unnamed-chunk-3-4.png" /><!-- --></p>
<pre class="r"><code>p + theme(legend.position = &#39;top&#39;)</code></pre>
<p><img src="README_files/figure-html/unnamed-chunk-3-5.png" /><!-- --></p>
<pre class="r"><code># transparent ellipses
p &lt;- ggord(ord, iris$Species, poly = FALSE)
p</code></pre>
<p><img src="README_files/figure-html/unnamed-chunk-3-6.png" /><!-- --></p>
<pre class="r"><code># convex hulls
p &lt;- ggord(ord, iris$Species, ellipse = FALSE, hull = TRUE)
p</code></pre>
<p><img src="README_files/figure-html/unnamed-chunk-3-7.png" /><!-- --></p>
<pre class="r"><code># change the vector labels with vec_lab
new_lab &lt;- list(Sepal.Length = &#39;SL&#39;, Sepal.Width = &#39;SW&#39;, Petal.Width = &#39;PW&#39;,
Petal.Length = &#39;PL&#39;)
p &lt;- ggord(ord, iris$Species, vec_lab = new_lab)
p</code></pre>
<p><img src="README_files/figure-html/unnamed-chunk-3-6.png" /><!-- --></p>
<p><img src="README_files/figure-html/unnamed-chunk-3-8.png" /><!-- --></p>
<pre class="r"><code># observations as labels from row names
p &lt;- ggord(ord, iris$Species, obslab = TRUE)
p</code></pre>
<p><img src="README_files/figure-html/unnamed-chunk-3-7.png" /><!-- --></p>
<p><img src="README_files/figure-html/unnamed-chunk-3-9.png" /><!-- --></p>
<pre class="r"><code># principal components analysis with the iris dataset
# princomp
ord &lt;- princomp(iris[, 1:4])

ggord(ord, iris$Species)</code></pre>
<p><img src="README_files/figure-html/unnamed-chunk-3-8.png" /><!-- --></p>
<p><img src="README_files/figure-html/unnamed-chunk-3-10.png" /><!-- --></p>
<pre class="r"><code># principal components analysis with the iris dataset
# PCA
library(FactoMineR)

ord &lt;- PCA(iris[, 1:4], graph = FALSE)

ggord(ord, iris$Species)</code></pre>
<p><img src="README_files/figure-html/unnamed-chunk-3-9.png" /><!-- --></p>
<p><img src="README_files/figure-html/unnamed-chunk-3-11.png" /><!-- --></p>
<pre class="r"><code># principal components analysis with the iris dataset
# dudi.pca
library(ade4)

ord &lt;- dudi.pca(iris[, 1:4], scannf = FALSE, nf = 4)

ggord(ord, iris$Species)</code></pre>
<p><img src="README_files/figure-html/unnamed-chunk-3-10.png" /><!-- --></p>
<p><img src="README_files/figure-html/unnamed-chunk-3-12.png" /><!-- --></p>
<pre class="r"><code># multiple correspondence analysis with the tea dataset
# MCA
data(tea, package = &#39;FactoMineR&#39;)
Expand All @@ -192,47 +200,47 @@ <h4><em>Marcus W. Beck, <a href="mailto:[email protected]">[email protected]
ord &lt;- MCA(tea[, -1], graph = FALSE)

ggord(ord, tea$Tea)</code></pre>
<p><img src="README_files/figure-html/unnamed-chunk-3-11.png" /><!-- --></p>
<p><img src="README_files/figure-html/unnamed-chunk-3-13.png" /><!-- --></p>
<pre class="r"><code># multiple correspondence analysis with the tea dataset
# mca
library(MASS)

ord &lt;- mca(tea[, -1])

ggord(ord, tea$Tea)</code></pre>
<p><img src="README_files/figure-html/unnamed-chunk-3-12.png" /><!-- --></p>
<p><img src="README_files/figure-html/unnamed-chunk-3-14.png" /><!-- --></p>
<pre class="r"><code># multiple correspondence analysis with the tea dataset
# acm
ord &lt;- dudi.acm(tea[, -1], scannf = FALSE)

ggord(ord, tea$Tea)</code></pre>
<p><img src="README_files/figure-html/unnamed-chunk-3-13.png" /><!-- --></p>
<p><img src="README_files/figure-html/unnamed-chunk-3-15.png" /><!-- --></p>
<pre class="r"><code># nonmetric multidimensional scaling with the iris dataset
# metaMDS
library(vegan)
ord &lt;- metaMDS(iris[, 1:4])

ggord(ord, iris$Species)</code></pre>
<p><img src="README_files/figure-html/unnamed-chunk-3-14.png" /><!-- --></p>
<p><img src="README_files/figure-html/unnamed-chunk-3-16.png" /><!-- --></p>
<pre class="r"><code># linear discriminant analysis
# example from lda in MASS package
ord &lt;- lda(Species ~ ., iris, prior = rep(1, 3)/3)

ggord(ord, iris$Species)</code></pre>
<p><img src="README_files/figure-html/unnamed-chunk-3-15.png" /><!-- --></p>
<p><img src="README_files/figure-html/unnamed-chunk-3-17.png" /><!-- --></p>
<pre class="r"><code># correspondence analysis
# dudi.coa
ord &lt;- dudi.coa(iris[, 1:4], scannf = FALSE, nf = 4)

ggord(ord, iris$Species)</code></pre>
<p><img src="README_files/figure-html/unnamed-chunk-3-16.png" /><!-- --></p>
<p><img src="README_files/figure-html/unnamed-chunk-3-18.png" /><!-- --></p>
<pre class="r"><code># correspondence analysis
# ca
library(ca)
ord &lt;- ca(iris[, 1:4])

ggord(ord, iris$Species)</code></pre>
<p><img src="README_files/figure-html/unnamed-chunk-3-17.png" /><!-- --></p>
<p><img src="README_files/figure-html/unnamed-chunk-3-19.png" /><!-- --></p>
<pre class="r"><code># double principle coordinate analysis (DPCoA)
# dpcoa
library(ade4)
Expand All @@ -242,7 +250,7 @@ <h4><em>Marcus W. Beck, <a href="mailto:[email protected]">[email protected]
ord &lt;- dpcoa(data.frame(t(ecomor$habitat)), dtaxo, scan = FALSE, nf = 2)

ggord(ord, grp_in = grp, ellipse = FALSE, arrow = 0.2, txt = 3)</code></pre>
<p><img src="README_files/figure-html/unnamed-chunk-3-18.png" /><!-- --></p>
<p><img src="README_files/figure-html/unnamed-chunk-3-20.png" /><!-- --></p>
<pre class="r"><code>######
# triplots

Expand All @@ -253,17 +261,17 @@ <h4><em>Marcus W. Beck, <a href="mailto:[email protected]">[email protected]
ord &lt;- rda(varespec, varechem)

ggord(ord)</code></pre>
<p><img src="README_files/figure-html/unnamed-chunk-3-19.png" /><!-- --></p>
<p><img src="README_files/figure-html/unnamed-chunk-3-21.png" /><!-- --></p>
<pre class="r"><code># canonical correspondence analysis
# cca from vegan
ord &lt;- cca(varespec, varechem)

ggord(ord)</code></pre>
<p><img src="README_files/figure-html/unnamed-chunk-3-20.png" /><!-- --></p>
<p><img src="README_files/figure-html/unnamed-chunk-3-22.png" /><!-- --></p>
<pre class="r"><code># species points as text
# suppress site points
ggord(ord, ptslab = TRUE, size = NA, addsize = 5)</code></pre>
<p><img src="README_files/figure-html/unnamed-chunk-3-21.png" /><!-- --></p>
<p><img src="README_files/figure-html/unnamed-chunk-3-23.png" /><!-- --></p>
</div>
</div>

Expand All @@ -290,7 +298,7 @@ <h4><em>Marcus W. Beck, <a href="mailto:[email protected]">[email protected]
(function () {
var script = document.createElement("script");
script.type = "text/javascript";
script.src = "https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML";
script.src = "https://mathjax.rstudio.com/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML";
document.getElementsByTagName("head")[0].appendChild(script);
})();
</script>
Expand Down
Loading

0 comments on commit 8ab5c56

Please sign in to comment.