如何使用FactoMineR包以编程方式确定主要成分的列索引?

时间:2018-07-17 10:54:05

标签: r cluster-analysis pca feature-selection unsupervised-learning

给出一个包含混合变量(即分类变量和连续变量)的数据框,例如

digits = 0:9
# set seed for reproducibility
set.seed(17)
# function to create random string
createRandString <- function(n = 5000) {
  a <- do.call(paste0, replicate(5, sample(LETTERS, n, TRUE), FALSE))
  paste0(a, sprintf("%04d", sample(9999, n, TRUE)), sample(LETTERS, n, TRUE))
}

df <- data.frame(ID=c(1:10), name=sample(letters[1:10]),
                 studLoc=sample(createRandString(10)),
                 finalmark=sample(c(0:100),10),
                 subj1mark=sample(c(0:100),10),subj2mark=sample(c(0:100),10)
                 )

我使用软件包FactoMineR

执行无监督的功能选择
df.princomp <- FactoMineR::FAMD(df, graph = FALSE)

变量df.princomp是一个列表。

此后,为了可视化我使用的主要组件 fviz_screeplot()fviz_contrib()之类的

#library(factoextra)
factoextra::fviz_screeplot(df.princomp, addlabels = TRUE,
                           barfill = "gray", barcolor = "black",
                           ylim = c(0, 50), xlab = "Principal Component", 
                           ylab = "Percentage of explained variance",
                           main = "Principal Component (PC) for mixed variables")

factoextra::fviz_contrib(df.princomp, choice = "var", 
                         axes = 1, top = 10, sort.val = c("desc"))

给出下面的图1

enter image description here

和图2

enter image description here

图1的解释:图1是一个卵形图。 Scree图是一个简单的线段图,它显示了每个主成分(PC)解释或表示的数据中总方差的分数。因此,我们可以看到前三个PC共同负责43.8%的总方差。现在自然会产生一个问题,“这些变量是什么?”。我在图2中显示了这一点。

图2的说明:此图显示了主成分分析(PCA)结果中行/列的贡献。从这里我可以看到变量namestudLocfinalMark是可以用于进一步分析的最重要的变量。

进一步的分析-我被困在其中:要导出上述变量namestudLocfinalMark的贡献。我使用像df.princompdf.princomp$quanti.var$contrib[,4]这样的主成分变量df.princomp$quali.var$contrib[,2:3](见上文)。

我必须手动指定列索引[,2:3][,4]

我想要的:我想知道如何进行动态列索引分配,这样就不必手动对列表{{1}中的列索引[,2:3]进行编码}?

我已经看过以下类似的问题1234,但找不到我的解决方案吗?解决该问题的任何帮助或建议都会有所帮助。

2 个答案:

答案 0 :(得分:1)

不确定我对您的问题的解释是否正确,如果不正确,请您道歉。根据我的收集,您正在使用PCA作为初始工具,向您展示哪些变量对解释数据集最重要。然后,您想回到原始数据,快速选择这些变量,而无需每次都进行手动编码,然后将其用于其他分析。

如果这是正确的,那么我已经保存了贡献图中的数据,过滤掉了贡献最大的变量,并使用该结果创建了一个仅包含这些变量的新数据框。

digits = 0:9
# set seed for reproducibility
set.seed(17)
# function to create random string
createRandString <- function(n = 5000) {
  a <- do.call(paste0, replicate(5, sample(LETTERS, n, TRUE), FALSE))
  paste0(a, sprintf("%04d", sample(9999, n, TRUE)), sample(LETTERS, n, TRUE))
}

df <- data.frame(ID=c(1:10), name=sample(letters[1:10]),
                 studLoc=sample(createRandString(10)),
                 finalmark=sample(c(0:100),10),
                 subj1mark=sample(c(0:100),10),subj2mark=sample(c(0:100),10)
)

df.princomp <- FactoMineR::FAMD(df, graph = FALSE)

factoextra::fviz_screeplot(df.princomp, addlabels = TRUE,
                           barfill = "gray", barcolor = "black",
                           ylim = c(0, 50), xlab = "Principal Component", 
                           ylab = "Percentage of explained variance",
                           main = "Principal Component (PC) for mixed variables")

#find the top contributing variables to the overall variation in the dataset
#here I am choosing the top 10 variables (although we only have 6 in our df).
#note you can specify which axes you want to look at with axes=, you can even do axes=c(1,2)

f<-factoextra::fviz_contrib(df.princomp, choice = "var", 
                         axes = c(1), top = 10, sort.val = c("desc"))

#save data from contribution plot
dat<-f$data

#filter out ID's that are higher than, say, 20

r<-rownames(dat[dat$contrib>20,])

#extract these from your original data frame into a new data frame for further analysis

new<-df[r]

new

#finalmark name    studLoc
#1         53    b POTYQ0002N
#2         73    i LWMTW1195I
#3         95    d VTUGO1685F
#4         39    f YCGGS5755N
#5         97    c GOSWE3283C
#6         58    g APBQD6181U
#7         67    a VUJOG1460V
#8         64    h YXOGP1897F
#9         15    j NFUOB6042V
#10        81    e QYTHG0783G

根据您的评论,您说要“在Dim.1和Dim.2中查找值大于5的变量并将这些变量保存到新的数据框中”,我会这样做:

#top contributors to both Dim 1 and 2

f<-factoextra::fviz_contrib(df.princomp, choice = "var", 
                         axes = c(1,2), top = 10, sort.val = c("desc"))

#save data from contribution plot
dat<-f$data

#filter out ID's that are higher than 5

r<-rownames(dat[dat$contrib>5,])

#extract these from your original data frame into a new data frame for further analysis

new<-df[r]

new

(这将所有原始变量保留在我们的新数据框中,因为它们对总方差的贡献超过5%)

答案 1 :(得分:0)

有很多方法可以提取单个变量对PC的贡献。对于数字输入,可以使用prcomp运行PCA并查看$rotation(我很快就和您交谈了,忘记了这里有因素,因此prcomp无法直接使用)。由于您使用的是factoextra::fviz_contrib,因此有必要检查该函数如何在后台提取这些信息。键入factoextra::fviz_contrib并阅读函数:

> factoextra::fviz_contrib
function (X, choice = c("row", "col", "var", "ind", "quanti.var", 
    "quali.var", "group", "partial.axes"), axes = 1, fill = "steelblue", 
    color = "steelblue", sort.val = c("desc", "asc", "none"), 
    top = Inf, xtickslab.rt = 45, ggtheme = theme_minimal(), 
    ...) 
{
    sort.val <- match.arg(sort.val)
    choice = match.arg(choice)
    title <- .build_title(choice[1], "Contribution", axes)
    dd <- facto_summarize(X, element = choice, result = "contrib", 
        axes = axes)
    contrib <- dd$contrib
    names(contrib) <- rownames(dd)
    theo_contrib <- 100/length(contrib)
    if (length(axes) > 1) {
        eig <- get_eigenvalue(X)[axes, 1]
        theo_contrib <- sum(theo_contrib * eig)/sum(eig)
    }
    df <- data.frame(name = factor(names(contrib), levels = names(contrib)), 
        contrib = contrib)
    if (choice == "quanti.var") {
        df$Groups <- .get_quanti_var_groups(X)
        if (missing(fill)) 
            fill <- "Groups"
        if (missing(color)) 
            color <- "Groups"
    }
    p <- ggpubr::ggbarplot(df, x = "name", y = "contrib", fill = fill, 
        color = color, sort.val = sort.val, top = top, main = title, 
        xlab = FALSE, ylab = "Contributions (%)", xtickslab.rt = xtickslab.rt, 
        ggtheme = ggtheme, sort.by.groups = FALSE, ...) + geom_hline(yintercept = theo_contrib, 
        linetype = 2, color = "red")
    p
}
<environment: namespace:factoextra>

因此,它实际上只是从同一包中调用facto_summarize。打个比方,您可以做同样的事情,只需调用:

> dd <- factoextra::facto_summarize(df.princomp, element = "var", result = "contrib", axes = 1)
> dd
               name    contrib
ID               ID  0.9924561
finalmark finalmark 21.4149175
subj1mark subj1mark  7.1874438
subj2mark subj2mark 16.6831560
name           name 26.8610132
studLoc     studLoc 26.8610132

这是与您的图2对应的表。对于PC2,请使用axes = 2,依此类推。

关于“如何以编程方式确定PC的列索引”,我不确定100%是否了解您想要的内容,但是,如果您只是想对“ finalmark”列说一下,请抓住它对PC3的贡献,请执行以下操作:

library(tidyverse)
# make a tidy table of all column names in the original df with their contributions to all PCs
contribution_df <- map_df(set_names(1:5), ~factoextra::facto_summarize(df.princomp, element = "var", result = "contrib", axes = .x), .id = "PC")

# get the contribution of column 'finalmark' by name
contribution_df %>%
  filter(name == "finalmark")

# get the contribution of column 'finalmark' to PC3
contribution_df %>%
  filter(name == "finalmark" & PC == 3)

# or, just the numeric value of contribution
filter(contribution_df, name == "finalmark" & PC == 3)$contrib

顺便说一句,我认为您的示例中的ID被视为数字而不是因子,但是由于它只是一个示例,因此我无需理会。