1D Convolutional Neural Network for Multi-Class Classification Problem
Dear Machine Learning, help me invest my money in kickstarter.
Devin Jevian
12/23/2020
library(vroom) # fast read data
library(dplyr) # data wrangling
library(magrittr) # piping operator
library(ggplot2) # data visualization
library(ggcorrplot) # correlation plot
library(hrbrthemes) # visualization theme
library(glue) # glue string and variable
library(tidymodels) # tidy modeling framework
library(keras) # machine learning framework
library(caret) # classification evaluation
use_condaenv(condaenv = "r-reticulate") # condaenv dengan tensorflow
# set random seed untuk R dan tensorflow
set.seed(seed = 777)
tensorflow::tf$random$set_seed(777)
# set theme plot
theme_set(theme_modern_rc())1 Background
Kickstarter merupakan platform investasi crowdfunding yang menghubungkan suatu project dengan pendanaan yang berasal dari masyarakat luar. Terima kasih untuk Mickaël Mouillé yang telah menyediakan dataset ini di kaggle. Artikel kali ini akan membahas mengenai penerapan metode klasifikasi dengan Convolutional neural networks 1 dimensi untuk memprediksi project kickstarter yang akan sukses dijalankan ataupun tidak.
2 Preliminary Inspection
df <- vroom("ks-projects-201801.csv")
str(df) # inspect dataframe structure## tibble [378,661 x 15] (S3: tbl_df/tbl/data.frame)
## $ ID : num [1:378661] 1000002330 1000003930 1000004038 1000007540 1000011046 ...
## $ name : chr [1:378661] "The Songs of Adelaide & Abullah" "Greeting From Earth: ZGAC Arts Capsule For ET" "Where is Hank?" "ToshiCapital Rekordz Needs Help to Complete Album" ...
## $ category : chr [1:378661] "Poetry" "Narrative Film" "Narrative Film" "Music" ...
## $ main_category : chr [1:378661] "Publishing" "Film & Video" "Film & Video" "Music" ...
## $ currency : chr [1:378661] "GBP" "USD" "USD" "USD" ...
## $ deadline : Date[1:378661], format: "2015-10-09" "2017-11-01" ...
## $ goal : num [1:378661] 1000 30000 45000 5000 19500 50000 1000 25000 125000 65000 ...
## $ launched : POSIXct[1:378661], format: "2015-08-11 12:12:28" "2017-09-02 04:43:57" ...
## $ pledged : num [1:378661] 0 2421 220 1 1283 ...
## $ state : chr [1:378661] "failed" "failed" "failed" "failed" ...
## $ backers : num [1:378661] 0 15 3 1 14 224 16 40 58 43 ...
## $ country : chr [1:378661] "GB" "US" "US" "US" ...
## $ usd pledged : num [1:378661] 0 100 220 1 1283 ...
## $ usd_pledged_real: num [1:378661] 0 2421 220 1 1283 ...
## $ usd_goal_real : num [1:378661] 1534 30000 45000 5000 19500 ...
## - attr(*, "spec")=
## .. cols(
## .. ID = col_double(),
## .. name = col_character(),
## .. category = col_character(),
## .. main_category = col_character(),
## .. currency = col_character(),
## .. deadline = col_date(format = ""),
## .. goal = col_double(),
## .. launched = col_datetime(format = ""),
## .. pledged = col_double(),
## .. state = col_character(),
## .. backers = col_double(),
## .. country = col_character(),
## .. `usd pledged` = col_double(),
## .. usd_pledged_real = col_double(),
## .. usd_goal_real = col_double(),
## .. .delim = ","
## .. )Seluruh kolom yang ada dalam dataset ini sudah bersifat self-explanatory atau nama variabel sudah cukup menjelaskan isi observasi yang bersangkutan. Untuk mengawali inspeksi kita akan mengubah tipe data menjadi factor
df %<>%
mutate(category = as.factor(category),
main_category = as.factor(main_category),
currency = as.factor(currency),
state = as.factor(state),
country = as.factor(country))Setelah membenarkan tipe data, kita akan melanjutkan eksplorasi data dengan mengecek jumlah unique value dalam setiap variabel factor kita.
print("Unique value counts")## [1] "Unique value counts"glue("main category: {length(unique(df$main_category))}")## main category: 15glue("category: {length(unique(df$category))}")## category: 159glue("state: {length(unique(df$state))}")## state: 6glue("currency: {length(unique(df$currency))}")## currency: 14glue("country: {length(unique(df$country))}")## country: 23Kolom state merupakan variabel target dalam klasifikasi kita, oleh karena itu kita akan melakukan penyelidikan lebih lanjut terhadap kolom tersebut.
round(sort(prop.table(table(df$state)), decreasing = T), 2)##
## failed successful canceled undefined live suspended
## 0.52 0.35 0.10 0.01 0.01 0.00Terdapat ketimpangan populasi dalam variabel state dimana undefined, live, dan suspended hanya berkisar di angka 1% dari data yang kita miliki.
colSums(is.na(df))## ID name category main_category
## 0 4 0 0
## currency deadline goal launched
## 0 0 0 0
## pledged state backers country
## 0 0 0 0
## usd pledged usd_pledged_real usd_goal_real
## 3797 0 0Kolom usd pledged memiliki jumlah NA terbanyak dan merupakan hasil konversi kolom pledged yang dilakukan oleh kickstarter oleh karena itu kita akan meghilangkan kolom usd_pledged dan goal karena kita sudah memiliki kolom usd_pledged_real dan usd_goal_real yang merupakan hasil dari konversi mata uang asing kedalam satuan USD oleh Fixer.io API.
df %<>%
select(-c("usd pledged", "goal"))Kita dapat membuat kolom rasio perbandingan antara dana yang diminta dan dana yang didapatkan melalui kolom usd_pledged_real dan usd_goal_real dan kita akan memberi nama kolom tersebut pledged_goal_ratio.
df %<>%
mutate(pledged_goal_ratio = usd_pledged_real/usd_goal_real)Selanjutnya kita akan menganalisa berapa banyak dana yang diberikan oleh setiap backers, karena itu kita akan membuat variabel baru yang bernama pledged_backers_ratio.
df %<>%
mutate(pledged_backers_ratio = usd_pledged_real/backers)Pembuatan pledged_goal_ratio dan pledged_backers_ratio akan menghasilkan kolom NA karena beberapa observasi memiliki usd_pledged_real dengan nilai 0 dan pembagian dengan 0 sebagai pembilang akan menghasilkan NA ataupun NaN, oleh karena itu kita akan mengubah NA dan NaN yang terdapat pada kedua kolom tersebut menjadi 0.
df$pledged_goal_ratio[is.na(df$pledged_goal_ratio)] <- 0
df$pledged_goal_ratio[is.infinite(df$pledged_goal_ratio)] <- 0
df$pledged_backers_ratio[is.na(df$pledged_backers_ratio)] <- 0
df$pledged_backers_ratio[is.infinite(df$pledged_backers_ratio)] <- 0colSums(is.na(df))## ID name category
## 0 4 0
## main_category currency deadline
## 0 0 0
## launched pledged state
## 0 0 0
## backers country usd_pledged_real
## 0 0 0
## usd_goal_real pledged_goal_ratio pledged_backers_ratio
## 0 0 0Terdapat 4 missing value pada variabel name, kita akan menghilangkan 4 observasi tersebut dengan function na.omit dari package stats.
na.omit(df)## # A tibble: 378,657 x 15
## ID name category main_category currency deadline launched
## <dbl> <chr> <fct> <fct> <fct> <date> <dttm>
## 1 1.00e9 The ~ Poetry Publishing GBP 2015-10-09 2015-08-11 12:12:28
## 2 1.00e9 Gree~ Narrati~ Film & Video USD 2017-11-01 2017-09-02 04:43:57
## 3 1.00e9 Wher~ Narrati~ Film & Video USD 2013-02-26 2013-01-12 00:20:50
## 4 1.00e9 Tosh~ Music Music USD 2012-04-16 2012-03-17 03:24:11
## 5 1.00e9 Comm~ Film & ~ Film & Video USD 2015-08-29 2015-07-04 08:35:03
## 6 1.00e9 Mona~ Restaur~ Food USD 2016-04-01 2016-02-26 13:38:27
## 7 1.00e9 Supp~ Food Food USD 2014-12-21 2014-12-01 18:30:44
## 8 1.00e9 Chas~ Drinks Food USD 2016-03-17 2016-02-01 20:05:12
## 9 1.00e9 SPIN~ Product~ Design USD 2014-05-29 2014-04-24 18:14:43
## 10 1.00e8 STUD~ Documen~ Film & Video USD 2014-08-10 2014-07-11 21:55:48
## # ... with 378,647 more rows, and 8 more variables: pledged <dbl>, state <fct>,
## # backers <dbl>, country <fct>, usd_pledged_real <dbl>, usd_goal_real <dbl>,
## # pledged_goal_ratio <dbl>, pledged_backers_ratio <dbl>Sekarang kita telah memiliki dataframe yang rapi dan bersih sehingga dapat melanjutkan kedalam tahapan pengambilan insight.
3 Exploratory Data Analysis
Fase eksplorasi data merupakan salah satu unsur terpenting yang terkadang disepelekan dalam pekerjaan seorgan data scientist, eksplorasi data yang baik akan memberikan insight dan mempermudah pembuatan model.
main_category_sort <- df %>%
group_by(main_category) %>%
summarise(n = n()) %>%
arrange(desc(n))
main_category_sort$main_category <- factor(
x = main_category_sort$main_category,
levels = main_category_sort$main_category)
main_category_sort %>%
ggplot(aes(main_category, n,
color = n,
fill = n,
label = glue("{round(n/sum(n), 2)*100}%"))) +
scale_color_gradient(low = "#c0c0c0", high = "gold") +
scale_fill_gradient(low = "#c0c0c0", high = "gold") +
geom_col() +
ylim(0,70000) +
geom_text(vjust = -0.5) +
xlab("Main Category") +
ggtitle("Proportion of Project Main Category") +
theme(
legend.position = "none",
axis.text.y = element_blank(),
axis.title.y = element_blank(),
axis.text.x = element_text(angle = 90, vjust = 0.25)
) 
Film & Video, Music, Publishing, dan Games menempati posisi 4 teratas dari proporsi kategori utama project dan keempat kategori utama tersebut mencakup 51% dari seluruh project yang ada di kickstarter
country_sort <- df %>%
group_by(country) %>%
summarise(n = n()) %>%
arrange(desc(n))
country_sort$country <- factor(
x = country_sort$country,
levels = country_sort$country)
country_sort %>%
ggplot(aes(country, n,
color = n,
fill = n,
label = glue("{round(n/sum(n), 2)*100}%"))) +
scale_color_gradient(low = "#c0c0c0", high = "gold") +
scale_fill_gradient(low = "#c0c0c0", high = "gold") +
geom_col() +
ylim(0, 320000) +
geom_text(vjust = -0.5) +
xlab("Country") +
ggtitle("Proportion of Project Country") +
theme(
legend.position = "none",
axis.text.y = element_blank(),
axis.title.y = element_blank(),
axis.text.x = element_text(angle = 90, vjust = 0.25)
) 
77% Project yang ada di kickstarter berasal dari Amerikat, dan 9% berasal dari Inggris, project yang berasal kedua negara tersebut mencakup hingga 86% dari total keseluruhan project kickstarter.
df %>%
arrange(desc(usd_pledged_real)) %>%
head(10) ## # A tibble: 10 x 15
## ID name category main_category currency deadline launched
## <dbl> <chr> <fct> <fct> <fct> <date> <dttm>
## 1 1.80e9 "Peb~ Product~ Design USD 2015-03-28 2015-02-24 15:44:42
## 2 3.43e8 "COO~ Product~ Design USD 2014-08-30 2014-07-08 10:14:37
## 3 2.10e9 "Peb~ Product~ Design USD 2016-06-30 2016-05-24 15:49:52
## 4 5.45e8 "Kin~ Tableto~ Games USD 2017-01-08 2016-11-25 06:01:41
## 5 5.07e8 "Peb~ Product~ Design USD 2012-05-19 2012-04-11 06:59:04
## 6 5.66e8 "The~ Product~ Design USD 2015-09-03 2015-07-07 13:52:34
## 7 1.96e9 "Exp~ Tableto~ Games USD 2015-02-20 2015-01-20 19:00:19
## 8 1.03e9 "OUY~ Gaming ~ Games USD 2012-08-09 2012-07-10 14:44:41
## 9 6.47e8 "THE~ Tableto~ Games USD 2017-10-19 2017-09-26 20:00:02
## 10 4.50e8 "The~ Product~ Design USD 2016-09-10 2016-07-13 00:47:35
## # ... with 8 more variables: pledged <dbl>, state <fct>, backers <dbl>,
## # country <fct>, usd_pledged_real <dbl>, usd_goal_real <dbl>,
## # pledged_goal_ratio <dbl>, pledged_backers_ratio <dbl>10 project yang mendapatkan dana terbesar mengalami kesusesan, memiliki perbandingan antara dana yang diminta dengan dana yang diterima lebih besar dari 9x lipat dan berasal dari main_category Design dan Games, namun bagaimana dengan project mendapatkan dana besar dan tidak sukses ataupun dibatalkan?
df[df$state == "failed",] %>%
arrange(desc(usd_pledged_real)) %>%
head(10) ## # A tibble: 10 x 15
## ID name category main_category currency deadline launched
## <dbl> <chr> <fct> <fct> <fct> <date> <dttm>
## 1 1.28e9 The ~ Design Design USD 2016-09-03 2016-07-19 16:25:24
## 2 1.89e9 Crow~ Hardware Technology USD 2013-04-01 2013-02-09 01:56:30
## 3 1.57e9 CENT~ Camera ~ Technology USD 2014-05-30 2014-04-30 17:59:35
## 4 1.54e9 Bruv~ Product~ Design USD 2015-10-30 2015-09-01 15:37:15
## 5 7.54e8 RED ~ Video G~ Games USD 2015-08-03 2015-07-04 20:30:24
## 6 2.73e8 Kick~ Hardware Technology GBP 2013-04-01 2013-02-05 02:26:22
## 7 1.64e9 Pant~ Video G~ Games USD 2014-02-22 2014-01-13 20:40:41
## 8 4.43e8 Zafi~ Technol~ Technology USD 2016-08-10 2016-07-11 17:00:34
## 9 7.10e8 PROJ~ Video G~ Games USD 2013-03-06 2013-02-04 16:40:00
## 10 2.08e9 Shad~ Video G~ Games USD 2013-08-24 2013-07-25 17:00:53
## # ... with 8 more variables: pledged <dbl>, state <fct>, backers <dbl>,
## # country <fct>, usd_pledged_real <dbl>, usd_goal_real <dbl>,
## # pledged_goal_ratio <dbl>, pledged_backers_ratio <dbl>10 project yang menerima dana terbesar namun tidak berjalan mempunyai pledge_goal_ratio kurang dari 1 yang berarti dana yang dikumpulkan tidak mencukupi untuk project tersebut berjalan, namun apakah seluruh project yang memiliki status failed dikarenakan tidak terkumpulnya dana?
df[df$state == "failed" & df$pledged_goal_ratio >1,] ## # A tibble: 4 x 15
## ID name category main_category currency deadline launched
## <dbl> <chr> <fct> <fct> <fct> <date> <dttm>
## 1 1.09e9 "\"B~ Jazz Music USD 2013-04-04 2013-03-05 10:55:56
## 2 1.30e9 "Mus~ Classic~ Music USD 2012-01-04 2011-11-07 15:20:24
## 3 2.10e9 "The~ Fiction Publishing USD 2010-05-16 2010-03-18 04:35:31
## 4 5.92e7 "Key~ Product~ Design USD 2013-10-04 2013-08-24 05:42:10
## # ... with 8 more variables: pledged <dbl>, state <fct>, backers <dbl>,
## # country <fct>, usd_pledged_real <dbl>, usd_goal_real <dbl>,
## # pledged_goal_ratio <dbl>, pledged_backers_ratio <dbl>Terdapat 4 observasi dengan pledged_goal_ratio lebih dari 1 namun tidak berhasil dijalankan.
df[df$state == "canceled",] %>%
arrange(desc(usd_pledged_real)) %>%
head(10) ## # A tibble: 10 x 15
## ID name category main_category currency deadline launched
## <dbl> <chr> <fct> <fct> <fct> <date> <dttm>
## 1 9.01e7 "HAL~ Wearabl~ Technology USD 2017-01-24 2016-12-10 11:34:12
## 2 8.62e8 "uni~ Product~ Design EUR 2017-12-09 2017-10-10 12:29:49
## 3 9.39e8 "Wil~ Video G~ Games USD 2013-02-16 2013-01-14 19:01:39
## 4 1.46e9 "Zaf~ Technol~ Technology USD 2016-01-05 2015-11-16 14:00:18
## 5 5.92e8 "Ste~ Gadgets Technology AUD 2015-01-28 2014-12-10 18:29:11
## 6 1.73e9 "Hum~ Video G~ Games USD 2014-11-04 2014-10-02 18:58:36
## 7 1.41e8 "Scr~ Product~ Design USD 2014-09-15 2014-08-11 15:30:17
## 8 2.53e6 "LUC~ Technol~ Technology CAD 2013-11-14 2013-10-15 04:20:24
## 9 1.58e9 "Pro~ Space E~ Technology USD 2016-12-21 2016-11-15 14:58:35
## 10 1.34e9 "The~ Hardware Technology USD 2016-09-24 2016-08-23 18:47:04
## # ... with 8 more variables: pledged <dbl>, state <fct>, backers <dbl>,
## # country <fct>, usd_pledged_real <dbl>, usd_goal_real <dbl>,
## # pledged_goal_ratio <dbl>, pledged_backers_ratio <dbl>10 Project dengan penerimaan dana terbesar namun dibatalkan berasal dari kategori Technology, Games dan Design dan pada tingkat teratas project tersebut menerima dana hingga 215 kali lipat dari dana yang diminta.
pledged_goal_ratio_sort <- df %>%
group_by(main_category) %>%
summarise(pledged_goal_ratio = mean(pledged_goal_ratio)) %>%
arrange(desc(pledged_goal_ratio))
pledged_goal_ratio_sort$main_category <- factor(
x = pledged_goal_ratio_sort$main_category,
levels = pledged_goal_ratio_sort$main_category)
pledged_goal_ratio_sort %>%
ggplot(aes(main_category, pledged_goal_ratio,
color = pledged_goal_ratio,
fill = pledged_goal_ratio,
label = glue("{round(pledged_goal_ratio,1)} X"))) +
scale_color_gradient(low = "#c0c0c0", high = "gold") +
scale_fill_gradient(low = "#c0c0c0", high = "gold") +
geom_col() +
ylim(0,10) +
geom_text(vjust = -0.5) +
xlab("Main Category") +
ggtitle("Average Pledged Amount / Goal Ratio") +
theme(
legend.position = "none",
axis.text.y = element_blank(),
axis.title.y = element_blank(),
axis.text.x = element_text(angle = 90, vjust = 0.25)
) 
Project dengan main category Music, Games, dan Comics menduduki 3 posisi paling tinggi dalam rata - rata rasio perbandingan dana terkumpul dengan dana target. Sebaliknya, project dengan main_category berupa Food, Dance, Photography, dan Journalism menduduki posisi 4 terbawah dan memiliki nilai kurang dari 1 yang menunjukkan bahwa dana yang dikumpulkan tidak mencukupi target.
pledged_backers_ratio_sort <- df %>%
group_by(main_category) %>%
summarise(pledged_backers_ratio = mean(pledged_backers_ratio)) %>%
arrange(desc(pledged_backers_ratio))
pledged_backers_ratio_sort$main_category <- factor(
x = pledged_backers_ratio_sort$main_category,
levels = pledged_backers_ratio_sort$main_category)
pledged_backers_ratio_sort %>%
ggplot(aes(main_category, pledged_backers_ratio,
color = pledged_backers_ratio,
fill = pledged_backers_ratio,
label = glue("$ {round(pledged_backers_ratio,0)}"))) +
scale_color_gradient(low = "#c0c0c0", high = "gold") +
scale_fill_gradient(low = "#c0c0c0", high = "gold") +
geom_col() +
ylim(0,100) +
geom_text(vjust = -0.5) +
xlab("Main Category") +
ggtitle("Average Pledged Amount / Backers") +
theme(
legend.position = "none",
axis.text.y = element_blank(),
axis.title.y = element_blank(),
axis.text.x = element_text(angle = 90, vjust = 0.25)
) 
Technology, Design, Film & Video menduduki posisi 3 teratas untuk project dengan rata - rata jumlah dana terkumpul per pemberi dana tertinggi. Bahkan Technology dan Design mendapatkan dana rata - rata per pemberi dana hingga 96 dan 94 USD, namun bagaimanakah dengan tingkat kesuksesan dari tiap kategori project?
main_category_state_sort <- df %>%
group_by(main_category, state) %>%
summarise(n = n())
success <- main_category_state_sort[main_category_state_sort$state == "successful",]
not_success <- main_category_state_sort[main_category_state_sort$state != "successful",] %>%
group_by(main_category) %>%
summarise(n = sum(n))
success_rate_sort <- full_join(success, not_success,
suffix = c("_success","_not_success"),
by = "main_category") %>%
mutate(success_rate = n_success/(n_not_success+n_success)) %>%
arrange(desc(success_rate))
success_rate_sort$main_category <- factor(
x = success_rate_sort$main_category,
levels = success_rate_sort$main_category)
success_rate_sort %>%
ggplot(aes(main_category, success_rate,
color = success_rate,
fill = success_rate,
label = glue("{round((success_rate)*100,0)}%"))) +
scale_color_gradient(low = "#c0c0c0", high = "gold") +
scale_fill_gradient(low = "#c0c0c0", high = "gold") +
geom_col() +
ylim(0,0.65) +
geom_text(vjust = -0.5) +
xlab("Main Category") +
ggtitle("Project Success Rate") +
theme(
legend.position = "none",
axis.text.y = element_blank(),
axis.title.y = element_blank(),
axis.text.x = element_text(angle = 90, vjust = 0.25)
) 
Ternyata project dengan kategori Technology yang memiliki nilai rata - rata dana per pemberi dana tertinggi memiliki rate kesuksesan paling rendah diantara seluruh kategori project dengan hanya memiliki 20% observasi sukses dari total observasi, jika kita memiliki nilai return per kategori project, kita dapat mengalikan peluang tersebut dengan return yang diterima untuk mendapatkan nilai expected return.
Kita dapat mencoba menggali nilai expected_pledge_backers_ratio untuk melihat berapa nilai ekspektasi berdasarkan peluang dari rata - rata dana yang ditanamkan oleh tiap pemberi dana.
expected_pledged_backers_ratio_sort <- left_join(pledged_backers_ratio_sort,success_rate_sort) %>%
mutate(expected_pledged_backers_ratio = pledged_backers_ratio * success_rate) %>%
arrange(desc(expected_pledged_backers_ratio))
expected_pledged_backers_ratio_sort$main_category <- factor(
x = expected_pledged_backers_ratio_sort$main_category,
levels = expected_pledged_backers_ratio_sort$main_category)
expected_pledged_backers_ratio_sort %>%
ggplot(aes(main_category, expected_pledged_backers_ratio,
color = expected_pledged_backers_ratio,
fill = expected_pledged_backers_ratio,
label = glue("${round((expected_pledged_backers_ratio))}"))) +
scale_color_gradient(low = "#c0c0c0", high = "gold") +
scale_fill_gradient(low = "#c0c0c0", high = "gold") +
geom_col() +
ylim(0,50) +
geom_text(vjust = -0.5) +
xlab("Main Category") +
ggtitle("Expected Average Pledged Amount / Backers") +
theme(
legend.position = "none",
axis.text.y = element_blank(),
axis.title.y = element_blank(),
axis.text.x = element_text(angle = 90, vjust = 0.25))
Nilai ekspektasi dari dana yang ditanamkan oleh pemberi dana diperoleh dengan penanaman dana pada projek Dance, Theater, dan Design, dilanjutkan dengan Film & Video, sedangkan project dengan kategori Crafts, dan Journalism menduduki 2 peringkat paling rendah.
Terdapat kolom launched dan deadline pada data yang menunjukkan kapan proposal project tersebut ditampilkan di Kickstarter dan batas waktu akhir pengumpulan dana dapat dilakukan, dari kedua kolom tersebut kita dapat menghasilkan kolom funding_duration yang menunjukkan berapa lama waktu yang dipunyai oleh suatu project untuk mengumpulkan dana dalam satuan hari.
df %<>%
mutate(funding_duration = round(as.numeric(difftime(deadline, launched, units = "days"))))
summary(df$funding_duration)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.00 29.00 30.00 33.86 37.00 16739.00Lama pendanaaan dari suatu project secara rata - rata berkisar di antara 33 hingga 34 hari, namun terdapat observasi dengan lama pendanaan hingga 16739 hari, oleh karena itu kita akan melakukan inspeksi data untuk observasi dengan lama pendanaan lebih dari 100 hari.
df[df$funding_duration >100,]## # A tibble: 7 x 16
## ID name category main_category currency deadline launched
## <dbl> <chr> <fct> <fct> <fct> <date> <dttm>
## 1 1.01e9 "Sal~ Film & ~ Film & Video USD 2010-09-15 1970-01-01 01:00:00
## 2 1.25e9 "1st~ Art Art USD 2010-08-14 1970-01-01 01:00:00
## 3 1.38e9 "\"I~ Film & ~ Film & Video USD 2010-05-21 1970-01-01 01:00:00
## 4 1.48e9 "Sup~ Theater Theater USD 2010-06-01 1970-01-01 01:00:00
## 5 3.31e8 "Hel~ Music Music USD 2010-05-04 1970-01-01 01:00:00
## 6 4.63e8 "Ide~ Design Design USD 2010-04-10 1970-01-01 01:00:00
## 7 6.95e7 "Stu~ Publish~ Publishing CHF 2015-10-31 1970-01-01 01:00:00
## # ... with 9 more variables: pledged <dbl>, state <fct>, backers <dbl>,
## # country <fct>, usd_pledged_real <dbl>, usd_goal_real <dbl>,
## # pledged_goal_ratio <dbl>, pledged_backers_ratio <dbl>,
## # funding_duration <dbl>Terdapat 7 observasi dengan lama pendanaan lebih dari 7 hari dan seluruhnya diluncurkan pada tanggal 1 Januari 1970 yang mustahil terjadi, oleh karena itu kita akan menghilangkan ketujuh observasi tersebut dari dataset kita dan melakukan pengecekan kembali terhadap variabel funding_duration.
df <- df[df$funding_duration < 100,]
df %>%
group_by(funding_duration) %>%
summarise(n = n()) %>%
ggplot(aes(funding_duration, n, fill = n, color = n)) +
geom_col(width = 0.2) +
geom_line() +
scale_color_gradient(low = "#c0c0c0", high = "gold") +
scale_fill_gradient(low = "#c0c0c0", high = "gold") +
xlab("Days") +
ggtitle("Funding Duration") +
annotate("text", x = 47, y = 100000, label =
glue("Average Duration = {round(mean(df$funding_duration))} days
Standard Deviation = {round(sd(df$funding_duration))} days")) +
theme(
axis.text.y = element_blank(),
axis.title.y = element_blank(),
legend.position = "none"
) 
Lama pendanaan suatu project memiliki durasi rata - rata 34 hari dengan standar deviasi 13 hari secara umum, inspeksi lebih lanjut dapat kita lakukan bedasarkan status dan kategori utama dari project tersebut.
aggregate(funding_duration ~ state,
data = df,
FUN = mean) %>%
arrange(desc(funding_duration))## state funding_duration
## 1 live 39.16935
## 2 canceled 35.36422
## 3 suspended 34.82818
## 4 failed 34.56113
## 5 undefined 32.26053
## 6 successful 31.51863Tidak terdapat perbedaan durasi pendanaan yang signifikan dalam observasi berdasarkan status project.
aggregate(funding_duration ~ main_category,
data = df,
FUN = mean) %>%
arrange(desc(funding_duration))## main_category funding_duration
## 1 Music 34.82713
## 2 Technology 34.79996
## 3 Film & Video 34.69264
## 4 Journalism 33.93460
## 5 Design 33.82926
## 6 Comics 33.55430
## 7 Food 33.43850
## 8 Publishing 33.37823
## 9 Photography 33.24705
## 10 Theater 32.98717
## 11 Dance 32.49071
## 12 Fashion 32.22567
## 13 Art 31.97997
## 14 Games 31.90471
## 15 Crafts 30.94755Perbedaan waktu yang signifikan juga tidak nampak dari observasi berdasarkan kategori utama.
4 Model Creation
4.1 Feature Selection
Proses Feature Selection merupakan tahapan penciptaaan model dimana dilakukan pemilihan terhadap variabel yang hendak digunakan untuk melatih model. Dalam dataset terdapat kolom ID, name, deadline, dan launched yang akan dihilangkan karena tidak memiliki signifikansi terhadap pelatihan model, kolom category yang memiliki 159 unique value juga tidak akan diperhitungkan kedalam variabel pelatihan model karena mengandung terlalu banyak unique value.
df %<>%
select(-c("ID", "name", "category", "deadline", "launched"))
str(df)## tibble [378,654 x 11] (S3: tbl_df/tbl/data.frame)
## $ main_category : Factor w/ 15 levels "Art","Comics",..: 13 7 7 11 7 8 8 8 5 7 ...
## $ currency : Factor w/ 14 levels "AUD","CAD","CHF",..: 6 14 14 14 14 14 14 14 14 14 ...
## $ pledged : num [1:378654] 0 2421 220 1 1283 ...
## $ state : Factor w/ 6 levels "canceled","failed",..: 2 2 2 2 1 4 4 2 1 1 ...
## $ backers : num [1:378654] 0 15 3 1 14 224 16 40 58 43 ...
## $ country : Factor w/ 23 levels "AT","AU","BE",..: 10 23 23 23 23 23 23 23 23 23 ...
## $ usd_pledged_real : num [1:378654] 0 2421 220 1 1283 ...
## $ usd_goal_real : num [1:378654] 1534 30000 45000 5000 19500 ...
## $ pledged_goal_ratio : num [1:378654] 0 0.0807 0.00489 0.0002 0.06579 ...
## $ pledged_backers_ratio: num [1:378654] 0 161.4 73.3 1 91.6 ...
## $ funding_duration : num [1:378654] 58 60 45 30 56 34 19 44 34 29 ...
## - attr(*, "spec")=
## .. cols(
## .. ID = col_double(),
## .. name = col_character(),
## .. category = col_character(),
## .. main_category = col_character(),
## .. currency = col_character(),
## .. deadline = col_date(format = ""),
## .. goal = col_double(),
## .. launched = col_datetime(format = ""),
## .. pledged = col_double(),
## .. state = col_character(),
## .. backers = col_double(),
## .. country = col_character(),
## .. `usd pledged` = col_double(),
## .. usd_pledged_real = col_double(),
## .. usd_goal_real = col_double(),
## .. .delim = ","
## .. )4.2 Preprocessing
Data yang telah dipersiapkan untuk melatih model harus melalui tahapan berikut sebelum dipergunakan:
- Menghilangkan variabel yang berkorelasi (diatas 0.5)
- Memastikan dataset yang dipergunakan tidak memiliki variance mendekati 0, variabel prediktor yang memiliki variance mendekati 0 akan berkontribusi sedikit terhadap pelatihan model dan menjadi beban tambahan dalam pelatihan model.
- Memastikan bahwa variabel target memiliki proporsi yang seimbang agar model tidak mengalami ketimpangan atau bias terhadap suatu value ketika dilatih.
- Dummify: data kategorikal diubah kedalam format 1 dan 0 karena model hanya dapat menerima input numeric.
- Scaling: data numerik yang telah diperoleh diubah kedalam jangkauan atau range yang sama untuk memudahkan model belajar
ggcorrplot(cor(df %>% select_if(is.numeric)),
method = "square",
type = "lower",
show.legend = FALSE,
show.diag = FALSE,
colors = c("gold", "#c0c0c0", "gold"),
outline.color = "#c0c0c0",
lab = TRUE,
lab_col = "#333333",
lab_size = 3,
hc.order = TRUE,
title = "Correlation Plot",
ggtheme = theme_modern_rc()) +
theme(
axis.title.y = element_blank(),
axis.title.x = element_blank(),
axis.text.x = element_text(angle = 90),
legend.position = "none"
)
Correlation plot menunjukkan korelasi yang tinggi antara kolom backers, pledged dan usd_pledged, untuk menghindari dampak dari korelasi yang tinggi antara ketiga variabel tersebut, akan dilakukan penghapusan variabel backers, dan pledged.
df %<>%
select(-c("backers", "pledged"))Setelah kita sudah memastikan data yang kita miliki sudah siap untuk berlanjut ke tahap preprocessing, kita dapat melakukan inspeksi kembali terhadap proporsi dari target variabel kita.
round(prop.table(table(df$state)), 2)##
## canceled failed live successful suspended undefined
## 0.10 0.52 0.01 0.35 0.00 0.01Terdapat 2 cara utama untuk menghadapi kelas target yang timpang yaitu dengan metode upsampling dan undersampling, metode upsampling dapat membantu kita untuk menghindari information loss, namun meningkatkan waktu pelatihan model, membutuhkan RAM atupun swap yang lebih besar, dan meningkatkan resiko overfitting karena metode tersebut melakukan replika dari observasi minor.
Cara kedua yaitu dengan menggunakan metode undersampling, yaitu dengan mengurangi jumlah observasi pada observasi mayoritas untuk mengimbangi jumlah observasi minor, metode ini ideal digunakan dengan dataset yang besar yang dapat meminimalisir resiko information loss, salah satu resiko terbesar dari undersampling adalah hilangnya observasi yang menjadi kunci dari pola penting untuk pelatihan model. Kedua metode tersebut akan menjadi langkah optimisasi model pada akhir artikel.
Dummify dan scaling akan dilakukan dengan bantuan dari package recipe yang terkandung dalam tidymodels
rec <- recipe(state ~ ., data = df)
summary(rec)## # A tibble: 9 x 4
## variable type role source
## <chr> <chr> <chr> <chr>
## 1 main_category nominal predictor original
## 2 currency nominal predictor original
## 3 country nominal predictor original
## 4 usd_pledged_real numeric predictor original
## 5 usd_goal_real numeric predictor original
## 6 pledged_goal_ratio numeric predictor original
## 7 pledged_backers_ratio numeric predictor original
## 8 funding_duration numeric predictor original
## 9 state nominal outcome originalPada tahap ini kita telah menentukan 1 variabel outcome yaitu variabel state dengan variabel lainnya sebagai predictor, variabel kategorikal digolongkan kedalam tipe nominal dan tahapan pembuatan resep preprocessing akan dilanjutkan dengan pembuatan resep.
rec %<>%
step_dummy(all_nominal(), -all_outcomes()) %>%
step_nzv(all_predictors()) %>% # menghilangkan variabel dengan variance mendekati 0
step_sqrt(all_predictors()) %>%
step_center(all_predictors()) %>%
step_scale(all_predictors())
prep_rec <- prep(rec, df)
df_baked <- bake(prep_rec, df)Sebelum berlanjut ke tahap pelatihan model, kita akan melalui tahap train - test split untuk memisahkan antara data yang akan digunakan untuk melatih model dan menguji performa model dengan bantuan function initial_split(), training(), dan testing() yang berasal dari package rsample dan merupakan bagian dari package tidymodels.
split <- initial_split(df_baked) # proporsi default 3/4
train <- training(split)
train_X <- train %>% select(!state)
train_y <- train %>% select(state)
test <- testing(split)
test_X <- test %>% select(!state)
test_y <- test %>% select(state)Sebelum melatih model dengan menggunakan framework keras, kita harus mengubah bentuk data dari dataframe menjadi matrix dan kedalam bentuk array karena framework keras membutuhkan input dalam format array untuk komputasi in-memory yang optimal.
train_X_matrix <- as.matrix(train_X)
test_X_matrix <- as.matrix(test_X)
levels(train_y) <- 1:length(train_y)
train_y_array <- to_categorical(as.matrix(as.numeric(train_y$state) - 1),
num_classes = 6)
levels(test_y) <- 1:length(test_y)
test_y_matrix <- as.matrix(as.numeric(test_y$state) - 1)Untuk variable test_y hanya akan dilakukan perubahan hingga tahap matrix, tidak seperti train_y yang diubah hingga dalam bentuk one-hot encoding karena test_y diperlukan untuk evaluasi hasil prediksi
train_X_array <- array(train_X_matrix,
dim = c(nrow(train_X_matrix), 17, 1))
test_X_array <- array(test_X_matrix,
dim = c(nrow(test_X_matrix), 17, 1))4.3 Layer Building
Secara umum kita mengenal CNN untuk masalah image classification yang sebenarnya merupakan CNN 2 dimensi. Untuk permasalahan klasifikasi dalam artikel kali ini kita akan menggunakan 1D convolution later yang dikenal efektif untuk melakukan seleksi terhadap variabel karena kernel akan bergerak dalam jangakuan 1 dimensi terhadap variabel prediktor dengan 17 variabel prediktor dan 1 data point, argumen kernel_size mendeklarasikan ukuran dari kernel yang bergerak dan activation function yang kita gunakan adalah relu agar diterapkan juga kepada output.
model <- keras_model_sequential()
model %>%
layer_conv_1d(filters = 64,
kernel_size = 2,
input_shape = c(17, 1),
activation = "relu") %>%
layer_max_pooling_1d() %>%
layer_flatten() %>%
layer_dense(units = 6,
activation = "softmax") layer_max_pooling_1d() dan layer_flatten() digunakan untuk mengubah bentuk dari output 1D CNN kedalam bentuk yang dapat diolah kembali oleh layer_dense(). 6 unit pada layer_dense() sama dengan 6 kelas pada target variable kita, dan softmax yang menjadi layer activation untuk output kita merupakan generalisasi dari logistic function untuk multi dimensi, dan pada akhirnya menormalisasi output dari neural network kita terhadap distribusi probabilitas terhadap kelas output.
model %>% compile(
loss = "categorical_crossentropy",
optimizer = "adam",
metrics = "accuracy"
)
model %>% summary()## Model: "sequential"
## ________________________________________________________________________________
## Layer (type) Output Shape Param #
## ================================================================================
## conv1d (Conv1D) (None, 16, 64) 192
## ________________________________________________________________________________
## max_pooling1d (MaxPooling1D) (None, 8, 64) 0
## ________________________________________________________________________________
## flatten (Flatten) (None, 512) 0
## ________________________________________________________________________________
## dense (Dense) (None, 6) 3078
## ================================================================================
## Total params: 3,270
## Trainable params: 3,270
## Non-trainable params: 0
## ________________________________________________________________________________Kita akan melatih model awal kita dengan 100 epochs dan 20% dari data train akan digunakan untuk validasi model. Parameter loss berupa categorical_crossentropy digunakan karena kita akan melakuka klasifikasi multi kategori, optimizer adam menjadi salah satu pilihan terbaik untuk machine learning, metrics accuracy merupakan metric standar untuk mengevaluasi output dari model klasifikasi.Function callback_early_stopping() digunakan untuk menghentikan pelatihan model ketika tidak ada peningkatan performa dari model untuk menghemat waktu pelatihan.
model %>% fit(
train_X_array, train_y_array,
epochs = 100,
validation_split = 0.2,
callback = callback_early_stopping(),
verbose = 0
)5 Model Evaluation
Ekspektasi utama dari model baseline ini adalah model kesulitan untuk mempelajari pola tertentu dari data dikarenakan terdapat ketimpangan yang ekstrim dalam variabel target yaitu pada kelas undefined, live, dan suspended yang masing - masing hanya memiliki proporsi 1% dari data keseluruhan.
scores <- model %>% evaluate(train_X_array, train_y_array)
print(scores)## loss accuracy
## 0.4008223 0.8738517Model berakhir dengan loss 40% serta accuracy 87%
pred_y <- model %>% predict(test_X_array)
y_hat = data.frame("pred_y" = ifelse(max.col(pred_y[ ,1:6]) == 1, "0",
ifelse(max.col(pred_y[ ,1:6]) == 2, "1",
ifelse(max.col(pred_y[ ,1:6]) == 3, "2",
ifelse(max.col(pred_y[ ,1:6]) == 4, "3",
ifelse(max.col(pred_y[ ,1:6]) == 5, "4", "5"))))))
confusionMatrix(as.factor(y_hat$pred_y),
as.factor(test_y_matrix))## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1 2 3 4 5
## 0 164 338 5 40 11 2
## 1 9192 48585 539 65 354 80
## 2 0 0 0 0 0 0
## 3 283 625 124 33229 83 1
## 4 17 44 0 1 0 0
## 5 3 22 0 27 0 829
##
## Overall Statistics
##
## Accuracy : 0.8748
## 95% CI : (0.8726, 0.8769)
## No Information Rate : 0.5241
## P-Value [Acc > NIR] : < 0.00000000000000022
##
## Kappa : 0.7705
##
## Mcnemar's Test P-Value : NA
##
## Statistics by Class:
##
## Class: 0 Class: 1 Class: 2 Class: 3 Class: 4 Class: 5
## Sensitivity 0.016979 0.9793 0.000000 0.9960 0.000000 0.908991
## Specificity 0.995341 0.7729 1.000000 0.9818 0.999342 0.999445
## Pos Pred Value 0.292857 0.8261 NaN 0.9675 0.000000 0.940976
## Neg Pred Value 0.899100 0.9713 0.992943 0.9978 0.995264 0.999115
## Prevalence 0.102036 0.5241 0.007057 0.3524 0.004733 0.009634
## Detection Rate 0.001732 0.5132 0.000000 0.3510 0.000000 0.008757
## Detection Prevalence 0.005916 0.6213 0.000000 0.3628 0.000655 0.009307
## Balanced Accuracy 0.506160 0.8761 0.500000 0.9889 0.499671 0.954218Function confusionMatrix dari package caret menunjukkan Sensitivity dan Balanced Accuracy yang sangat kecil untuk class 0, 2 dan 4 dikarenakan observasi yang sangat sedikit untuk kelas tersebut jika dibandingkan dengan total populasi keseluruhan. Oleh karena itu kita akan melakukan optimisasi model dengan metode downsampling untuk mengatasi permasalahan ketimpangan kelas dan pada akhirnya membantu model kita berlatih dengan lebih tekun.
6 Model Optimization
6.1 Undersampling
Salah satu cara optimisasi model yang disarankan untuk kasus variabel target dengan ketimpangan yang ekstrim adalah dengan melakukan undersampling, kita dapat melakukan undersampling karena data yang kita miliki sudah cukup banyak, namun tetap perlu menjadi catatan bahwa resiko information loss selalu menjadi resiko utama dari metode undersampling. Downsampling akan dilakukan dengan bantuan function downSample dari package caret.
train_down <- downSample(x = train_X, y = train_y$state)
test_down <- downSample(x = test_X, y = test_y$state)
train_X_down <- train_down %>% select(-c(Class))
test_X_down <- test_down %>% select(-c(Class))
train_y_down <- train_down %>% select(Class)
test_y_down <- test_down %>% select(Class)
train_X_down_matrix <- as.matrix(train_X_down)
test_X_down_matrix <- as.matrix(test_X_down)
levels(train_y_down) <- 1:length(train_y_down)
train_y_down_array <- to_categorical(as.matrix(as.numeric(train_y_down$Class) - 1),
num_classes = 6)
levels(test_y_down) <- 1:length(test_y_down)
test_y_down_matrix <- as.matrix(as.numeric(test_y_down$Class) - 1)
train_X_down_array <- array(train_X_down_matrix,
dim = c(nrow(train_X_down_matrix), 17, 1))
test_X_down_array <- array(test_X_down_matrix,
dim = c(nrow(test_X_down_matrix), 17, 1))
prop.table(table(train_down$Class))##
## canceled failed live successful suspended undefined
## 0.1666667 0.1666667 0.1666667 0.1666667 0.1666667 0.1666667Setelah kita melakukan preprocessing prediktor dan target untuk data train dan test yang telah mengalami downsampling, kita akan melatih model kembali namun tanpa parameter validation_split karena dataset yang kita miliki sudah menjadi sangat sedikit setelah dilakukan downsampling.
model %>% fit(
train_X_down_array, train_y_down_array,
epochs = 100,
verbose = 0
)
scores_down <- model %>% evaluate(train_X_down_array, train_y_down_array)
print(scores_down)## loss accuracy
## 0.9753780 0.5602481pred_y_down <- model %>% predict(test_X_down_array)
y_hat_down = data.frame("pred_y" = ifelse(max.col(pred_y_down[ ,1:6]) == 1, "0",
ifelse(max.col(pred_y_down[ ,1:6]) == 2, "1",
ifelse(max.col(pred_y_down[ ,1:6]) == 3, "2",
ifelse(max.col(pred_y_down[ ,1:6]) == 4, "3",
ifelse(max.col(pred_y_down[ ,1:6]) == 5, "4", "5"))))))
confusionMatrix(as.factor(y_hat_down$pred_y),
as.factor(test_y_down_matrix))## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1 2 3 4 5
## 0 174 109 83 0 82 0
## 1 72 111 65 0 27 0
## 2 60 78 124 11 61 0
## 3 16 6 69 419 47 0
## 4 124 137 100 18 227 1
## 5 2 7 7 0 4 447
##
## Overall Statistics
##
## Accuracy : 0.5588
## 95% CI : (0.5398, 0.5777)
## No Information Rate : 0.1667
## P-Value [Acc > NIR] : < 0.00000000000000022
##
## Kappa : 0.4705
##
## Mcnemar's Test P-Value : NA
##
## Statistics by Class:
##
## Class: 0 Class: 1 Class: 2 Class: 3 Class: 4 Class: 5
## Sensitivity 0.38839 0.24777 0.27679 0.9353 0.50670 0.9978
## Specificity 0.87768 0.92679 0.90625 0.9384 0.83036 0.9911
## Pos Pred Value 0.38839 0.40364 0.37126 0.7522 0.37397 0.9572
## Neg Pred Value 0.87768 0.86034 0.86236 0.9864 0.89380 0.9995
## Prevalence 0.16667 0.16667 0.16667 0.1667 0.16667 0.1667
## Detection Rate 0.06473 0.04129 0.04613 0.1559 0.08445 0.1663
## Detection Prevalence 0.16667 0.10231 0.12426 0.2072 0.22582 0.1737
## Balanced Accuracy 0.63304 0.58728 0.59152 0.9368 0.66853 0.9944Dengan data hasil downsampling, model mendapati loss lebih besar dan akurasi yang menurun dikarenakan information loss yang terjadi, salah satu cara untuk menghadapi hal tersebut adalah dengan menambah epoch, menambah jumlah neuron ataupun memperkecil learning rate dari model kita.
model_down <- keras_model_sequential()
model_down %>%
layer_conv_1d(filters = 64,
kernel_size = 2,
input_shape = c(17, 1),
activation = "relu") %>%
layer_max_pooling_1d() %>%
layer_flatten() %>%
layer_dense(units = 6,
activation = "softmax")
model_down %>% compile(
loss = "categorical_crossentropy",
optimizer = "adam",
metrics = "accuracy"
)
model_down %>% fit(
train_X_down_array, train_y_down_array,
epochs = 300,
verbose = 0
)
pred_y_down <- model_down %>% predict(test_X_down_array)
y_hat_down <- data.frame("pred_y" = ifelse(max.col(pred_y_down[ ,1:6]) == 1, "0",
ifelse(max.col(pred_y_down[ ,1:6]) == 2, "1",
ifelse(max.col(pred_y_down[ ,1:6]) == 3, "2",
ifelse(max.col(pred_y_down[ ,1:6]) == 4, "3",
ifelse(max.col(pred_y_down[ ,1:6]) == 5, "4", "5"))))))
confusionMatrix(as.factor(y_hat_down$pred_y),
as.factor(test_y_down_matrix))## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1 2 3 4 5
## 0 118 55 38 0 66 0
## 1 175 232 133 1 101 0
## 2 91 114 176 23 135 0
## 3 13 6 60 407 33 0
## 4 51 35 37 17 109 1
## 5 0 6 4 0 4 447
##
## Overall Statistics
##
## Accuracy : 0.5539
## 95% CI : (0.5349, 0.5729)
## No Information Rate : 0.1667
## P-Value [Acc > NIR] : < 0.00000000000000022
##
## Kappa : 0.4647
##
## Mcnemar's Test P-Value : NA
##
## Statistics by Class:
##
## Class: 0 Class: 1 Class: 2 Class: 3 Class: 4 Class: 5
## Sensitivity 0.2634 0.51786 0.39286 0.9085 0.24330 0.9978
## Specificity 0.9290 0.81696 0.83795 0.9500 0.93705 0.9938
## Pos Pred Value 0.4260 0.36137 0.32653 0.7842 0.43600 0.9696
## Neg Pred Value 0.8631 0.89443 0.87343 0.9811 0.86095 0.9996
## Prevalence 0.1667 0.16667 0.16667 0.1667 0.16667 0.1667
## Detection Rate 0.0439 0.08631 0.06548 0.1514 0.04055 0.1663
## Detection Prevalence 0.1031 0.23884 0.20052 0.1931 0.09301 0.1715
## Balanced Accuracy 0.5962 0.66741 0.61540 0.9292 0.59018 0.9958Masih terdapat ketimpangan yang cukup tinggi pada metrics prediksi kita dengan peningkatan hanya kurang lebih 12% akurasi dengan peningkatan jumlah epoch sebesar 3 kali lipat.
Metode undersampling belum dapat menyelesaikan permasalah ketimpangan data dalam target variable yang kita miliki, oleh karena itu kita akan mencoba untuk melakukan eliminasi kelas pada variabel target kita.
6.2 Class Target Elimination
Metode ini menyederhanakan kelas dari target variabel untuk mempermudah melatih model dan hanya dapat dilakukan dengan catatan kita melakukan eliminasi target variabel sesuai dengan business problem yang sedang kita hadapi, dalam kasus data kickstarter ini, kita mencoba untuk menebak apakah suatu project akan berjalan ataupun tidak, oleh karena itu kita akan mempertimbangkan untuk hanya menggunakan kelas target canceled, failed, dan successful.
df %<>%
filter(state %in% c("failed", "canceled", "successful")) %>%
mutate(state = factor(state))
prop.table(table(df$state))##
## canceled failed successful
## 0.1046652 0.5337294 0.3616054Kita akan melakukan serangkaian preprocessing dan modeling seperti yang telah kita lakukan pada langkah - langkah sebelumnya terhadap dataset baru ini.
rec <- recipe(state ~ ., data = df)
rec %<>%
step_dummy(all_nominal(), -all_outcomes()) %>%
step_nzv(all_predictors()) %>% # menghilangkan variabel dengan variance mendekati 0
step_sqrt(all_predictors()) %>%
step_center(all_predictors()) %>%
step_scale(all_predictors())
prep_rec <- prep(rec, df)
df_baked <- bake(prep_rec, df)
split <- initial_split(df_baked) # proporsi default 3/4
train <- training(split)
train_X <- train %>% select(!state)
train_y <- train %>% select(state)
test <- testing(split)
test_X <- test %>% select(!state)
test_y <- test %>% select(state)
train_X_matrix <- as.matrix(train_X)
test_X_matrix <- as.matrix(test_X)
levels(train_y) <- 1:length(train_y)
train_y_array <- to_categorical(as.matrix(as.numeric(train_y$state) - 1),
num_classes = 3)
levels(test_y) <- 1:length(test_y)
test_y_matrix <- as.matrix(as.numeric(test_y$state) - 1)
train_X_array <- array(train_X_matrix,
dim = c(nrow(train_X_matrix), 17, 1))
test_X_array <- array(test_X_matrix,
dim = c(nrow(test_X_matrix), 17, 1))model <- keras_model_sequential()
model %>%
layer_conv_1d(filters = 64,
kernel_size = 2,
input_shape = c(17, 1),
activation = "relu") %>%
layer_max_pooling_1d() %>%
layer_flatten() %>%
layer_dense(units = 3,
activation = "softmax")
model %>% compile(
loss = "categorical_crossentropy",
optimizer = "adam",
metrics = "accuracy"
)
model %>% fit(
train_X_array, train_y_array,
epochs = 100,
validation_split = 0.2,
callback = callback_early_stopping(),
verbose = 0
)
pred_y <- model %>% predict(test_X_array)
y_hat = data.frame("pred_y" = ifelse(max.col(pred_y[ ,1:3]) == 1, "0",
ifelse(max.col(pred_y[ ,1:3]) == 2, "1", "2")))
confusionMatrix(as.factor(y_hat$pred_y),
as.factor(test_y_matrix))## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1 2
## 0 4 18 6
## 1 9481 49047 210
## 2 238 390 33218
##
## Overall Statistics
##
## Accuracy : 0.8883
## 95% CI : (0.8863, 0.8903)
## No Information Rate : 0.534
## P-Value [Acc > NIR] : < 0.00000000000000022
##
## Kappa : 0.789
##
## Mcnemar's Test P-Value : < 0.00000000000000022
##
## Statistics by Class:
##
## Class: 0 Class: 1 Class: 2
## Sensitivity 0.00041140 0.9918 0.9935
## Specificity 0.99971046 0.7754 0.9894
## Pos Pred Value 0.14285714 0.8350 0.9814
## Neg Pred Value 0.89502506 0.9880 0.9963
## Prevalence 0.10498639 0.5340 0.3610
## Detection Rate 0.00004319 0.5296 0.3587
## Detection Prevalence 0.00030234 0.6342 0.3655
## Balanced Accuracy 0.50006093 0.8836 0.9915Dengan menghilangkan target variabel, kita mendapat peningkatan kurang lebih 1% pada akurasi dari model kita, sebagai langkah optimisasi tambahan kita akan coba untuk melakukan tuning terhadap model .
model <- keras_model_sequential()
model %>%
layer_conv_1d(filters = 64,
kernel_size = 2,
input_shape = c(17, 1),
activation = "relu") %>%
layer_max_pooling_1d() %>%
layer_flatten() %>%
layer_dense(units = 32,
activation = "relu") %>%
layer_dense(units = 3,
activation = "softmax")
model %>% compile(
loss = "categorical_crossentropy",
optimizer = "adam",
metrics = "accuracy"
)
model %>% fit(
train_X_array, train_y_array,
epochs = 100,
validation_split = 0.2,
callback = callback_early_stopping(),
verbose = 2
)
pred_y <- model %>% predict(test_X_array)
y_hat = data.frame("pred_y" = ifelse(max.col(pred_y[ ,1:3]) == 1, "0",
ifelse(max.col(pred_y[ ,1:3]) == 2, "1", "2")))
confusionMatrix(as.factor(y_hat$pred_y),
as.factor(test_y_matrix))## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1 2
## 0 5 19 6
## 1 9483 49144 13
## 2 235 292 33415
##
## Overall Statistics
##
## Accuracy : 0.8915
## 95% CI : (0.8895, 0.8935)
## No Information Rate : 0.534
## P-Value [Acc > NIR] : < 0.00000000000000022
##
## Kappa : 0.7951
##
## Mcnemar's Test P-Value : < 0.00000000000000022
##
## Statistics by Class:
##
## Class: 0 Class: 1 Class: 2
## Sensitivity 0.00051424 0.9937 0.9994
## Specificity 0.99969839 0.7800 0.9911
## Pos Pred Value 0.16666667 0.8381 0.9845
## Neg Pred Value 0.89503359 0.9908 0.9997
## Prevalence 0.10498639 0.5340 0.3610
## Detection Rate 0.00005399 0.5306 0.3608
## Detection Prevalence 0.00032393 0.6332 0.3665
## Balanced Accuracy 0.50010632 0.8868 0.9953Dengan penambahan 1 layer_dense() dengan 32 unit NN dan activation relu setelah layer CNN kita mendapatkan penambahan akurasi kurang lebih 0.1% sehingga kita mendapatkan model akhir dengan akurasi 89%, berdasarkan metrics Sensitivity dan Specificity dari Class 0, kita dapat melihat bahwa Specificity hampir mencapai 100% namun Sensitivity hanya sebesar 8% hal tersebut menunjukkan bahwa model kita dapat membedakan dengan baik mana project yang tidak akan di cancel, namun model hampir tidak mengerti bagaimana cara menebak project yang akan di cancel karena kesulitan untuk membedakan antara kelas canceled dan failed berdasarkan confusion matrix yang tersedia.
7 Bonus
Sebagai langkah tambahan, kita akan melakukan klasifikasi dengan 2 kelas target yaitu failed dan successful, observasi dalam kelas canceled akan digolongkan kedalam kelas failed berdasarkan kesulitan model yang tergambar dari confusion matrix sebelumnya.
df[df$state == "canceled",3] <- "failed"
df %<>%
mutate(state = factor(state))
prop.table(table(df$state))##
## failed successful
## 0.6383946 0.3616054Kita juga akan melakukan sedikit perubahan dalam arsitektur NN kita dengan menambahkan layer dropout sebesar 0.5 setelah layer CNN dan memperbesar validation_split menjadi 50% untuk menghindari overfitting.
rec <- recipe(state ~ ., data = df)
summary(rec)## # A tibble: 9 x 4
## variable type role source
## <chr> <chr> <chr> <chr>
## 1 main_category nominal predictor original
## 2 currency nominal predictor original
## 3 country nominal predictor original
## 4 usd_pledged_real numeric predictor original
## 5 usd_goal_real numeric predictor original
## 6 pledged_goal_ratio numeric predictor original
## 7 pledged_backers_ratio numeric predictor original
## 8 funding_duration numeric predictor original
## 9 state nominal outcome originalrec %<>%
step_dummy(all_nominal(), -all_outcomes()) %>%
step_nzv(all_predictors()) %>% # menghilangkan variabel dengan variance mendekati 0
step_sqrt(all_predictors()) %>%
step_center(all_predictors()) %>%
step_scale(all_predictors())
prep_rec <- prep(rec, df)
df_baked <- bake(prep_rec, df)
split <- initial_split(df_baked) # proporsi default 3/4
train <- training(split)
train_X <- train %>% select(!state)
train_y <- train %>% select(state)
test <- testing(split)
test_X <- test %>% select(!state)
test_y <- test %>% select(state)
train_X_matrix <- as.matrix(train_X)
test_X_matrix <- as.matrix(test_X)
levels(train_y) <- 1:length(train_y)
train_y_array <- to_categorical(as.matrix(as.numeric(train_y$state) - 1),
num_classes = 2)
levels(test_y) <- 1:length(test_y)
test_y_matrix <- as.matrix(as.numeric(test_y$state) - 1)
train_X_array <- array(train_X_matrix,
dim = c(nrow(train_X_matrix), 17, 1))
test_X_array <- array(test_X_matrix,
dim = c(nrow(test_X_matrix), 17, 1))
model <- keras_model_sequential()
model %>%
layer_conv_1d(filters = 64,
kernel_size = 2,
input_shape = c(17, 1),
activation = "relu") %>%
layer_dropout(0.5) %>%
layer_max_pooling_1d() %>%
layer_flatten() %>%
layer_dense(units = 2,
activation = "softmax")
model %>% compile(
loss = "categorical_crossentropy",
optimizer = "adam",
metrics = "accuracy"
)
model %>% fit(
train_X_array, train_y_array,
epochs = 100,
validation_split = 0.5,
callback = callback_early_stopping(),
verbose = 2
)
pred_y <- model %>% predict(test_X_array)
y_hat <- data.frame("pred_y" = ifelse(max.col(pred_y[ ,1:2]) == 1, "0", "1"))
confusionMatrix(as.factor(y_hat$pred_y),
as.factor(test_y_matrix))## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 57602 3833
## 1 1625 29552
##
## Accuracy : 0.9411
## 95% CI : (0.9395, 0.9426)
## No Information Rate : 0.6395
## P-Value [Acc > NIR] : < 0.00000000000000022
##
## Kappa : 0.8703
##
## Mcnemar's Test P-Value : < 0.00000000000000022
##
## Sensitivity : 0.9726
## Specificity : 0.8852
## Pos Pred Value : 0.9376
## Neg Pred Value : 0.9479
## Prevalence : 0.6395
## Detection Rate : 0.6220
## Detection Prevalence : 0.6634
## Balanced Accuracy : 0.9289
##
## 'Positive' Class : 0
## Pada akhirnya kita memiliki model yang dapat membedakan antara project yang sukses dan gagal dengan akurasi sebesar 94%