r - Convex hulls with ggbiplot -
based on below tried script plotting pca convex hulls without success, idea how can solve it?
library(ggbiplot) library(plyr) data <-read.csv("c:/users/aaa.csv") my.pca <- prcomp(data[,1:9] , scale. = true) find_hull <- function(my.pca) my.pca[chull(my.pca$x[,1], my.pca$x[,2]), ] hulls <- ddply(my.pca , "group", find_hull) ggbiplot(my.pca, obs.scale = 1, var.scale = 1,groups = data$group) + scale_color_discrete(name = '') + geom_polygon(data=hulls, alpha=.2) + theme_bw() + theme(legend.direction = 'horizontal', legend.position = 'top')
thanks.
the script below plot pca ellipses (slightly modified example https://github.com/vqv/ggbiplot 'opts' deprecated)
library(ggbiplot) data(wine) wine.pca <- prcomp(wine, scale. = true) g <- ggbiplot(wine.pca, obs.scale = 1, var.scale = 1, groups = wine.class, ellipse = true, circle = true) g <- g + scale_color_discrete(name = '') g <- g + theme(legend.direction = 'horizontal', legend.position = 'top') print(g)
removing the ellipses easy trying to replace them convex hulls without success, idea how it?
thanks
yes, can design new geom ggplot, , use ggbiplot. here's new geom convex hulls:
library(ggplot2) statbag <- ggproto("statbag", stat, compute_group = function(data, scales, prop = 0.5) { ################################# ################################# # aplpack package, plotting functions removed plothulls_ <- function(x, y, fraction, n.hull = 1, col.hull, lty.hull, lwd.hull, density=0, ...){ # function data peeling: # x,y : data # fraction.in.inner.hull : max percentage of points within hull drawn # n.hull : number of hulls plotted (if there no fractiion argument) # col.hull, lty.hull, lwd.hull : style of hull line # plotting bits have been removed, bm 160321 # pw 130524 if(ncol(x) == 2){ y <- x[,2]; x <- x[,1] } n <- length(x) if(!missing(fraction)) { # find special hull n.hull <- 1 if(missing(col.hull)) col.hull <- 1 if(missing(lty.hull)) lty.hull <- 1 if(missing(lwd.hull)) lwd.hull <- 1 x.old <- x; y.old <- y idx <- chull(x,y); x.hull <- x[idx]; y.hull <- y[idx] for( in 1:(length(x)/3)){ x <- x[-idx]; y <- y[-idx] if( (length(x)/n) < fraction ){ return(cbind(x.hull,y.hull)) } idx <- chull(x,y); x.hull <- x[idx]; y.hull <- y[idx]; } } if(missing(col.hull)) col.hull <- 1:n.hull if(length(col.hull)) col.hull <- rep(col.hull,n.hull) if(missing(lty.hull)) lty.hull <- 1:n.hull if(length(lty.hull)) lty.hull <- rep(lty.hull,n.hull) if(missing(lwd.hull)) lwd.hull <- 1 if(length(lwd.hull)) lwd.hull <- rep(lwd.hull,n.hull) result <- null for( in 1:n.hull){ idx <- chull(x,y); x.hull <- x[idx]; y.hull <- y[idx] result <- c(result, list( cbind(x.hull,y.hull) )) x <- x[-idx]; y <- y[-idx] if(0 == length(x)) return(result) } result } # end of definition of plothulls ################################# # prepare data go function below the_matrix <- matrix(data = c(data$x, data$y), ncol = 2) # data out of function df names setnames(data.frame(plothulls_(the_matrix, fraction = prop)), nm = c("x", "y")) # how can hull , loop vertices passed on also? }, required_aes = c("x", "y") ) #' @inheritparams ggplot2::stat_identity #' @param prop proportion of points included in bag (default 0.5) stat_bag <- function(mapping = null, data = null, geom = "polygon", position = "identity", na.rm = false, show.legend = na, inherit.aes = true, prop = 0.5, alpha = 0.3, ...) { layer( stat = statbag, data = data, mapping = mapping, geom = geom, position = position, show.legend = show.legend, inherit.aes = inherit.aes, params = list(na.rm = na.rm, prop = prop, alpha = alpha, ...) ) } geom_bag <- function(mapping = null, data = null, stat = "identity", position = "identity", prop = 0.5, alpha = 0.3, ..., na.rm = false, show.legend = na, inherit.aes = true) { layer( data = data, mapping = mapping, stat = statbag, geom = geombag, position = position, show.legend = show.legend, inherit.aes = inherit.aes, params = list( na.rm = na.rm, alpha = alpha, prop = prop, ... ) ) } #' @rdname ggplot2-ggproto #' @format null #' @usage null #' @export geombag <- ggproto("geombag", geom, draw_group = function(data, panel_scales, coord) { n <- nrow(data) if (n == 1) return(zerogrob()) munched <- coord_munch(coord, data, panel_scales) # sort group make sure colors, fill, etc. come in same order munched <- munched[order(munched$group), ] # gpar(), there 1 entry per polygon (not 1 entry per point). # we'll pull first value each group, , assume these values # same within each group. first_idx <- !duplicated(munched$group) first_rows <- munched[first_idx, ] ggplot2:::ggname("geom_bag", grid:::polygongrob(munched$x, munched$y, default.units = "native", id = munched$group, gp = grid::gpar( col = first_rows$colour, fill = alpha(first_rows$fill, first_rows$alpha), lwd = first_rows$size * .pt, lty = first_rows$linetype ) ) ) }, default_aes = aes(colour = "na", fill = "grey20", size = 0.5, linetype = 1, alpha = na, prop = 0.5), handle_na = function(data, params) { data }, required_aes = c("x", "y"), draw_key = draw_key_polygon )
and here in use ggbiplot, set prop
1 indicate want draw polygon encloses points:
library(ggbiplot) data(wine) wine.pca <- prcomp(wine, scale. = true) g <- ggbiplot(wine.pca, obs.scale = 1, var.scale = 1, groups = wine.class, ellipse = false, circle = true) g <- g + scale_color_discrete(name = '') g <- g + theme(legend.direction = 'horizontal', legend.position = 'top') g + geom_bag(aes(group = wine.class, fill = wine.class), prop = 1)
Comments
Post a Comment