UAS

UAS Metode Multivariat

Jawaban Soal No 5

library("ggplot2")
library("ggfortify")

## Warning: package 'ggfortify' was built under R version 4.4.2

library("gridExtra")

## Warning: package 'gridExtra' was built under R version 4.4.1

library("carData")
library("car")
library("factoextra")

## Warning: package 'factoextra' was built under R version 4.4.1

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

library("corrplot")

## corrplot 0.92 loaded

library(readr)
decathlon_3 <- read_csv("C:/Users/LENOVO/Downloads/decathlon-3.csv")

## Rows: 41 Columns: 14
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr  (2): Athlets, Competition
## dbl (12): 100m, Long.jump, Shot.put, High.jump, 400m, 110m.hurdle, Discus, P...
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.

View(decathlon_3)

Untuk analisis lebih lanjut, saya akan membuat subset individu aktif (baris 1:40) dan variabel aktif (kolom 1:11) dari set data decathlon3, oleh karena itu saya akan membuat set data baru decathlon3.active untuk melakukan analisis komponen utama.

data(decathlon_3)

## Warning in data(decathlon_3): data set 'decathlon_3' not found

decathlon_3.active <- decathlon_3[1:40, 1:11]
head(decathlon_3.active)

## # A tibble: 6 × 11
##   Athlets `100m` Long.jump Shot.put High.jump `400m` `110m.hurdle` Discus
##   <chr>    <dbl>     <dbl>    <dbl>     <dbl>  <dbl>         <dbl>  <dbl>
## 1 SEBRLE    11.0      7.58     14.8      2.07   49.8          14.7   43.8
## 2 CLAY      10.8      7.4      14.3      1.86   49.4          14.0   50.7
## 3 KARPOV    11.0      7.3      14.8      2.04   48.4          14.1   49.0
## 4 BERNARD   11.0      7.23     14.2      1.92   48.9          15.0   40.9
## 5 YURKOV    11.3      7.09     15.2      2.1    50.4          15.3   46.3
## 6 WARNERS   11.1      7.6      14.3      1.98   48.7          14.2   41.1
## # ℹ 3 more variables: Pole.vault <dbl>, Javeline <dbl>, `1500m` <dbl>

Eksplanatory data

summary(decathlon_3.active)

##    Athlets               100m         Long.jump        Shot.put    
##  Length:40          Min.   :10.44   Min.   :6.610   Min.   :12.68  
##  Class :character   1st Qu.:10.85   1st Qu.:7.060   1st Qu.:13.85  
##  Mode  :character   Median :10.97   Median :7.300   Median :14.53  
##                     Mean   :10.99   Mean   :7.274   Mean   :14.47  
##                     3rd Qu.:11.13   3rd Qu.:7.482   3rd Qu.:15.00  
##                     Max.   :11.64   Max.   :7.960   Max.   :16.36  
##    High.jump          400m        110m.hurdle        Discus     
##  Min.   :1.850   Min.   :46.81   Min.   :13.97   Min.   :37.92  
##  1st Qu.:1.917   1st Qu.:48.90   1st Qu.:14.20   1st Qu.:41.70  
##  Median :1.960   Median :49.38   Median :14.45   Median :44.41  
##  Mean   :1.978   Mean   :49.53   Mean   :14.59   Mean   :44.22  
##  3rd Qu.:2.045   3rd Qu.:50.18   3rd Qu.:14.96   3rd Qu.:45.77  
##  Max.   :2.150   Max.   :51.67   Max.   :15.67   Max.   :51.65  
##    Pole.vault       Javeline         1500m      
##  Min.   :4.200   Min.   :50.31   Min.   :262.1  
##  1st Qu.:4.575   1st Qu.:55.12   1st Qu.:270.7  
##  Median :4.800   Median :58.06   Median :278.0  
##  Mean   :4.771   Mean   :58.31   Mean   :278.6  
##  3rd Qu.:4.940   3rd Qu.:61.00   3rd Qu.:282.8  
##  Max.   :5.400   Max.   :70.52   Max.   :317.0

Menunjukkan performa atlet yang bervariasi dalam berbagai cabang olahraga. Statistik deskriptif membantu memahami distribusi performa untuk setiap cabang, seperti waktu tercepat dan terlambat atau jarak lompatan terpendek dan terpanjang. Rentang antar kuartil (IQR = Q3 - Q1) memberikan wawasan tentang sebaran data, sementara median dan mean menunjukkan nilai tengah dan rata-rata performa atlet.

Metodologi PCA - Visualisasi dan Interpretasi

library(dplyr)

## 
## Attaching package: 'dplyr'

## The following object is masked from 'package:car':
## 
##     recode

## The following object is masked from 'package:gridExtra':
## 
##     combine

## The following objects are masked from 'package:stats':
## 
##     filter, lag

## The following objects are masked from 'package:base':
## 
##     intersect, setdiff, setequal, union

# Periksa struktur data
str(decathlon_3.active)

## tibble [40 × 11] (S3: tbl_df/tbl/data.frame)
##  $ Athlets    : chr [1:40] "SEBRLE" "CLAY" "KARPOV" "BERNARD" ...
##  $ 100m       : num [1:40] 11 10.8 11 11 11.3 ...
##  $ Long.jump  : num [1:40] 7.58 7.4 7.3 7.23 7.09 7.6 7.3 7.31 6.81 7.56 ...
##  $ Shot.put   : num [1:40] 14.8 14.3 14.8 14.2 15.2 ...
##  $ High.jump  : num [1:40] 2.07 1.86 2.04 1.92 2.1 1.98 2.01 2.13 1.95 1.86 ...
##  $ 400m       : num [1:40] 49.8 49.4 48.4 48.9 50.4 ...
##  $ 110m.hurdle: num [1:40] 14.7 14.1 14.1 15 15.3 ...
##  $ Discus     : num [1:40] 43.8 50.7 49 40.9 46.3 ...
##  $ Pole.vault : num [1:40] 5.02 4.92 4.92 5.32 4.72 4.92 4.42 4.42 4.92 4.82 ...
##  $ Javeline   : num [1:40] 63.2 60.1 50.3 62.8 63.4 ...
##  $ 1500m      : num [1:40] 292 302 300 280 276 ...

# Pastikan hanya kolom numerik yang digunakan
decathlon_3.active <- decathlon_3.active %>%
  mutate_if(is.factor, as.numeric) %>%
  mutate_if(is.character, as.numeric) %>%
  select(where(is.numeric))

## Warning: There was 1 warning in `mutate()`.
## ℹ In argument: `Athlets = .Primitive("as.double")(Athlets)`.
## Caused by warning:
## ! NAs introduced by coercion

# Periksa hasil perubahan
str(decathlon_3.active)

## tibble [40 × 11] (S3: tbl_df/tbl/data.frame)
##  $ Athlets    : num [1:40] NA NA NA NA NA NA NA NA NA NA ...
##  $ 100m       : num [1:40] 11 10.8 11 11 11.3 ...
##  $ Long.jump  : num [1:40] 7.58 7.4 7.3 7.23 7.09 7.6 7.3 7.31 6.81 7.56 ...
##  $ Shot.put   : num [1:40] 14.8 14.3 14.8 14.2 15.2 ...
##  $ High.jump  : num [1:40] 2.07 1.86 2.04 1.92 2.1 1.98 2.01 2.13 1.95 1.86 ...
##  $ 400m       : num [1:40] 49.8 49.4 48.4 48.9 50.4 ...
##  $ 110m.hurdle: num [1:40] 14.7 14.1 14.1 15 15.3 ...
##  $ Discus     : num [1:40] 43.8 50.7 49 40.9 46.3 ...
##  $ Pole.vault : num [1:40] 5.02 4.92 4.92 5.32 4.72 4.92 4.42 4.42 4.92 4.82 ...
##  $ Javeline   : num [1:40] 63.2 60.1 50.3 62.8 63.4 ...
##  $ 1500m      : num [1:40] 292 302 300 280 276 ...

# menghapus kolom pertama 
decathlon_3.active <- decathlon_3.active[, -1]

# menjalankan PCA
res.pca <- prcomp(decathlon_3.active, scale = TRUE)
print(res.pca)

## Standard deviations (1, .., p=10):
##  [1] 1.8275374 1.2279496 1.2057137 1.0275844 0.8263005 0.7985897 0.6914141
##  [8] 0.6492426 0.4797529 0.4385443
## 
## Rotation (n x k) = (10 x 10):
##                     PC1         PC2        PC3         PC4         PC5
## 100m        -0.41128012  0.04201309 -0.2405308  0.09772622  0.40974015
## Long.jump    0.38738359 -0.12053650  0.3098075 -0.18133606  0.06010917
## Shot.put     0.37261846  0.33447770 -0.3003039 -0.12309083  0.16810709
## High.jump    0.31623994  0.09560703 -0.3508037  0.18626323  0.51100047
## 400m        -0.35701225  0.44504612 -0.1888084  0.04406545 -0.23199630
## 110m.hurdle -0.39579995  0.12785729 -0.2031302 -0.25437863  0.21591601
## Discus       0.36486642  0.28843592 -0.2009729  0.29438630 -0.01656842
## Pole.vault  -0.01039982  0.35753803  0.4659386 -0.51797215  0.45696722
## Javeline     0.15639896  0.06332042 -0.4426223 -0.65773319 -0.40100118
## 1500m        0.01089779  0.65820824  0.3203196  0.23130031 -0.26226116
##                     PC6        PC7         PC8         PC9        PC10
## 100m        -0.21316916 -0.3364339  0.49769682 -0.02226472  0.43239374
## Long.jump    0.35919423 -0.5854105  0.08870115 -0.45357529  0.13267964
## Shot.put    -0.26595699  0.2835060 -0.30934955 -0.41030393  0.44780703
## High.jump    0.59402099  0.1380332  0.09768763  0.27220800 -0.12813563
## 400m         0.31561393  0.1275902  0.22777504 -0.56262045 -0.31424337
## 110m.hurdle  0.11173996 -0.4162170 -0.68331638  0.07433038 -0.12742110
## Discus      -0.47014098 -0.4333342  0.07001755  0.03474396 -0.49135385
## Pole.vault  -0.17367030  0.1760758  0.19465302  0.07625332 -0.27014258
## Javeline     0.05766052 -0.1182726  0.27277938  0.29420830  0.06261139
## 1500m        0.18795674 -0.1496408 -0.05644795  0.36834795  0.38101319

summary(res.pca)

## Importance of components:
##                          PC1    PC2    PC3    PC4     PC5     PC6     PC7
## Standard deviation     1.828 1.2279 1.2057 1.0276 0.82630 0.79859 0.69141
## Proportion of Variance 0.334 0.1508 0.1454 0.1056 0.06828 0.06377 0.04781
## Cumulative Proportion  0.334 0.4848 0.6301 0.7357 0.80402 0.86779 0.91560
##                            PC8     PC9    PC10
## Standard deviation     0.64924 0.47975 0.43854
## Proportion of Variance 0.04215 0.02302 0.01923
## Cumulative Proportion  0.95775 0.98077 1.00000

eig.val<-get_eigenvalue(res.pca)
eig.val

##        eigenvalue variance.percent cumulative.variance.percent
## Dim.1   3.3398929        33.398929                    33.39893
## Dim.2   1.5078603        15.078603                    48.47753
## Dim.3   1.4537455        14.537455                    63.01499
## Dim.4   1.0559297        10.559297                    73.57428
## Dim.5   0.6827726         6.827726                    80.40201
## Dim.6   0.6377455         6.377455                    86.77947
## Dim.7   0.4780534         4.780534                    91.56000
## Dim.8   0.4215160         4.215160                    95.77516
## Dim.9   0.2301629         2.301629                    98.07679
## Dim.10  0.1923211         1.923211                   100.00000

fviz_eig(res.pca, col.var="blue")

Berdasarkan scree plot yang ditampilkan, dapat disimpulkan bahwa komponen utama pertama hingga ketiga menjelaskan sebagian besar varians dalam data, dengan komponen pertama menyumbang proporsi yang paling signifikan. Setelah komponen ketiga, kontribusi varians yang dijelaskan semakin kecil, menunjukkan bahwa komponen-komponen selanjutnya memiliki peran yang semakin tidak signifikan. Oleh karena itu, dapat dipilih 3 atau 4 komponen utama sebagai komponen yang signifikan, yang sudah cukup untuk menggambarkan sebagian besar informasi dalam data.

Sactter Plot Komponen pertama dan kedua

# Ambil komponen utama pertama dan kedua
pca_data <- as.data.frame(res.pca$x[, 1:2])

# Tambahkan label atau informasi jika ada
pca_data$Athletes <- rownames(pca_data)

# Buat scatter plot
ggplot(pca_data, aes(x = PC1, y = PC2)) +
  geom_point() +
  labs(title = "Scatter Plot of First and Second Principal Components",
       x = "Principal Component 1", y = "Principal Component 2") +
  theme_minimal()

Berdasarkan scatter plot antara komponen utama pertama dan kedua, terlihat bahwa data tidak membentuk kluster yang jelas atau pola pengelompokan tertentu. Titik-titik data tersebar relatif merata di seluruh bidang, tanpa adanya kelompok yang terpisah secara signifikan. Ini menunjukkan bahwa data tidak menunjukkan struktur kluster yang kuat ketika diproyeksikan pada dua komponen utama pertama. Oleh karena itu, data ini mungkin tidak memiliki pola kluster yang jelas berdasarkan dua dimensi tersebut, atau mungkin kluster tersebut hanya bisa terlihat dengan menggunakan lebih banyak komponen utama.

Hasil PCA untuk variabel

var <- get_pca_var(res.pca)
var

## Principal Component Analysis Results for variables
##  ===================================================
##   Name       Description                                    
## 1 "$coord"   "Coordinates for the variables"                
## 2 "$cor"     "Correlations between variables and dimensions"
## 3 "$cos2"    "Cos2 for the variables"                       
## 4 "$contrib" "contributions of the variables"

Cos2 disebut kosinus kuadrat (koordinat kuadrat) dan sesuai dengan kualitas representasi variabel. Cos2 variabel pada semua dimensi menggunakan paket corrplot ditampilkan di bawah, serta diagram batang variabel cos2 menggunakan fungsi fviz_cos2().

head(var$cos2)

##                 Dim.1       Dim.2      Dim.3       Dim.4       Dim.5
## 100m        0.5649473 0.002661524 0.08410658 0.010084566 0.114628636
## Long.jump   0.5012045 0.021907776 0.13953152 0.034721891 0.002466934
## Shot.put    0.4637258 0.168692374 0.13110230 0.015998765 0.019295148
## High.jump   0.3340150 0.013782906 0.17890259 0.036634417 0.178286592
## 400m        0.4256952 0.298655943 0.05182400 0.002050366 0.036748381
## 110m.hurdle 0.5232196 0.024649727 0.05998429 0.068327615 0.031830669
##                   Dim.6       Dim.7       Dim.8        Dim.9      Dim.10
## 100m        0.028979851 0.054109811 0.104410404 0.0001140958 0.035957196
## Long.jump   0.082282242 0.163831530 0.003316443 0.0473515356 0.003385599
## Shot.put    0.045109732 0.038423856 0.040337876 0.0387477647 0.038566377
## High.jump   0.225035486 0.009108429 0.004022473 0.0170544244 0.003157671
## 400m        0.063527206 0.007782353 0.021868869 0.0728561681 0.018991501
## 110m.hurdle 0.007962775 0.082816332 0.196814780 0.0012716512 0.003122552

library("corrplot")
corrplot(var$cos2, is.corr=FALSE)

fviz_cos2(res.pca, choice = "var", axes = 1:2)

fviz_pca_var(res.pca,
             col.var = "cos2", # Color by the quality of representation
             gradient.cols = c("darkorchid4", "gold", "darkorange"),
             repel = TRUE
             )

Kualitas representasi variabel dapat digambar pada peta faktor, di mana nilai cos2 berbeda berdasarkan warna gradien. Variabel dengan nilai cos2 rendah akan diwarnai “darkorchid4”, nilai cos2 sedang - “emas”, nilai co2 tinggi - “darkorange”. Variabel yang berkorelasi positif dikelompokkan bersama, sedangkan variabel yang berkorelasi negatif diposisikan pada sisi berlawanan dari titik asal plot. Jarak antara variabel dan titik asal mengukur kualitas variabel pada peta faktor. Variabel yang jauh dari titik asal terwakili dengan baik pada peta faktor.

# Contributions of variables to PC1
a<-fviz_contrib(res.pca, choice = "var", axes = 1)
# Contributions of variables to PC2
b<-fviz_contrib(res.pca, choice = "var", axes = 2)
grid.arrange(a,b, ncol=2, top='Contribution of the variables to the first two PCs')

Garis putus-putus merah pada grafik di atas menunjukkan kontribusi rata-rata yang diharapkan. Untuk komponen tertentu, variabel dengan kontribusi yang melebihi tolok ukur ini dianggap penting dalam memberikan kontribusi pada komponen tersebut. Dapat dilihat bahwa variabel X100m, 110m.hurde, dan 1500m memberikan kontribusi paling besar pada kedua dimensi.

Hasil PCA untuk individu

ind <- get_pca_ind(res.pca)
ind

## Principal Component Analysis Results for individuals
##  ===================================================
##   Name       Description                       
## 1 "$coord"   "Coordinates for the individuals" 
## 2 "$cos2"    "Cos2 for the individuals"        
## 3 "$contrib" "contributions of the individuals"

fviz_pca_ind(res.pca,
             col.ind = "cos2", # Color by the quality of representation
             gradient.cols = c("darkorchid4", "gold", "darkorange"),
             repel = TRUE
             )

# Total contribution on PC1 and PC2
fviz_contrib(res.pca, choice = "ind", axes = 1:2)

Berdasarkan diagram “Contribution of Individuals to Dim-1-2”, dapat dilihat bahwa sebagian besar individu memiliki kontribusi yang relatif kecil terhadap dua komponen utama pertama (Dim-1-2). Hanya beberapa individu yang memiliki kontribusi besar, dengan nilai kontribusi terbesar lebih dari 10%. Seiring bergeraknya ke individu-individu berikutnya, kontribusinya semakin berkurang, dengan sebagian besar individu menunjukkan kontribusi di bawah 3% yang digambarkan oleh garis merah putus-putus. Ini menunjukkan bahwa sebagian besar data memberikan kontribusi kecil terhadap dua komponen utama pertama, sementara beberapa individu memberikan kontribusi yang lebih besar dalam pembentukan struktur dimensi tersebut. Hal ini juga mengindikasikan bahwa sebagian kecil individu mungkin lebih berpengaruh dalam membentuk varians yang dijelaskan oleh dua komponen utama pertama.

Ringkasan analisis PCA di atas untuk kedua variabel (disiplin olahraga) dan individu (atlet) ditampilkan dalam plot korelasi (plot otomatis) dari paket ggfortify wirg yang merujuk ke dimensi 1 dan 2.

autoplot(res.pca, loadings=TRUE, loadings.colour='darkorchid4', loadings.label=TRUE, loadings.label.size=3)

Final results and analysis

Tujuan dari proyek ini adalah untuk membedakan atlet mana yang memperoleh hasil terbaik di antara seluruh kelompok. Sejauh ini, Analisis Komponen Utama telah dilakukan untuk kedua variabel (disiplin olahraga) dan individu (atlet) dengan menggunakan perhitungan prcomp(), ekstraksi nilai eigen, kosinus kuadrat, dan kontribusi. Dengan mempertimbangkan PC yang dihitung, saya akan meringkasnya dalam kluster melalui metode pengelompokan k-means. Untuk tujuan tersebut, saya akan menggunakan fungsi eclust() dengan 4 kluster sebagai asumsi dan autoplot() untuk pengamatan 2D.

kmeans<-eclust(decathlon_3.active, k=4)

autoplot(res.pca, data=kmeans, colour="cluster")

Kelompok yang paling dekat dengan titik asal (biru) menunjukkan atlet dengan hasil terbaik dalam disiplin olahraga. Kelompok ungu menunjukkan atlet dengan hasil rata-rata, sedangkan kelompok yang tersisa (hijau dan merah) menunjukkan atlet terburuk.

Kesimpulan:

1. Ada 3 komponen utama yang terbentuk.
   
2. Scatter Plot data dalam ruang dua dimensi menggunakan komponen utama pertama dan kedua:

# Ambil komponen utama pertama dan kedua
pca_data <- as.data.frame(res.pca$x[, 1:2])

# Tambahkan label atau informasi jika ada
pca_data$Athletes <- rownames(pca_data)

# Buat scatter plot
ggplot(pca_data, aes(x = PC1, y = PC2)) +
  geom_point() +
  labs(title = "Scatter Plot of First and Second Principal Components",
       x = "Principal Component 1", y = "Principal Component 2") +
  theme_minimal()

Berdasarkan scatter plot antara komponen utama pertama dan kedua, terlihat bahwa data tidak membentuk kluster yang jelas atau pola pengelompokan tertentu. Titik-titik data tersebar relatif merata di seluruh bidang, tanpa adanya kelompok yang terpisah secara signifikan.
c) dari hasil PCA yang diperoleh didapatkan bahwa variabel X100m, 110m.hurdle, dan 1500m memberikan kontribusi paling besar pada kedua dimensi.
d) Komponen utama yang paling berkaitan dengan performa atlit adalah komponen utama pertama dan komponen utama kedua. e) Urutan atlit yang memiliki performa terbaik adalah 1,5,33,40,25,4,31,29,27,22,10,14,15,16 yaitu Sebrle, Bernard, Karpov, Pogorelov, Martineau, Burguignon, Sebrle, Clay, Barras, Averyanov, Pogorelov, Smirnov, Drews, Korkizoglou. Kelompok yang paling dekat dengan titik asal (biru) menunjukkan atlet dengan hasil terbaik dalam disiplin olahraga.