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)  

enter image description here


Comments

Popular posts from this blog

css - Which browser returns the correct result for getBoundingClientRect of an SVG element? -

gcc - Calling fftR4() in c from assembly -

.htaccess - Matching full URL in RewriteCond -