Panggil Package

Pertama panggil package yang dibutuhkan dengan sintaks berikut:

library(caret)

## Loading required package: lattice

## Loading required package: ggplot2

library(corrplot)

## corrplot 0.84 loaded

library(imager)

## Loading required package: magrittr

## 
## Attaching package: 'imager'

## The following object is masked from 'package:magrittr':
## 
##     add

## The following objects are masked from 'package:stats':
## 
##     convolve, spectrum

## The following object is masked from 'package:graphics':
## 
##     frame

## The following object is masked from 'package:base':
## 
##     save.image

library(rgl)

## Warning in rgl.init(initValue, onlyNULL): RGL: unable to open X11 display

## Warning: 'rgl.init' failed, running with 'rgl.useNULL = TRUE'.

library(factoextra)

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

library(plotly)

## 
## Attaching package: 'plotly'

## The following object is masked from 'package:imager':
## 
##     highlight

## The following object is masked from 'package:ggplot2':
## 
##     last_plot

## The following object is masked from 'package:stats':
## 
##     filter

## The following object is masked from 'package:graphics':
## 
##     layout

library(DataExplorer)

Load Data

Lalu, load data yang dibutuhkan dan lakukan praproses serta eksplorasi data. decathlon2 adalah data penampilan atlet selama dua pertemuan olahraga. Praproses yang dilakukan berupa mengambil subset data yaitu kolom 1 sampai 10 karena kolom rank, points dan competition tidak diperlukan dalam hal ini.

data("decathlon2")
df <- decathlon2[, 1:10]

Eksplorasi Data

plot_correlation(df)

plot_histogram(df)

Berdasarkan plot korelasi, terlihat adanya korelasi negatif antara lompatan panjang (long,jump) dan x100m. Selain itu, terdapat korelasi yang positif antara rintangan x110m (x110m hurdle) dan x100m. Berdasarkan plot histogram, tidak didapati adanya sebaran data dari peubah yang miring atau menjulur ke kiri maupun ke kanan.

Menerapkan Principal Component Analysis

Principal Component Analysis (PCA) yaitu mentransfer satu himpunan peubah yang berkorelasi ke dalam himpunan peubah tak berkorelasi baru. Pada tahap ini akan dicobakan fungsi PCA dari package FactoMineR.

library("FactoMineR")
set.seed(2)
res.pca <- PCA(df,  graph = FALSE)

Visualisasi Akar Ciri

eigen=get_eig(res.pca)
fviz_screeplot(res.pca, addlabels = TRUE, ylim = c(0, 50))

Penentuan Banyaknya Komponen Utama

Perbandingan <- data.frame("Lambda"=round(eigen[,1],4),
  "Pctn"=round(eigen[,2],3),
  "CumPctn"=(round(eigen[,3],4)))
Perbandingan

Komponen utama pertama dapat menjelaskan 37.5% dari total keragaman data sementara komponen utama kedua dapat menjelaskan sekitar 17%% dari total keragaman data sedangkan komponen utama kedua dapat menjelaskan sekitar 15% dari total keragaman data, sehingga jika menggunakan ketiga komponen utama maka total keragaman yang dapat dijelaskan adalah 70.1297% dari total keragaman data. Oleh karena itu, dipilih komponen utama sebanyak 3 karena kumulatif proporsi keragaman total yang mampu dijelaskan sudah lebih dari 70%

K-Means Clustering

set.seed(2)
iris2 <- iris
iris2$Species <- NULL
(kmeans.result <- kmeans(iris2, 5))

## K-means clustering with 5 clusters of sizes 45, 28, 27, 22, 28
## 
## Cluster means:
##   Sepal.Length Sepal.Width Petal.Length Petal.Width
## 1     6.264444    2.884444     4.886667   1.6666667
## 2     5.242857    3.667857     1.500000   0.2821429
## 3     7.014815    3.096296     5.918519   2.1555556
## 4     4.704545    3.122727     1.413636   0.2000000
## 5     5.532143    2.635714     3.960714   1.2285714
## 
## Clustering vector:
##   [1] 2 4 4 4 2 2 4 2 4 4 2 4 4 4 2 2 2 2 2 2 2 2 4 2 4 4 2 2 2 4 4 2 2 2 4 4 2
##  [38] 2 4 2 2 4 4 2 2 4 2 4 2 4 1 1 1 5 1 5 1 5 1 5 5 5 5 1 5 1 5 5 1 5 1 5 1 1
##  [75] 1 1 1 1 1 5 5 5 5 1 5 1 1 1 5 5 5 1 5 5 5 5 5 1 5 5 3 1 3 1 3 3 5 3 3 3 1
## [112] 1 3 1 1 1 1 3 3 1 3 1 3 1 3 3 1 1 3 3 3 3 3 1 1 3 3 1 1 3 3 3 1 3 3 3 1 1
## [149] 1 1
## 
## Within cluster sum of squares by cluster:
## [1] 17.014222  4.630714 15.351111  3.114091  9.749286
##  (between_SS / total_SS =  92.7 %)
## 
## Available components:
## 
## [1] "cluster"      "centers"      "totss"        "withinss"     "tot.withinss"
## [6] "betweenss"    "size"         "iter"         "ifault"

Output diatas menunjukan banyaknya data pada cluster 1 adalah sebanyak 28, clluster 2 sebanyak 27 data, cluster 3 sebanyak 28 data, cluster 4 sebanyak 22 data, cluster 5 sebanyak 45 data. Pada cluster 1 rata-rata sepal length adalah 5.242857, sepal width adalah 3.667857 dan seterusnya.

table(iris$Species, kmeans.result$cluster)

##             
##               1  2  3  4  5
##   setosa      0 28  0 22  0
##   versicolor 23  0  0  0 27
##   virginica  22  0 27  0  1

Output diatas menunjukan bahwa cluster 1 terdiri dari 28 jenis species sentosa, cluster 2 27 jenis species virginica dan seterusnya

plot(iris2[c("Sepal.Length", "Sepal.Width")], col = kmeans.result$cluster)
points(kmeans.result$centers[,c("Sepal.Length", "Sepal.Width")], col = 1:3,pch = 8, cex=2)

Plot tersebut merupakan sebaran cluster berdasarkan nilai atribut Sepal Length dan Sepal Width, pada gambar tersebut tanda bintang menunjukkan pusat cluster untuk setiap kelas.

Visualisasi menggunakan fviz_cluster

library(cluster)
fviz_cluster(kmeans.result,iris2)

K-Medoids Clustering

Algoritma k-medoids hampir sama dengan algoritma k-means, di mana keduanya sama- sama mempartisi data yang ada ke dalam bentuk dua atau lebih kelompok berdasarkan pendekatan partisi. Perbedaanya adalah jika pada k-means cluster diwakili dengan pusat dari cluster, sedangkan pada k-medoids, cluster diwakili oleh objek terdekat dari pusat cluster.

Melakukan pengklasteran dengan menggunakan fungsi pamk()

library(fpc)
set.seed(2)
pamk.result <- pamk(iris2)

Menampilkan jumlah cluster yang terbentuk

pamk.result$nc

## [1] 2

table(pamk.result$pamobject$clustering, iris$Species)

##    
##     setosa versicolor virginica
##   1     50          1         0
##   2      0         49        50

Dari hasil algoritma pamk() diperoleh 2 klaster: 1) Kluster 1 adalah teridiri atas beberapa jenis “setosa” dan satu “versicolor” 2) Kluster 2 terdiri atas banyak “ versicolor" ditambah banayk dari “ virginica ".

Melihat plot dari hasil pamk.result

layout(matrix(c(1,2),1,2)) # 2 graphs per page
plot(pamk.result$pamobject)

layout(matrix(1)) # change back to one graph per page

Gambar sebelah kiri adalah clusplot 2-dimensi (clustering plot) dari dua kelompok dan garis menunjukkan jarak antara cluster. Gambar sebelah kanan menunjukkan silhouettes. Dalam silhouettes, nilai Si yang besar (hampir 1) menunjukkan bahwa pengamatan yang sesuai terkelompok sangat baik, nilai Si yang mendekati 0 berarti pengamatan terletak di antara dua kelompok, dan pengamatan dengan Si negatif mungkin ditempatkan di cluster yang salah. Karena Si rata-rata adalah masing- masing 0,81 dan 0,62 di silhouettes di atas, mengidentifikasikan bahwa dua kelompok ini baik.

Hierarchical Clustering

Hierarchical Clustering adalah algoritma clustering yang mengelompokkan data dengan membuat suatu hirarki berupa dendogram dimana data yang mirip akan ditempatkan pada hirarki yang berdekatan dan yang tidak pada hirarki yang berjauhan.

Ambil 40 data dari dataset iris, simpan pada irisSample dan hapus variabel Species

set.seed(2)
idx <- sample(1:dim(iris)[1], 50)
irisSample <- iris[idx,]
irisSample$Species <- NULL

Melakukan pengklasteran hierarchical clustering dengan menggunakan metode complete linked dan simpan hasilnya pada hc

hc <- hclust(dist(irisSample), method="complete")

Hasil clustering plot dengan pelabelan berdasarkan atribut Species pada data iris

plot(hc, hang = -1, labels=iris$Species[idx])

Panggil Package

Pertama panggil package yang dibutuhkan dengan sintaks berikut:

library(tidyverse)

## ── Attaching packages ─────────────────────────────────────── tidyverse 1.3.0 ──

## ✓ tibble  3.1.0     ✓ dplyr   1.0.5
## ✓ tidyr   1.1.3     ✓ stringr 1.4.0
## ✓ readr   1.4.0     ✓ forcats 0.5.0
## ✓ purrr   0.3.4

## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## x imager::add()       masks magrittr::add()
## x stringr::boundary() masks imager::boundary()
## x tidyr::extract()    masks magrittr::extract()
## x tidyr::fill()       masks imager::fill()
## x dplyr::filter()     masks plotly::filter(), stats::filter()
## x dplyr::lag()        masks stats::lag()
## x purrr::lift()       masks caret::lift()
## x purrr::set_names()  masks magrittr::set_names()

library(arules)

## Loading required package: Matrix

## 
## Attaching package: 'Matrix'

## The following objects are masked from 'package:tidyr':
## 
##     expand, pack, unpack

## 
## Attaching package: 'arules'

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

## The following objects are masked from 'package:base':
## 
##     abbreviate, write

library(arulesViz)
library(igraph)

## 
## Attaching package: 'igraph'

## The following object is masked from 'package:arules':
## 
##     union

## The following objects are masked from 'package:dplyr':
## 
##     as_data_frame, groups, union

## The following objects are masked from 'package:purrr':
## 
##     compose, simplify

## The following object is masked from 'package:tidyr':
## 
##     crossing

## The following object is masked from 'package:tibble':
## 
##     as_data_frame

## The following object is masked from 'package:plotly':
## 
##     groups

## The following object is masked from 'package:imager':
## 
##     spectrum

## The following objects are masked from 'package:stats':
## 
##     decompose, spectrum

## The following object is masked from 'package:base':
## 
##     union

Selanjutnya, load data yang dibutuhkan dan lakukan praproses data.

Titanic dataset (dataset bawaan R) merupakan data yang terdiri dari 4 dimensi dengan informasi penumpang di kapal Titanic menurut Class, Sex, Age, dan Survived. Data ini sudah berbentuk ringkasan berupa frekuensi atau banyak penumpang berdasarkan karakteristiknya, sehingga perlu dilakukan praproses untuk melakukan association rule mining. Praproses yang dilakukan adalah membentuk informasi pada setiap baris menjadi mewakili satu orang.

Panggil Data

str(Titanic)

##  'table' num [1:4, 1:2, 1:2, 1:2] 0 0 35 0 0 0 17 0 118 154 ...
##  - attr(*, "dimnames")=List of 4
##   ..$ Class   : chr [1:4] "1st" "2nd" "3rd" "Crew"
##   ..$ Sex     : chr [1:2] "Male" "Female"
##   ..$ Age     : chr [1:2] "Child" "Adult"
##   ..$ Survived: chr [1:2] "No" "Yes"

# Ubah data menjadi data.frame
df <- as.data.frame(Titanic) 
# Lihat 6 baris pertama 
head(df)

# Lihat banyaknya seluruh penumpang
print(paste('Banyaknya seluruh penumpang adalah', sum(df$Freq), 'org.'))

## [1] "Banyaknya seluruh penumpang adalah 2201 org."

Praproses Data

# Ubah data hasil tabulasi menjadi per penumpang ## Ambil kolom selain "Freq"
cols <- colnames(df)[! colnames(df) %in% "Freq"] 
titanic <- sapply(cols,
function(col) {## Replikasi masing-masing nilai sebanyak "Freq" 
  rep(df[, col], df$Freq)
})
# Ubah matrix data menjadi data.frame
titanic <- as.data.frame(titanic) # Ringkasan statistik
summary(titanic)

##     Class               Sex                Age              Survived        
##  Length:2201        Length:2201        Length:2201        Length:2201       
##  Class :character   Class :character   Class :character   Class :character  
##  Mode  :character   Mode  :character   Mode  :character   Mode  :character

Penerapan Algoritme Apriori

# Muat pustaka
# install.packages('arules') 
library(arules)
# Terapkan algoritme
rules <- apriori(titanic)

## Warning: Column(s) 1, 2, 3, 4 not logical or factor. Applying default
## discretization (see '? discretizeDF').

## Apriori
## 
## Parameter specification:
##  confidence minval smax arem  aval originalSupport maxtime support minlen
##         0.8    0.1    1 none FALSE            TRUE       5     0.1      1
##  maxlen target  ext
##      10  rules TRUE
## 
## Algorithmic control:
##  filter tree heap memopt load sort verbose
##     0.1 TRUE TRUE  FALSE TRUE    2    TRUE
## 
## Absolute minimum support count: 220 
## 
## set item appearances ...[0 item(s)] done [0.00s].
## set transactions ...[10 item(s), 2201 transaction(s)] done [0.00s].
## sorting and recoding items ... [9 item(s)] done [0.00s].
## creating transaction tree ... done [0.00s].
## checking subsets of size 1 2 3 4 done [0.00s].
## writing ... [27 rule(s)] done [0.00s].
## creating S4 object  ... done [0.00s].

Output diatas menunjukan Absolute minimum support countadalah sebesar 220 dan jumlah aturan yang terbentuk adalah sebanyak 27. Minimum support bawaan 0.1.

Menampilkan hasil rules yang terbentuk secara terurut

# Urutkan rules berdasarkan "lift"
rules <- sort(rules, by="lift")
# Lihat 10 rules terbaik yang terbentuk
inspect(rules[1:10])

##      lhs                                   rhs           support   confidence
## [1]  {Class=Crew,Survived=No}           => {Sex=Male}    0.3044071 0.9955423 
## [2]  {Class=Crew,Age=Adult,Survived=No} => {Sex=Male}    0.3044071 0.9955423 
## [3]  {Class=Crew}                       => {Sex=Male}    0.3916402 0.9740113 
## [4]  {Class=Crew,Age=Adult}             => {Sex=Male}    0.3916402 0.9740113 
## [5]  {Class=3rd,Sex=Male,Age=Adult}     => {Survived=No} 0.1758292 0.8376623 
## [6]  {Class=3rd,Sex=Male}               => {Survived=No} 0.1917310 0.8274510 
## [7]  {Age=Adult,Survived=No}            => {Sex=Male}    0.6038164 0.9242003 
## [8]  {Survived=No}                      => {Sex=Male}    0.6197183 0.9154362 
## [9]  {Class=Crew}                       => {Age=Adult}   0.4020900 1.0000000 
## [10] {Class=Crew,Survived=No}           => {Age=Adult}   0.3057701 1.0000000 
##      coverage  lift     count
## [1]  0.3057701 1.265851  670 
## [2]  0.3057701 1.265851  670 
## [3]  0.4020900 1.238474  862 
## [4]  0.4020900 1.238474  862 
## [5]  0.2099046 1.237379  387 
## [6]  0.2317129 1.222295  422 
## [7]  0.6533394 1.175139 1329 
## [8]  0.6769650 1.163995 1364 
## [9]  0.4020900 1.052103  885 
## [10] 0.3057701 1.052103  673

Output diatas menunjukan 10 aturan terbaik berdasarkan nilai lift. Lift Ratio lebih besar dari 1.0 menunjukkan bahwa ada beberapa kegunaan aturan tersebut.Semakin besar lift ratio, semakin besar kekuatan asosiasi.

Mengatur parameter yang digunakan pada algoritme Apriori

# Parameter yang akan diterapkan
params = list(minlen = 2, support = 0.005,
confidence = 0.8) # Terapkan algoritme
rules <- apriori(titanic, parameter = params)

## Warning: Column(s) 1, 2, 3, 4 not logical or factor. Applying default
## discretization (see '? discretizeDF').

## Apriori
## 
## Parameter specification:
##  confidence minval smax arem  aval originalSupport maxtime support minlen
##         0.8    0.1    1 none FALSE            TRUE       5   0.005      2
##  maxlen target  ext
##      10  rules TRUE
## 
## Algorithmic control:
##  filter tree heap memopt load sort verbose
##     0.1 TRUE TRUE  FALSE TRUE    2    TRUE
## 
## Absolute minimum support count: 11 
## 
## set item appearances ...[0 item(s)] done [0.00s].
## set transactions ...[10 item(s), 2201 transaction(s)] done [0.00s].
## sorting and recoding items ... [10 item(s)] done [0.00s].
## creating transaction tree ... done [0.00s].
## checking subsets of size 1 2 3 4 done [0.00s].
## writing ... [71 rule(s)] done [0.00s].
## creating S4 object  ... done [0.00s].

Total rules yang terbentuk lebih banyak (71 rules) dibandingkan sebelumnya (27 rules) karena minimum support diatur lebih rendah, yaitu 0.005 dibandingkan dengan minimum support bawaan 0.1. Fungsi apriori di R dapat menyaring rules yang digunakan pada sisi kiri (𝑋) dan/atau sisi kanan (𝑌). Misalkan hal yang ingin diamati adalah rules dengan 𝑌 menjelaskan keselamatan penumpang.

Aturan yang Menjelaskan Keselamatan Penumpang

# Terapkan algoritme dengan sisi kanan hanya terdiri dari atribut "Survived=No"
rules <- apriori(titanic,
parameter = params,
appearance = list(rhs = c('Survived=No'), default = 'lhs'))

## Warning: Column(s) 1, 2, 3, 4 not logical or factor. Applying default
## discretization (see '? discretizeDF').

## Apriori
## 
## Parameter specification:
##  confidence minval smax arem  aval originalSupport maxtime support minlen
##         0.8    0.1    1 none FALSE            TRUE       5   0.005      2
##  maxlen target  ext
##      10  rules TRUE
## 
## Algorithmic control:
##  filter tree heap memopt load sort verbose
##     0.1 TRUE TRUE  FALSE TRUE    2    TRUE
## 
## Absolute minimum support count: 11 
## 
## set item appearances ...[1 item(s)] done [0.00s].
## set transactions ...[10 item(s), 2201 transaction(s)] done [0.00s].
## sorting and recoding items ... [10 item(s)] done [0.00s].
## creating transaction tree ... done [0.00s].
## checking subsets of size 1 2 3 4 done [0.00s].
## writing ... [4 rule(s)] done [0.00s].
## creating S4 object  ... done [0.00s].

Output diatas menunjukan terdapat 4 aturan yang terbentuk

# Urutkan rules berdasarkan "lift"
rules <- sort(rules, by='lift') 
# Lihat rules yang terbentuk 
inspect(rules)

##     lhs                               rhs           support   confidence
## [1] {Class=2nd,Sex=Male,Age=Adult} => {Survived=No} 0.0699682 0.9166667 
## [2] {Class=2nd,Sex=Male}           => {Survived=No} 0.0699682 0.8603352 
## [3] {Class=3rd,Sex=Male,Age=Adult} => {Survived=No} 0.1758292 0.8376623 
## [4] {Class=3rd,Sex=Male}           => {Survived=No} 0.1917310 0.8274510 
##     coverage   lift     count
## [1] 0.07632894 1.354083 154  
## [2] 0.08132667 1.270871 154  
## [3] 0.20990459 1.237379 387  
## [4] 0.23171286 1.222295 422

Hasil di atas menunjukkan terdapat 4 rules yang bersifat redundan atau rules yang merupakan subset dari rules lainnya. Contohnya terdapat pada rules pertama dan kedua. Pada rules kedua merupakan subset dari rules pertama, yaitu penumpang laki-laki dengan kelas sosial kedua. Begitu juga terjadi pada rules ketiga dan keempat. Untuk menyaring rules yang bersifat redundan tersebut, lakukan langkah berikut.

Menghilangkan Aturan yang Redundan

# Membentuk matriks hubungan subset
subset_matrix <- is.subset(rules, rules) 
subset_matrix[upper.tri(subset_matrix)] <- FALSE
# Menentukan rules yang redundan
redundant <- colSums(subset_matrix) > 1
# Untuk melihat rules yang redundan: > which(redundant)
# Ambil rules yang tidak redundan
rules_pruned <- rules[!redundant]
inspect(rules_pruned)

##     lhs                     rhs           support   confidence coverage  
## [1] {Class=2nd,Sex=Male} => {Survived=No} 0.0699682 0.8603352  0.08132667
## [2] {Class=3rd,Sex=Male} => {Survived=No} 0.1917310 0.8274510  0.23171286
##     lift     count
## [1] 1.270871 154  
## [2] 1.222295 422

Visualisasi Rules yang Terbentuk

# Muat pustaka
# install.packages('arulesViz') 
library(arulesViz)
plot(rules_pruned)

plot(rules_pruned, method='grouped')

plot(rules_pruned, method='graph')

plot(rules_pruned, method='graph', control=list(type='items'))

## Warning: Unknown control parameters: type

## Available control parameters (with default values):
## layout    =  list(fun = function (graph, dim = 2, ...)  {     if ("layout" %in% graph_attr_names(graph)) {         lay <- graph_attr(graph, "layout")         if (is.function(lay)) {             lay(graph, ...)         }         else {             lay         }     }     else if (all(c("x", "y") %in% vertex_attr_names(graph))) {         if ("z" %in% vertex_attr_names(graph)) {             cbind(V(graph)$x, V(graph)$y, V(graph)$z)         }         else {             cbind(V(graph)$x, V(graph)$y)         }     }     else if (vcount(graph) < 1000) {         layout_with_fr(graph, dim = dim, ...)     }     else {         layout_with_drl(graph, dim = dim, ...)     } }, call_str = c("layout_nicely(<graph>, input = \"/Users/azzahraamonra/LAPORAN STA582 ke 4.Rmd\", ", "    encoding = \"UTF-8\")"), args = list())
## edges     =  <environment>
## nodes     =  <environment>
## nodetext  =  <environment>
## colors    =  c("#EE0000FF", "#EEEEEEFF")
## engine    =  ggplot2
## max   =  100
## verbose   =  FALSE

Berdasarkan dari rules yang terbentuk, terlihat karakteristik penumpang yang berasosiasi kuat dengan tidak selamat dari kecelakaan kapal Titanic. Karakteristik penumpang tersebut adalah penumpang laki-laki dengan kelas sosial kedua atau kelas sosial ketiga.