PCA

library(tidyverse)

## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr     1.1.4     ✔ readr     2.1.5
## ✔ forcats   1.0.0     ✔ stringr   1.5.1
## ✔ ggplot2   3.5.1     ✔ tibble    3.2.1
## ✔ lubridate 1.9.3     ✔ tidyr     1.3.1
## ✔ purrr     1.0.2     
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors

library(FactoMineR)
library(factoextra)

## Welcome! Want to learn more? See two factoextra-related books at https://goo.gl/ve3WBa

library(DataExplorer)

Data

pelari <- read.csv("/Users/User/Library/CloudStorage/OneDrive-apps.ipb.ac.id/Kuliah/Data/pelari wanita.csv")
head(pelari)

##   X1OOm X200m X400m X800m X1500m X3000m Marathon   country
## 1 11.61 22.94 54.50  2.15   4.43   9.79   178.52 argentina
## 2 11.20 22.35 51.08  1.98   4.13   9.08   152.37 australia
## 3 11.43 23.09 50.62  1.99   4.22   9.34   159.37   austria
## 4 11.41 23.04 52.00  2.00   4.14   8.88   157.85   belgium
## 5 11.46 23.05 53.30  2.16   4.58   9.81   169.98   bermuda
## 6 11.31 23.17 52.80  2.10   4.49   9.77   168.75    brazil

glimpse(pelari)

## Rows: 55
## Columns: 8
## $ X1OOm    <dbl> 11.61, 11.20, 11.43, 11.41, 11.46, 11.31, 12.14, 11.00, 12.00…
## $ X200m    <dbl> 22.94, 22.35, 23.09, 23.04, 23.05, 23.17, 24.47, 22.25, 24.52…
## $ X400m    <dbl> 54.50, 51.08, 50.62, 52.00, 53.30, 52.80, 55.00, 50.06, 54.90…
## $ X800m    <dbl> 2.15, 1.98, 1.99, 2.00, 2.16, 2.10, 2.18, 2.00, 2.05, 2.08, 2…
## $ X1500m   <dbl> 4.43, 4.13, 4.22, 4.14, 4.58, 4.49, 4.45, 4.06, 4.23, 4.33, 4…
## $ X3000m   <dbl> 9.79, 9.08, 9.34, 8.88, 9.81, 9.77, 9.51, 8.81, 9.37, 9.31, 9…
## $ Marathon <dbl> 178.52, 152.37, 159.37, 157.85, 169.98, 168.75, 191.02, 149.4…
## $ country  <chr> "argentina", "australia", "austria", "belgium", "bermuda", "b…

rownames(pelari) <- pelari$country
head(pelari)

##           X1OOm X200m X400m X800m X1500m X3000m Marathon   country
## argentina 11.61 22.94 54.50  2.15   4.43   9.79   178.52 argentina
## australia 11.20 22.35 51.08  1.98   4.13   9.08   152.37 australia
## austria   11.43 23.09 50.62  1.99   4.22   9.34   159.37   austria
## belgium   11.41 23.04 52.00  2.00   4.14   8.88   157.85   belgium
## bermuda   11.46 23.05 53.30  2.16   4.58   9.81   169.98   bermuda
## brazil    11.31 23.17 52.80  2.10   4.49   9.77   168.75    brazil

Eksplorasi Data

plot_intro(pelari,ggtheme = theme_classic())

plot_density(pelari,geom_density_args = list(fill="steelblue"),
             ggtheme = theme_classic())

plot_correlation(pelari,type = "continuous",
                 cor_args = list(method="spearman"),
             ggtheme = theme_classic())

PCA

pca_pelari_cov <- prcomp(x = pelari |> select(-country),
                       scale. = FALSE) # dengan kovarians

pca_pelari_cor <- prcomp(x = pelari |> select(-country),
                       scale. = TRUE) # dengan korelasi

# mengatur output angka dalam R
options(digits = 4,scipen = 100)
summary(pca_pelari_cov)

## Importance of components:
##                           PC1     PC2     PC3     PC4     PC5     PC6    PC7
## Standard deviation     30.510 2.01264 0.56452 0.33943 0.11954 0.07653 0.0293
## Proportion of Variance  0.995 0.00433 0.00034 0.00012 0.00002 0.00001 0.0000
## Cumulative Proportion   0.995 0.99951 0.99985 0.99998 0.99999 1.00000 1.0000

summary(pca_pelari_cor)

## Importance of components:
##                          PC1    PC2    PC3    PC4     PC5     PC6     PC7
## Standard deviation     2.409 0.8085 0.5476 0.3542 0.23198 0.19761 0.14981
## Proportion of Variance 0.829 0.0934 0.0428 0.0179 0.00769 0.00558 0.00321
## Cumulative Proportion  0.829 0.9228 0.9656 0.9835 0.99122 0.99679 1.00000

Eigenvector

pca_pelari_cov$rotation

##               PC1      PC2      PC3      PC4       PC5        PC6        PC7
## X1OOm    0.010210  0.12042  0.32610 -0.15007 -0.925339  0.0016557  0.0167811
## X200m    0.025063  0.31471  0.87989 -0.01399  0.353756 -0.0252781  0.0123378
## X400m    0.062211  0.93417 -0.32761  0.12178 -0.013367  0.0218349 -0.0253093
## X800m    0.002772  0.02557 -0.03711 -0.04868  0.015164 -0.2618195  0.9627106
## X1500m   0.009578  0.03855 -0.05536 -0.33973  0.034288 -0.8990650 -0.2654165
## X3000m   0.024340  0.08222 -0.08769 -0.91884  0.130442  0.3493052  0.0408423
## Marathon 0.997349 -0.06986 -0.00224  0.02011 -0.002138  0.0000938 -0.0000268

PC1 dimana keragamannya paling besar, kontribusi terbesarnya adalah dari variabel Marathon. Hal ini terjadi karena efek skala angkanya yang terbesar. Perbedaan skala ini yang diterapkan PCA dengan skala kovarians sebetulnya kurang tepat. Karena dalam PC1, hanya Marathon yang dapat menjelaskan keragamannya.

pca_pelari_cor$rotation

##             PC1     PC2      PC3      PC4      PC5       PC6      PC7
## X1OOm    0.3684  0.4901 -0.28601  0.31939  0.23117  0.619825  0.05218
## X200m    0.3654  0.5366 -0.22982 -0.08330  0.04145 -0.710765 -0.10923
## X400m    0.3816  0.2465  0.51537 -0.34738 -0.57218  0.190946  0.20850
## X800m    0.3846 -0.1554  0.58453 -0.04208  0.62032 -0.019089 -0.31521
## X1500m   0.3891 -0.3604  0.01291  0.42954  0.03026 -0.231248  0.69256
## X3000m   0.3889 -0.3475 -0.15273  0.36312 -0.46335  0.009277 -0.59836
## Marathon 0.3670 -0.3692 -0.48437 -0.67250  0.13054  0.142281  0.06960

Eigenvctor dalam PC1 nilainya mirip2 sehingga pengaruh Marathon hampir sama dengan variabel lain.

nilai negatif pada eigenvector menandakan peubah asal memberikan kontribusi yang berkembalikan pada pembentukan komponen utama. Dalam konteks eigenvector negatif, semakin besar nilai peubah asal semakin kecil nilai pada komponen utama.

PC Score

as_tibble(pca_pelari_cov$x) |> 
  glimpse()

## Rows: 55
## Columns: 7
## $ PC1 <dbl> 5.313, -21.020, -14.039, -15.483, -3.276, -4.535, 17.848, -24.008,…
## $ PC2 <dbl> 0.46645, -1.21095, -1.84400, -0.50744, -0.03373, -0.40348, 0.58414…
## $ PC3 <dbl> -1.02895, -0.41762, 0.41537, -0.03944, -0.57925, -0.34530, 0.32064…
## $ PC4 <dbl> -0.10340, -0.21350, -0.44355, 0.14699, -0.47016, -0.46470, 0.35699…
## $ PC5 <dbl> -0.216826, -0.050011, 0.027277, -0.049696, 0.003089, 0.184440, -0.…
## $ PC6 <dbl> 0.04842, 0.05175, 0.03133, -0.02883, -0.11210, -0.04376, -0.10093,…
## $ PC7 <dbl> 0.020491, -0.019444, 0.001359, -0.022406, 0.020563, -0.003295, 0.0…

as_tibble(pca_pelari_cor$x) |> 
  glimpse()

## Rows: 55
## Columns: 7
## $ PC1 <dbl> 0.5273, -2.0936, -1.3804, -1.5100, 0.3878, -0.1184, 1.6820, -2.608…
## $ PC2 <dbl> -0.67472, -0.53280, -0.27500, 0.09096, -0.97641, -0.91152, 0.58619…
## $ PC3 <dbl> 0.61559, -0.04317, -0.53231, -0.08346, 0.64887, 0.32214, 0.07583, …
## $ PC4 <dbl> 0.04553, 0.18738, 0.42624, -0.03942, 0.47446, 0.34097, -0.14512, 0…
## $ PC5 <dbl> -0.002558, -0.218356, -0.025504, -0.030326, 0.204322, -0.095961, 0…
## $ PC6 <dbl> 0.457908, 0.137967, -0.081683, 0.062877, -0.049426, -0.300448, 0.2…
## $ PC7 <dbl> -0.079963, -0.009815, -0.106173, 0.138491, 0.047829, -0.006724, 0.…

Penentuan Banyak k -> Tujuannya bukan untuk visualisasi

Scree Plot

fviz_screeplot(pca_pelari_cov,choice = "eigenvalue",geom="line")

fviz_screeplot(pca_pelari_cor,choice = "eigenvalue",geom="line")

Banyaknya komponen utama bisa ditentukan dengan screeplot dengan melihat di komponen utama yang mana garisnya berbentuk seperti siku (elbow). Pada gambar diatas garis membentuk siku saat berada di komponen utama kedua (dimension kedua). Sehingga banyaknya komponen utama yang digunakan sebanyak dua (Komponen Utama 1 dan Komponen Utama 2)

Cumulative Percentage of Variance

summary(pca_pelari_cov)

## Importance of components:
##                           PC1     PC2     PC3     PC4     PC5     PC6    PC7
## Standard deviation     30.510 2.01264 0.56452 0.33943 0.11954 0.07653 0.0293
## Proportion of Variance  0.995 0.00433 0.00034 0.00012 0.00002 0.00001 0.0000
## Cumulative Proportion   0.995 0.99951 0.99985 0.99998 0.99999 1.00000 1.0000

summary(pca_pelari_cor)

## Importance of components:
##                          PC1    PC2    PC3    PC4     PC5     PC6     PC7
## Standard deviation     2.409 0.8085 0.5476 0.3542 0.23198 0.19761 0.14981
## Proportion of Variance 0.829 0.0934 0.0428 0.0179 0.00769 0.00558 0.00321
## Cumulative Proportion  0.829 0.9228 0.9656 0.9835 0.99122 0.99679 1.00000

Cumulative Percentage of variance menjelaskan seberapa besar keragaman yang dapat dijelaskan oleh komponen utama secara kumulatif. Misalnya saja dengan menggunakan dua komponen utama saja (PC1 dan PC2), sudah bisa menjelaskan sekitar 92% keragaman dari data. Biasanya nilai Cumulative Percentage of variance yang digunakan untuk memilih adalah 80%.

Interpretasi

pca_pelari_cor$rotation[,1:2]

##             PC1     PC2
## X1OOm    0.3684  0.4901
## X200m    0.3654  0.5366
## X400m    0.3816  0.2465
## X800m    0.3846 -0.1554
## X1500m   0.3891 -0.3604
## X3000m   0.3889 -0.3475
## Marathon 0.3670 -0.3692

PC1 memiliki eigenvector yang relatif sama yaitu berkisar di 0.3 untuk semua cabang lomba. eigenvector yang relatif sama ini menandakan bahwa kontribusi peubah asal untuk membangun komponen utama ini relatif sama. Artinya nilai-nilai yang ada di PC1 (score value) dapat menggambarkan waktu lari untuk semua cabang lomba. Oleh karena itu kita dapat dapat menggunakan PC1 untuk menentukan negara mana yang memiliki pelari tercepat untuk semua kategori lomba.

PC2 memiliki nilai positif untuk cabang lari jarak dekat (100m -400m) dan nilai negatif untuk cabang lari jarak jauh(800m-marathon). Hal ini berarti semakin besar score value pada PC2 maka waktu lari cabang jarak dekat semakin lambat namun waktu lari untuk cabang jarak jauh semakin cepat. Oleh karena itu, PC2 dapat digunakan untuk menentukan negara mana yang pada cabang lari jarak dekat waktunya mirip seperti cabang lari jarak jauh.

Note: Besaran eigenvector adalah besaran koefisien, yang menentukan seberapa besar kontribusi dalam menentukan PC yg baru. tanda negatif menunjukkan pengaruhnya berkebalikan.

fviz_pca_ind(X = pca_pelari_cor,repel = TRUE)

Berdasarkan grafik score value dapat diketahui bahwa negara yang memiliki catatan waktu pelari terlambat untuk semua cabang lomba adalah negara wsamoa. Hal ini dikarenakan wsamoa score value wsakoa untuk PC1 (Dim1) paling besar diantara yang lain. Walaupun negara wsamoa memiliki cabang lari terlama disemua cabang lomba, namun perbedaan waktu terkecil antara pelari jarak jauh dan jarak dekat adalah negara wsamoa (PC2 [Dim2]). Hal ini berarti pelari untuk lomba jarak dekat sangat lambat karena memiliki waktu yang hampir mirip seperti pelari jarak jauh. Sedangkan negara yang memiliki pelari tercepat untuk semua cabang lomba adalah gdr.

Interpretasi cookis: Koefisien + : dia terlambat (100-400m) Koefisien - : dia tercepat (Marathon, 800-3000m)

PCA for Image

library(jpeg)

kucing <- readJPEG("/Users/User/Library/CloudStorage/OneDrive-apps.ipb.ac.id/Kuliah/Data/kucing.jpeg")

dim(kucing)

## [1] 2657 1771    3

r <- kucing[,,1]
g <- kucing[,,2]
b <- kucing[,,3]

cat.r.pca <- prcomp(r, center = FALSE)
cat.g.pca <- prcomp(g, center = FALSE)
cat.b.pca <- prcomp(b, center = FALSE)
rgb.pca <- list(cat.r.pca, cat.g.pca, cat.b.pca)

pca_image <- function(j,comp) {
 compressed.img <- j$x[,1:comp] %*% t(j$rotation[,1:comp])}

res3 <- sapply(rgb.pca,pca_image,comp=3,
            simplify = "array" )
res46 <- sapply(rgb.pca,pca_image,comp=46,
            simplify = "array" )
res128 <- sapply(rgb.pca,pca_image,comp=128,
            simplify = "array" )
res256 <- sapply(rgb.pca,pca_image,comp=256,
            simplify = "array" )
res512 <- sapply(rgb.pca,pca_image,comp=512,
            simplify = "array" )

writeJPEG(res3,"/Users/User/Library/CloudStorage/OneDrive-apps.ipb.ac.id/Kuliah/Data/res3.jpg")

writeJPEG(res256,"/Users/User/Library/CloudStorage/OneDrive-apps.ipb.ac.id/Kuliah/Data/res256.jpg")

writeJPEG(res512,"/Users/User/Library/CloudStorage/OneDrive-apps.ipb.ac.id/Kuliah/Data/res512.jpg")