Factoextra - 省略記号と変数の線幅を変更する

Question

現在、factomineRとfactoextraパッケージでpcaを作成しています。

データアイリスと私のコードの例：私は、変数の幅のための楕円と同じ周囲の線の幅を変更したい

library(FactoMineR) 
library(factoextra) 

data(iris) 
res.pca<-PCA(iris , scale.unit=TRUE, ncp=2, quali.sup=c(5), graph = FALSE) 

fviz_pca_biplot(res.pca, label="var", habillage=5, 
       addEllipses=TRUE) + theme_minimal() 

http://i.stack.imgur.com/s7JO4.png

。私はいくつかの方法を試しましたが、私が望むようにする方法を理解できませんでした。

アイデア？

Answer 1

私は必要な機能のコピーを作成し、その中のコードを変更します。具体的には、省略記号の幅を広げるには、ggplot2::stat_ellipseコマンドの呼び出しでsize=..を追加します。

my_fviz_pca_biplot <- function (X, axes = c(1, 2), geom = c("point", "text"), label = "all", 
           invisible = "none", labelsize = 4, pointsize = 2, habillage = "none", 
           addEllipses = FALSE, ellipse.level = 0.95, col.ind = "black", 
           col.ind.sup = "blue", alpha.ind = 1, col.var = "steelblue", 
           alpha.var = 1, col.quanti.sup = "blue", col.circle = "grey70", 
           repel = FALSE, axes.linetype = "dashed", select.var = list(name = NULL, 
                          cos2 = NULL, contrib = NULL), select.ind = list(name = NULL, 
                                      cos2 = NULL, contrib = NULL), title = "Biplot of variables and individuals", 
           jitter = list(what = "label", width = NULL, height = NULL), 
           ...) 
{ 
    if (is.null(jitter$what)) 
    jitter$what <- "label" 
    if (length(axes) != 2) 
    stop("axes should be of length 2") 
    scale.unit <- .get_scale_unit(X) 
    var <- facto_summarize(X, element = "var", result = c("coord", 
                 "contrib", "cos2"), axes = axes) 
    colnames(var)[2:3] <- c("x", "y") 
    var.all <- var 
    if (!is.null(select.var)) 
    var <- .select(var, select.var) 
    lab <- .label(label) 
    hide <- .hide(invisible) 
    alpha.limits <- NULL 
    if (alpha.var %in% c("cos2", "contrib", "coord", "x", "y")) 
    alpha.limits = range(var.all[, alpha.var]) 
    pca.ind <- get_pca_ind(X) 
    ind <- data.frame(pca.ind$coord[, axes, drop = FALSE]) 
    colnames(ind) <- c("x", "y") 
    r <- min((max(ind[, "x"]) - min(ind[, "x"])/(max(var[, "x"]) - 
               min(var[, "x"]))), (max(ind[, "y"]) - min(ind[, "y"])/(max(var[, 
                               "y"]) - min(var[, "y"])))) 
    var[, c("x", "y")] <- var[, c("x", "y")] * r * 0.7 
    p <- my_fviz_pca_ind(X, axes = axes, geom = geom, repel = repel, 
         label = label, invisible = invisible, labelsize = labelsize, 
         pointsize = pointsize, axes.linetype = axes.linetype, 
         col.ind = col.ind, col.ind.sup = col.ind.sup, alpha.ind = alpha.ind, 
         habillage = habillage, addEllipses = addEllipses, ellipse.level = ellipse.level, 
         select.ind = select.ind, jitter = jitter) 
    if (!hide$var) { 
    p <- .ggscatter(p = p, data = var, x = "x", y = "y", 
        col = col.var, alpha = alpha.var, alpha.limits = alpha.limits, 
        geom = c("arrow", "text"), repel = repel, lab = lab$var, 
        labelsize = labelsize, jitter = jitter) 
    } 
    if (inherits(X, "PCA") & !hide$quanti) { 
    quanti_sup <- .get_supp(X, element = "quanti", axes = axes, 
          select = select.var) 
    if (!is.null(quanti_sup)) 
     colnames(quanti_sup)[2:3] <- c("x", "y") 
    if (!is.null(quanti_sup)) { 
     p <- fviz_add(p, df = quanti_sup[, 2:3, drop = FALSE] * 
         r * 0.7, geom = c("arrow", "text"), color = col.quanti.sup, 
        linetype = 2, labelsize = labelsize, addlabel = (lab$quanti), 
        jitter = jitter) 
    } 
    } 
    title2 <- title 
    p + labs(title = title2) 
} 

environment(my_fviz_pca_biplot) <- environment(fviz_pca_biplot) 

my_fviz_pca_ind <- function (X, axes = c(1, 2), geom = c("point", "text"), repel = FALSE, 
          label = "all", invisible = "none", labelsize = 4, pointsize = 2, 
          habillage = "none", addEllipses = FALSE, ellipse.level = 0.95, 
          ellipse.type = "norm", ellipse.alpha = 0.1, col.ind = "black", 
          col.ind.sup = "blue", alpha.ind = 1, select.ind = list(name = NULL, 
                        cos2 = NULL, contrib = NULL), jitter = list(what = "label", 
                                   width = NULL, height = NULL), title = "Individuals factor map - PCA", 
          axes.linetype = "dashed", ...) 
{ 
    if (length(intersect(geom, c("point", "text", "arrow"))) == 
     0) 
    stop("The specified value(s) for the argument geom are not allowed ") 
    if (length(axes) != 2) 
    stop("axes should be of length 2") 
    if (is.null(jitter$what)) 
    jitter$what <- "label" 
    ind <- facto_summarize(X, element = "ind", result = c("coord", 
                 "contrib", "cos2"), axes = axes) 
    colnames(ind)[2:3] <- c("x", "y") 
    ind.all <- ind 
    if (!is.null(select.ind)) 
    ind <- .select(ind, select.ind) 
    lab <- .label(label) 
    hide <- .hide(invisible) 
    alpha.limits <- NULL 
    if (alpha.ind %in% c("cos2", "contrib", "coord", "x", "y")) 
    alpha.limits = range(ind.all[, alpha.ind]) 
    if (habillage[1] == "none") { 
    p <- ggplot() 
    if (hide$ind) 
     p <- ggplot() + geom_blank(data = ind, aes_string("x", 
                 "y")) 
    else p <- .ggscatter(data = ind, x = "x", y = "y", col = col.ind, 
         alpha = alpha.ind, repel = repel, alpha.limits = alpha.limits, 
         shape = 19, geom = geom, lab = lab$ind, labelsize = labelsize, 
         pointsize = pointsize, jitter = jitter) 
    } 
    else { 
    p <- ggplot() 
    if (hide$ind & hide$quali) 
     p <- ggplot() + geom_blank(data = ind, aes_string("x", 
                 "y")) 
    if (inherits(X, "PCA") & length(habillage) == 1) { 
     data <- X$call$X 
     if (is.numeric(habillage)) 
     name.quali <- colnames(data)[habillage] 
     else name.quali <- habillage 
     ind <- cbind.data.frame(data[rownames(ind), name.quali], 
           ind) 
     colnames(ind)[1] <- name.quali 
     ind[, 1] <- as.factor(ind[, 1]) 
    } 
    else { 
     if (nrow(ind) != length(habillage)) 
     stop("The number of active individuals used in the PCA is different ", 
      "from the length of the factor habillage. Please, remove the supplementary ", 
      "individuals in the variable habillage.") 
     name.quali <- "Groups" 
     ind <- cbind.data.frame(Groups = habillage, ind) 
     ind[, 1] <- as.factor(ind[, 1]) 
    } 
    if (!hide$ind) { 
     label_coord <- ind 
     if (jitter$what %in% c("both", "b")) { 
     label_coord <- ind <- .jitter(ind, jitter) 
     } 
     else if (jitter$what %in% c("point", "p")) { 
     ind <- .jitter(ind, jitter) 
     } 
     else if (jitter$what %in% c("label", "l")) { 
     label_coord <- .jitter(label_coord, jitter) 
     } 
     if ("point" %in% geom) 
     p <- p + geom_point(data = ind, aes_string("x", 
                "y", color = name.quali, shape = name.quali), 
          size = pointsize) 
     if (lab$ind & "text" %in% geom) { 
     if (repel) 
      p <- p + ggrepel::geom_text_repel(data = label_coord, 
              aes_string("x", "y", label = "name", color = name.quali, 
                 shape = name.quali), size = labelsize) 
     else p <- p + geom_text(data = label_coord, aes_string("x", 
                   "y", label = "name", color = name.quali, shape = name.quali), 
           size = labelsize, vjust = -0.7) 
     } 
    } 
    if (!hide$quali) { 
     coord_quali.sup <- .get_coord_quali(ind$x, ind$y, 
              groups = ind[, 1]) 
     coord_quali.sup <- cbind.data.frame(name = rownames(coord_quali.sup), 
              coord_quali.sup) 
     colnames(coord_quali.sup)[1] <- name.quali 
     coord_quali.sup[, 1] <- as.factor(coord_quali.sup[, 
                 1]) 
     if ("point" %in% geom) { 
     p <- p + geom_point(data = coord_quali.sup, aes_string("x", 
                   "y", color = name.quali, shape = name.quali), 
          size = pointsize * 2) 
     } 
     if (lab$quali & "text" %in% geom) { 
     if (repel) 
      p <- p + ggrepel::geom_text_repel(data = coord_quali.sup, 
              aes_string("x", "y", color = name.quali), 
              label = rownames(coord_quali.sup), size = labelsize) 
     else p <- p + geom_text(data = coord_quali.sup, 
           aes_string("x", "y", color = name.quali), label = rownames(coord_quali.sup), 
           size = labelsize, vjust = -1) 
     } 
    } 
    if (addEllipses) { 
     if (ellipse.type == "convex") { 
     frame.data <- .cluster_chull(ind[, c("x", "y")], 
            ind[, name.quali]) 
     colnames(frame.data)[which(colnames(frame.data) == 
            "cluster")] <- name.quali 
     mapping = aes_string(x = "x", y = "y", colour = name.quali, 
          fill = name.quali, group = name.quali) 
     p <- p + ggplot2::geom_polygon(data = frame.data, 
             mapping = mapping, alpha = ellipse.alpha) 
     } 
     else if (ellipse.type %in% c("t", "norm", "euclid")) { 
     mapping = aes_string(x = "x", y = "y", colour = name.quali, 
          group = name.quali, fill = name.quali) 
     p <- p + ggplot2::stat_ellipse(mapping = mapping, 
             data = ind, level = ellipse.level, type = ellipse.type, 
             alpha = ellipse.alpha, geom = "polygon", size=5) 
     } 
    } 
    } 
    if (inherits(X, "PCA") & !hide$ind.sup) { 
    ind_sup <- .get_supp(X, element = "ind.sup", axes = axes, 
         select = select.ind) 
    if (!is.null(ind_sup)) 
     colnames(ind_sup)[2:3] <- c("x", "y") 
    if (!is.null(ind_sup)) { 
     p <- fviz_add(p, df = ind_sup[, 2:3, drop = FALSE], 
        geom = geom, color = col.ind.sup, shape = 19, 
        pointsize = pointsize, labelsize = labelsize, 
        addlabel = (lab$ind.sup & "text" %in% geom), 
        jitter = jitter) 
    } 
    } 
    title2 <- title 
    p <- .fviz_finish(p, X, axes, axes.linetype) + labs(title = title2) 
    p 
} 

environment(my_fviz_pca_ind) <- environment(fviz_pca_ind) 

新しい機能を使用します。

my_fviz_pca_biplot(res.pca, label="var", habillage=5, 
            addEllipses=TRUE) + theme_minimal()