Exploratory Factor Analysis
Ryoya.I
2026-04-05
1.データの読み込みおよび前処理
prst1 <- read.csv("https://goo.gl/z5P8ce") #データの読み込み
summary(prst1) #基本統計量の確認## Adaptable BestValue CuttingEdge Delightful Exciting
## Min. :1.000 Min. :1.000 Min. :1.00 Min. :1.000 Min. :1.000
## 1st Qu.:4.000 1st Qu.:3.000 1st Qu.:3.00 1st Qu.:3.000 1st Qu.:3.000
## Median :4.000 Median :4.000 Median :4.00 Median :4.000 Median :4.000
## Mean :4.255 Mean :3.849 Mean :4.07 Mean :3.983 Mean :3.892
## 3rd Qu.:5.000 3rd Qu.:5.000 3rd Qu.:5.00 3rd Qu.:5.000 3rd Qu.:5.000
## Max. :7.000 Max. :7.000 Max. :7.00 Max. :7.000 Max. :7.000
## Friendly Generous Helpful Intuitive
## Min. :1.000 Min. :1.000 Min. :1.000 Min. :1.000
## 1st Qu.:4.000 1st Qu.:3.000 1st Qu.:3.000 1st Qu.:3.000
## Median :4.000 Median :4.000 Median :4.000 Median :4.000
## Mean :4.246 Mean :4.031 Mean :3.894 Mean :3.724
## 3rd Qu.:5.000 3rd Qu.:5.000 3rd Qu.:5.000 3rd Qu.:4.000
## Max. :7.000 Max. :7.000 Max. :7.000 Max. :7.000
## Brand
## Length:3050
## Class :character
## Mode :character
##
##
## str(prst1) #データの構造を確認## 'data.frame': 3050 obs. of 10 variables:
## $ Adaptable : int 6 4 3 4 4 4 5 4 5 5 ...
## $ BestValue : int 5 3 2 1 1 3 3 2 4 3 ...
## $ CuttingEdge: int 4 4 3 4 3 4 5 7 4 5 ...
## $ Delightful : int 4 2 6 4 3 4 4 5 3 4 ...
## $ Exciting : int 3 4 5 5 3 3 6 4 3 5 ...
## $ Friendly : int 4 4 5 4 5 4 3 3 4 6 ...
## $ Generous : int 5 5 6 5 5 6 5 5 4 4 ...
## $ Helpful : int 4 2 4 3 4 2 3 4 3 5 ...
## $ Intuitive : int 3 5 3 3 4 4 4 4 3 5 ...
## $ Brand : chr "Sierra" "Romeo" "Sierra" "Sierra" ...prst.sc <- prst1
prst.sc[, 1:9] <- data.frame(scale(prst1[, 1:9])) #１から９列目を標準化
summary(prst.sc)## Adaptable BestValue CuttingEdge Delightful
## Min. :-3.3414 Min. :-2.7323 Min. :-2.88159 Min. :-3.04151
## 1st Qu.:-0.2622 1st Qu.:-0.8139 1st Qu.:-1.00463 1st Qu.:-1.00202
## Median :-0.2622 Median : 0.1453 Median :-0.06616 Median : 0.01772
## Mean : 0.0000 Mean : 0.0000 Mean : 0.00000 Mean : 0.00000
## 3rd Qu.: 0.7643 3rd Qu.: 1.1045 3rd Qu.: 0.87232 3rd Qu.: 1.03746
## Max. : 2.8171 Max. : 3.0228 Max. : 2.74928 Max. : 3.07695
## Exciting Friendly Generous Helpful
## Min. :-2.8785 Min. :-3.2141 Min. :-3.20078 Min. :-2.67745
## 1st Qu.:-0.8881 1st Qu.:-0.2435 1st Qu.:-1.08908 1st Qu.:-0.82696
## Median : 0.1070 Median :-0.2435 Median :-0.03323 Median : 0.09829
## Mean : 0.0000 Mean : 0.0000 Mean : 0.00000 Mean : 0.00000
## 3rd Qu.: 1.1022 3rd Qu.: 0.7467 3rd Qu.: 1.02262 3rd Qu.: 1.02353
## Max. : 3.0925 Max. : 2.7271 Max. : 3.13431 Max. : 2.87403
## Intuitive Brand
## Min. :-2.8282 Length:3050
## 1st Qu.:-0.7519 Class :character
## Median : 0.2863 Mode :character
## Mean : 0.0000
## 3rd Qu.: 0.2863
## Max. : 3.40072.探索的因子分析
library(nFactors)## Warning: package 'nFactors' was built under R version 4.5.3ns <- nScree(prst.sc[, 1:9]) #スクリーテスト
plotnScree(ns) #可視化
eigen(cor(prst.sc[, 1:9])) #固有値と固有ベクトルを表示## eigen() decomposition
## $values
## [1] 1.9573315 1.8432173 1.2354099 0.8320148 0.7181264 0.6963876 0.6060699
## [8] 0.5818321 0.5296106
##
## $vectors
## [,1] [,2] [,3] [,4] [,5]
## [1,] -0.454796056 0.018771390 0.484854547 -0.022290444 -0.001595812
## [2,] -0.200424840 0.022560279 0.758421452 -0.036874375 -0.040645411
## [3,] -0.004346220 -0.550602529 0.049599530 0.140771690 0.328512346
## [4,] -0.008382854 -0.493143304 -0.006078214 0.284618447 -0.816903535
## [5,] -0.015746816 -0.532195521 0.026882143 0.283250965 0.465175395
## [6,] -0.488578311 0.007292388 -0.259651422 -0.037444609 0.028633300
## [7,] -0.004171407 -0.411362484 -0.034895270 -0.901283819 -0.062223349
## [8,] -0.482335720 0.012399852 -0.233318665 0.002813413 0.026111045
## [9,] -0.530357797 -0.011274003 -0.251831534 0.058012424 -0.036498109
## [,6] [,7] [,8] [,9]
## [1,] 0.049382497 -0.18545094 0.32478016 0.64413664
## [2,] -0.019143658 0.13485725 -0.28416622 -0.53085088
## [3,] -0.187618684 0.70577873 0.04259771 0.17743129
## [4,] 0.016784507 -0.06080094 -0.05827660 0.03144492
## [5,] 0.167478871 -0.60095192 -0.04878140 -0.16615068
## [6,] 0.626816396 0.18494971 -0.50286566 0.10778763
## [7,] 0.003136973 -0.10013813 0.03733792 -0.04393123
## [8,] -0.733596722 -0.17012473 -0.37927746 0.03336511
## [9,] 0.050896382 0.10621403 0.63879392 -0.47806620factanal(prst.sc[, 1:9], factor=2)##
## Call:
## factanal(x = prst.sc[, 1:9], factors = 2)
##
## Uniquenesses:
## Adaptable BestValue CuttingEdge Delightful Exciting Friendly
## 0.829 0.988 0.581 0.751 0.645 0.674
## Generous Helpful Intuitive
## 0.859 0.698 0.526
##
## Loadings:
## Factor1 Factor2
## Adaptable 0.414
## BestValue 0.111
## CuttingEdge 0.647
## Delightful 0.498
## Exciting 0.596
## Friendly 0.571
## Generous 0.376
## Helpful 0.550
## Intuitive 0.687
##
## Factor1 Factor2
## SS loadings 1.286 1.164
## Proportion Var 0.143 0.129
## Cumulative Var 0.143 0.272
##
## Test of the hypothesis that 2 factors are sufficient.
## The chi square statistic is 523.11 on 19 degrees of freedom.
## The p-value is 7.84e-99factanal(prst.sc[, 1:9], factor=3)##
## Call:
## factanal(x = prst.sc[, 1:9], factors = 3)
##
## Uniquenesses:
## Adaptable BestValue CuttingEdge Delightful Exciting Friendly
## 0.706 0.005 0.579 0.752 0.646 0.671
## Generous Helpful Intuitive
## 0.859 0.699 0.506
##
## Loadings:
## Factor1 Factor2 Factor3
## Adaptable 0.372 0.394
## BestValue 0.997
## CuttingEdge 0.648
## Delightful 0.498
## Exciting 0.595
## Friendly 0.573
## Generous 0.376
## Helpful 0.548
## Intuitive 0.702
##
## Factor1 Factor2 Factor3
## SS loadings 1.262 1.164 1.152
## Proportion Var 0.140 0.129 0.128
## Cumulative Var 0.140 0.270 0.398
##
## Test of the hypothesis that 3 factors are sufficient.
## The chi square statistic is 11.99 on 12 degrees of freedom.
## The p-value is 0.446探索的因子分析とは、観測された複数の変数に隠れ潜む共通の概念を発見する手法である。因子とは複数の変数に対して影響を与えている潜在的な概念を指す。例えば、「語彙力」「読解力」「文章力」の3変数が共通して高いという結果には、背後に「言語能力」という因子があると考えられる。換言すると、実証的に観察できるもの（顕在変数）ではないが、複数の変数を通して明らかになるもの（潜在変数）である。
固有値とは、ある因子が観測変数全体における分散を、どの程度説明するかを示す指標である。例えば、固有値 = 2.0 だとその因子は2変数分のばらつきを説明していると解釈する。また、因子の採用には固有値1以上の基準を設ける（Kaiser基準）。スクリーテストとは、固有値を大きい順に並べた際、固有値の減少が急から緩やかに変化する点の直前までを因子数とする手続きであり、今回は3因子を採用する。
factanal（）は因子分析を行う関数であり、factor=kで因子数を指定できる。Uniquenesses（独自性）はその変数の分散のうち、因子で説明できなかった部分である。例えば、Adaptableが0.829なら、1 - Uniqueness(0.829) = 0.171（17%）は因子で説明できた割合となる。Loadings（因子負荷量）は厳密には変数と因子の共分散なのだが、factanal（）は変数を標準化してから計算するため、結果として相関係数と一致する。また、0に近い因子負荷量は表示されない。それを踏まえて、どの変数がどの因子にどれだけ強く結びついているかを確認する。
SS loadingsは各変数における負荷量の二乗和であり、その因子がどれくらい分散を説明するかを示す。因子数を2に指定したときの出力だと、Factor1のSS loadingsが1.286なら、9変数のばらつきのうち1.286個分説明していると読む。Proportion Varは全変数のうち、その因子が説明する割合である。SS loadingsが1.286の例だと、Factor1は0.140（14.3%）ほど説明していると読む。SS loadingsは個数単位で、Proportion Varは割合で示しているところに注意されたい。Cumulative Varはそれまでの因子における分散の説明割合を足し合わせたものである。Factor2のCumulative Varだと、Factor1(0.140)とFactor2(0.129)のProportion Varを足し合わせて四捨五入したものが0.270と出力されている。
P値の解釈について、Factor=2だと7.84e-99（ほぼ0）であり、Factor=3だと0.446（44.6%）である。検定では「P値が小さい=有意な差がある」という解釈になることが多いが、因子分析における帰無仮説は「この因子数でデータを十分に説明できている」となる。つまり、データとモデルに有意な差があると、それは因子モデルが変数間の関係を再現できてないことになる。その場合はモデルの再現性を上げるため、因子数を増やす必要がある。
3. 因子と各変数の因子負荷量ヒートマップとパス図
library(gplots)## Warning: package 'gplots' was built under R version 4.5.3##
## ---------------------
## gplots 3.3.0 loaded:
## * Use citation('gplots') for citation info.
## * Homepage: https://talgalili.github.io/gplots/
## * Report issues: https://github.com/talgalili/gplots/issues
## * Ask questions: https://stackoverflow.com/questions/tagged/gplots
## * Suppress this message with: suppressPackageStartupMessages(library(gplots))
## ---------------------##
## Attaching package: 'gplots'## The following object is masked from 'package:stats':
##
## lowesslibrary(RColorBrewer)
brand.fa <- factanal(prst.sc[, 1:9], factor=3)
heatmap.2(brand.fa$loadings,
col = brewer.pal(9, "Greens"), #色を緑の9段階の濃淡で表示
trace = "none", #トレースラインの非表示(デフォだと表示)
key = TRUE, #色の凡例を表示
dend = "none", #樹形図の非表示
Colv = FALSE, #因子列の並び替えなし
cexCol = 1.2, #列ラベルのフォントを1.2倍大きく
main = "\n\n\n Factor loadings for brand adjective"
#タイトルを\nで改行しながら表示
)
library(semPlot)## Warning: package 'semPlot' was built under R version 4.5.3semPaths(brand.fa,
what = "est", #推定値(因子負荷量)を表示
residuals = FALSE, #残差(独自性)は非表示
cut = 0.3, #0.3以下の負荷量は薄く表示
posCol = c("white","darkgreen"), #正の負荷量は白から濃い緑のグラデーションで表現
negCol = c("white","red"), #負の負荷量は白から赤のグラデーションで表現
edge.label.cex = 0.75, #数値ラベルのフォントサイズ指定
nCharNodes = 7 #各変数の表示文字数を制限
)
4.各ブランドの因子得点
brand.fa2 <- factanal(prst.sc[,1:9],
factors = 3,
scores = "Bartlett" #Bartlett法で算出
)
brand.score <- data.frame(brand.fa2$scores) #得点を取り出してdfに
brand.score$brand <- prst.sc$Brand #ブランド名を追加
head(brand.score) #先頭表示## Factor1 Factor2 Factor3 brand
## 1 -0.2533476 -0.26787615 1.1022112 Sierra
## 2 0.1653136 -0.44532362 -0.8175906 Romeo
## 3 -0.2232188 1.21523387 -1.7712950 Sierra
## 4 -0.5896332 0.80274750 -2.7424697 Sierra
## 5 0.8532805 -1.20936245 -2.7323045 Sierra
## 6 -0.5192238 0.04341744 -0.8279926 Sierrafa.mean <- aggregate(. ~ brand, data = brand.score, mean) #ブランドごとに平均を算出
rownames(fa.mean) <- fa.mean[, 1] #1列目のブランド名を行名に
fa.mean <- fa.mean[, -1] #１列除いて代入
names(fa.mean) <- c("Friend","Edge","Value") #ラベルをつける
fa.mean## Friend Edge Value
## Papa 0.7175496 -0.8622579 -0.12711879
## Romeo 0.2073764 -0.2006271 -0.02943947
## Sierra -0.3025375 0.3144044 0.02001072
## Tango -0.7420775 0.8851260 0.22597196heatmap.2(as.matrix(fa.mean), #ヒートマップ
col = brewer.pal(9,"GnBu"),
trace = "none",
key = TRUE,
dend = "none",
cexCol = 1.2,
main = "\n\n Mean factor score by brand"
)
因子得点とは、各観測対象が各因子をどれだけ反映しているかを示す値である。因子得点は標準化されていることと、最初の出力は1行が1回答者のブランドに対する評価であることに留意されたい。出力からブランドは親しみやすさ系と革新系に分かれていることが読み取れる。そして、Friend因子とEdge因子はトレードオフの関係にある。つまり、親しみやすいブランドは革新性を評価されず、革新性が高いブランドは親しみにくい。Value因子は中間的な位置にあり、2つの因子と強い結びつきが見られない。そのため、トレードオフを考慮したうえで、コスパに焦点を挙げていくことが有効である。