Tên: Mai Huy

MSSV: 43.01.104.065

Số thứ tự: 08

a) Split the data set into a training set and a test set.

# Load thư viện ISLR
library(ISLR)
# set.seed dùng để tái tạo những vector random giống nhau theo tương ứng với giá trị được đưa vào hàm seed
set.seed(2)
# Sử dụng 1 nửa số lượng quan sát được random để sử dụng cho tập train 
train <- sample(1:nrow(Carseats), nrow(Carseats) / 2)
# Chia tập train
Carseats.train <- Carseats[train, ]
# Chia tập test chứa các quan sát còn lại ngoài tập train
Carseats.test <- Carseats[-train, ]

b) Fit a regression tree to the training set. Plot the tree, and interpret the results. What test error rate do you obtain ?

# Load thư viện dữ liệu tree
library(tree)
# Hàm tree dùng để tạo ra cây phân loại giúp dự đoán giá trị đầu ra là biến Sales và sử dụng tất cả các biến còn lại làm giá trị đầu vào trong tập train
tree.carseats <- tree(Sales ~ ., data = Carseats.train)
# Phân tích dữ liệu cây phân loại vừa được tạo
summary(tree.carseats)

Regression tree:
tree(formula = Sales ~ ., data = Carseats.train)
Variables actually used in tree construction:
[1] "Price"       "ShelveLoc"   "CompPrice"   "Age"         "Advertising" "Population" 
Number of terminal nodes:  14 
Residual mean deviance:  2.602 = 484 / 186 
Distribution of residuals:
    Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
-4.71700 -1.08700 -0.01026  0.00000  1.11300  4.06600 

Hàm summary liệt kê các biến internal nodes trong cây bao gồm các biến : “Price” “ShelveLoc” “CompPrice” “Age” “Advertising” “Population” , cho biết số lượng terminal nodes = 14, độ lệch chuẩn trung bình = 2.602 được tính thông qua tổng bình phương các lỗi của cây

Ngoài còn cho biết giá trị min, max , trung vị, tỉ lệ 25%, 75 % của sai số lỗi cho các nhánh

# Hiển thị cấu trúc cây đã được tạo
plot(tree.carseats)
# Hiển thị nhãn tên các node của cây, biến pretty = 0 là để bao gồm tên loại cho bất cứ giá trị định tính nào so với việc chỉ hiển thị các kí tự chữ cái cho mỗi loại
text(tree.carseats, pretty = 0)

# Tiến hành dự đoán trên tập test
yhat <- predict(tree.carseats, newdata = Carseats.test)
# Tính Mean Squared Error (MSE) của cây hồi quy
mean((yhat - Carseats.test$Sales)^2)
[1] 4.471569

MSE của tập test = 4.471569

c) Use cross-validation in order to determine the optimal level of tree complexity. Does pruning the tree improve the test error rate ?

# Hàm cv.tree thực hiện cross-validation để quyết định độ phức tạp tối ưu cho cây.
cv.carseats <- cv.tree(tree.carseats)
# Hiển thị đồ thị phân tán với x là số lượng terminal nodes và y là sai số lỗi cross validation
plot(cv.carseats$size, cv.carseats$dev, type = "b")

# Cắt tỉa cây còn 11 nodes
prune.carseats <- prune.tree(tree.carseats, best = 11)
# Hiển thị cấu trúc cây đã được tỉa còn 11 nodes
plot(prune.carseats)
# Hiển thị nhãn tên các node của cây, biến pretty = 0 là để bao gồm tên loại cho bất cứ giá trị định tính nào so với việc chỉ hiển thị các kí tự chữ cái cho mỗi loại
text(prune.carseats, pretty = 0)

# Dự đoán trên cây còn 11 nodes
yhat <- predict(prune.carseats, newdata = Carseats.test)
# Tính Mean Squared Error (MSE) của cây hồi quy đã cắt tỉa
mean((yhat - Carseats.test$Sales)^2)
[1] 4.644345

Chúng ta thấy rằng MSE đã tăng lên 4.644345

d) Use the bagging approach in order to analyze this data. What test MSE do you obtain? Use the importance() function to determine which variables are most important.

# Load thu7 viện randomForest
library("randomForest")
# Dùng random forest để train model với số lượng biến được lấy ở mỗi lần chia nhánh = 10, số lượng cây = 500
bag.carseats <- randomForest(Sales ~ ., data = Carseats.train, mtry = 10, ntree = 500, importance = TRUE)
# Tiến hành dự đoán trên tập test 
yhat.bag <- predict(bag.carseats, newdata = Carseats.test)
# Tính Mean Squared Error (MSE) 
mean((yhat.bag - Carseats.test$Sales)^2)
[1] 2.562442

Chúng ta thấy rằng dùng phương pháp bagging khiến MSE giảm còn 2.562442

# Hiển thị mức độ quan trọng của các biến
importance(bag.carseats)
               %IncMSE IncNodePurity
CompPrice   24.0384059    207.128682
Income       5.0615224     77.450201
Advertising 12.7636689    109.216356
Population   1.5579661     59.994608
Price       55.0603145    527.315416
ShelveLoc   42.8863387    292.641357
Age         10.2535921    118.582012
Education    1.5050452     39.717904
Urban       -0.4031245      8.684356
US           2.3690815      8.308509

Chúng ta kết luận rằng 2 biến Price và Shelveloc là 2 biến quan trọng nhất

e) Use random forests to analyze this data. What test error rate do you obtain ? Use the “importance()” function to determine which variables are most important. Describe the effect of m, the number of variables considered at each split, on the error rate obtained.

# Dùng random forest để train model với số lượng biến được lấy ở mỗi lần chia nhánh = 3, số lượng cây = 500
rf.carseats <- randomForest(Sales ~ ., data = Carseats.train, mtry = 3, ntree = 500, importance = TRUE)
# Tiến hành dự đoán trên tập test 
yhat.rf <- predict(rf.carseats, newdata = Carseats.test)
# Tính Mean Squared Error (MSE) 
mean((yhat.rf - Carseats.test$Sales)^2)
[1] 3.280936

Chúng ta thấy rằng MSE tăng lên 3.280936

# Hiển thị mức độ quan trọng của các biến
importance(rf.carseats)
               %IncMSE IncNodePurity
CompPrice   11.8402467     155.22418
Income       4.9417897     128.34762
Advertising 12.9703787     123.04064
Population  -1.5047249      99.83149
Price       34.8663319     398.85162
ShelveLoc   28.5648884     241.22555
Age          6.3564779     148.38824
Education    0.3142653      70.35479
Urban        0.8880883      13.30574
US           1.9629250      16.86138

Chúng ta kết luận rằng 2 biến Price và Shelveloc là 2 biến quan trọng nhất

LS0tDQp0aXRsZTogIkLDoGkgdOG6rXAgMV9UdeG6p24gNyINCm91dHB1dDogaHRtbF9ub3RlYm9vaw0KLS0tDQoNCiMjIyBUw6puOiBNYWkgSHV5DQojIyMgTVNTVjogNDMuMDEuMTA0LjA2NQ0KIyMjIFPhu5EgdGjhu6kgdOG7sTogMDgNCg0KIyMjIGEpIFNwbGl0IHRoZSBkYXRhIHNldCBpbnRvIGEgdHJhaW5pbmcgc2V0IGFuZCBhIHRlc3Qgc2V0Lg0KDQpgYGB7cn0NCiMgTG9hZCB0aMawIHZp4buHbiBJU0xSDQpsaWJyYXJ5KElTTFIpDQojIHNldC5zZWVkIGTDuW5nIMSR4buDIHTDoWkgdOG6oW8gbmjhu69uZyB2ZWN0b3IgcmFuZG9tIGdp4buRbmcgbmhhdSB0aGVvIHTGsMahbmcg4bupbmcgduG7m2kgZ2nDoSB0cuG7iyDEkcaw4bujYyDEkcawYSB2w6BvIGjDoG0gc2VlZA0Kc2V0LnNlZWQoMikNCiMgU+G7rSBk4bulbmcgMSBu4butYSBz4buRIGzGsOG7o25nIHF1YW4gc8OhdCDEkcaw4bujYyByYW5kb20gxJHhu4Mgc+G7rSBk4bulbmcgY2hvIHThuq1wIHRyYWluIA0KdHJhaW4gPC0gc2FtcGxlKDE6bnJvdyhDYXJzZWF0cyksIG5yb3coQ2Fyc2VhdHMpIC8gMikNCiMgQ2hpYSB04bqtcCB0cmFpbg0KQ2Fyc2VhdHMudHJhaW4gPC0gQ2Fyc2VhdHNbdHJhaW4sIF0NCiMgQ2hpYSB04bqtcCB0ZXN0IGNo4bupYSBjw6FjIHF1YW4gc8OhdCBjw7JuIGzhuqFpIG5nb8OgaSB04bqtcCB0cmFpbg0KQ2Fyc2VhdHMudGVzdCA8LSBDYXJzZWF0c1stdHJhaW4sIF0NCmBgYA0KDQojIyMgYikgRml0IGEgcmVncmVzc2lvbiB0cmVlIHRvIHRoZSB0cmFpbmluZyBzZXQuIFBsb3QgdGhlIHRyZWUsIGFuZCBpbnRlcnByZXQgdGhlIHJlc3VsdHMuIFdoYXQgdGVzdCBlcnJvciByYXRlIGRvIHlvdSBvYnRhaW4gPw0KDQpgYGB7cn0NCiMgTG9hZCB0aMawIHZp4buHbiBk4buvIGxp4buHdSB0cmVlDQpsaWJyYXJ5KHRyZWUpDQojIEjDoG0gdHJlZSBkw7luZyDEkeG7gyB04bqhbyByYSBjw6J5IHBow6JuIGxv4bqhaSBnacO6cCBk4buxIMSRb8OhbiBnacOhIHRy4buLIMSR4bqndSByYSBsw6AgYmnhur9uIFNhbGVzIHbDoCBz4butIGThu6VuZyB04bqldCBj4bqjIGPDoWMgYmnhur9uIGPDsm4gbOG6oWkgbMOgbSBnacOhIHRy4buLIMSR4bqndSB2w6BvIHRyb25nIHThuq1wIHRyYWluDQp0cmVlLmNhcnNlYXRzIDwtIHRyZWUoU2FsZXMgfiAuLCBkYXRhID0gQ2Fyc2VhdHMudHJhaW4pDQpgYGANCg0KYGBge3J9DQojIFBow6JuIHTDrWNoIGThu68gbGnhu4d1IGPDonkgcGjDom4gbG/huqFpIHbhu6thIMSRxrDhu6NjIHThuqFvDQpzdW1tYXJ5KHRyZWUuY2Fyc2VhdHMpDQpgYGANCg0KSMOgbSBzdW1tYXJ5IGxp4buHdCBrw6ogY8OhYyBiaeG6v24gaW50ZXJuYWwgbm9kZXMgdHJvbmcgY8OieSBiYW8gZ+G7k20gY8OhYyBiaeG6v24gOiAiUHJpY2UiICAiU2hlbHZlTG9jIiAgICJDb21wUHJpY2UiICAgIkFnZSIgICAgICAgICAiQWR2ZXJ0aXNpbmciICJQb3B1bGF0aW9uIiAsIGNobyBiaeG6v3Qgc+G7kSBsxrDhu6NuZyB0ZXJtaW5hbCBub2RlcyA9IDE0LCDEkeG7mSBs4buHY2ggY2h14bqpbiB0cnVuZyBiw6xuaCA9IDIuNjAyIMSRxrDhu6NjIHTDrW5oIHRow7RuZyBxdWEgdOG7lW5nIGLDrG5oIHBoxrDGoW5nIGPDoWMgbOG7l2kgY+G7p2EgY8OieQ0KDQpOZ2/DoGkgY8OybiBjaG8gYmnhur90IGdpw6EgdHLhu4sgbWluLCBtYXggLCB0cnVuZyB24buLLCB04buJIGzhu4cgMjUlLCA3NSAlIGPhu6dhIHNhaSBz4buRIGzhu5dpIGNobyBjw6FjIG5ow6FuaA0KDQpgYGB7cn0NCiMgSGnhu4NuIHRo4buLIGPhuqV1IHRyw7pjIGPDonkgxJHDoyDEkcaw4bujYyB04bqhbw0KcGxvdCh0cmVlLmNhcnNlYXRzKQ0KIyBIaeG7g24gdGjhu4sgbmjDo24gdMOqbiBjw6FjIG5vZGUgY+G7p2EgY8OieSwgYmnhur9uIHByZXR0eSA9IDAgbMOgIMSR4buDIGJhbyBn4buTbSB0w6puIGxv4bqhaSBjaG8gYuG6pXQgY+G7qSBnacOhIHRy4buLIMSR4buLbmggdMOtbmggbsOgbyBzbyB24bubaSB2aeG7h2MgY2jhu4kgaGnhu4NuIHRo4buLIGPDoWMga8OtIHThu7EgY2jhu68gY8OhaSBjaG8gbeG7l2kgbG/huqFpDQp0ZXh0KHRyZWUuY2Fyc2VhdHMsIHByZXR0eSA9IDApDQpgYGANCg0KYGBge3J9DQojIFRp4bq/biBow6BuaCBk4buxIMSRb8OhbiB0csOqbiB04bqtcCB0ZXN0DQp5aGF0IDwtIHByZWRpY3QodHJlZS5jYXJzZWF0cywgbmV3ZGF0YSA9IENhcnNlYXRzLnRlc3QpDQojIFTDrW5oIE1lYW4gU3F1YXJlZCBFcnJvciAoTVNFKSBj4bunYSBjw6J5IGjhu5NpIHF1eQ0KbWVhbigoeWhhdCAtIENhcnNlYXRzLnRlc3QkU2FsZXMpXjIpDQpgYGANCg0KTVNFIGPhu6dhIHThuq1wIHRlc3QgPSA0LjQ3MTU2OQ0KDQojIyMgYykgVXNlIGNyb3NzLXZhbGlkYXRpb24gaW4gb3JkZXIgdG8gZGV0ZXJtaW5lIHRoZSBvcHRpbWFsIGxldmVsIG9mIHRyZWUgY29tcGxleGl0eS4gRG9lcyBwcnVuaW5nIHRoZSB0cmVlIGltcHJvdmUgdGhlIHRlc3QgZXJyb3IgcmF0ZSA/DQoNCmBgYHtyfQ0KIyBIw6BtIGN2LnRyZWUgdGjhu7FjIGhp4buHbiBjcm9zcy12YWxpZGF0aW9uIMSR4buDIHF1eeG6v3QgxJHhu4tuaCDEkeG7mSBwaOG7qWMgdOG6oXAgdOG7kWkgxrB1IGNobyBjw6J5Lg0KY3YuY2Fyc2VhdHMgPC0gY3YudHJlZSh0cmVlLmNhcnNlYXRzKQ0KYGBgDQoNCmBgYHtyfQ0KIyBIaeG7g24gdGjhu4sgxJHhu5MgdGjhu4sgcGjDom4gdMOhbiB24bubaSB4IGzDoCBz4buRIGzGsOG7o25nIHRlcm1pbmFsIG5vZGVzIHbDoCB5IGzDoCBzYWkgc+G7kSBs4buXaSBjcm9zcyB2YWxpZGF0aW9uDQpwbG90KGN2LmNhcnNlYXRzJHNpemUsIGN2LmNhcnNlYXRzJGRldiwgdHlwZSA9ICJiIikNCmBgYA0KDQoNCg0KYGBge3J9DQojIEPhuq90IHThu4lhIGPDonkgY8OybiAxMSBub2Rlcw0KcHJ1bmUuY2Fyc2VhdHMgPC0gcHJ1bmUudHJlZSh0cmVlLmNhcnNlYXRzLCBiZXN0ID0gMTEpDQpgYGANCg0KDQpgYGB7cn0NCiMgSGnhu4NuIHRo4buLIGPhuqV1IHRyw7pjIGPDonkgxJHDoyDEkcaw4bujYyB04buJYSBjw7JuIDExIG5vZGVzDQpwbG90KHBydW5lLmNhcnNlYXRzKQ0KIyBIaeG7g24gdGjhu4sgbmjDo24gdMOqbiBjw6FjIG5vZGUgY+G7p2EgY8OieSwgYmnhur9uIHByZXR0eSA9IDAgbMOgIMSR4buDIGJhbyBn4buTbSB0w6puIGxv4bqhaSBjaG8gYuG6pXQgY+G7qSBnacOhIHRy4buLIMSR4buLbmggdMOtbmggbsOgbyBzbyB24bubaSB2aeG7h2MgY2jhu4kgaGnhu4NuIHRo4buLIGPDoWMga8OtIHThu7EgY2jhu68gY8OhaSBjaG8gbeG7l2kgbG/huqFpDQp0ZXh0KHBydW5lLmNhcnNlYXRzLCBwcmV0dHkgPSAwKQ0KYGBgDQoNCmBgYHtyfQ0KIyBE4buxIMSRb8OhbiB0csOqbiBjw6J5IGPDsm4gMTEgbm9kZXMNCnloYXQgPC0gcHJlZGljdChwcnVuZS5jYXJzZWF0cywgbmV3ZGF0YSA9IENhcnNlYXRzLnRlc3QpDQojIFTDrW5oIE1lYW4gU3F1YXJlZCBFcnJvciAoTVNFKSBj4bunYSBjw6J5IGjhu5NpIHF1eSDEkcOjIGPhuq90IHThu4lhDQptZWFuKCh5aGF0IC0gQ2Fyc2VhdHMudGVzdCRTYWxlcyleMikNCmBgYA0KDQpDaMO6bmcgdGEgdGjhuqV5IHLhurFuZyBNU0UgxJHDoyB0xINuZyBsw6puIDQuNjQ0MzQ1DQoNCg0KIyMjIGQpIFVzZSB0aGUgYmFnZ2luZyBhcHByb2FjaCBpbiBvcmRlciB0byBhbmFseXplIHRoaXMgZGF0YS4gV2hhdCB0ZXN0IE1TRSBkbyB5b3Ugb2J0YWluPyBVc2UgdGhlIGltcG9ydGFuY2UoKSBmdW5jdGlvbiB0byBkZXRlcm1pbmUgd2hpY2ggdmFyaWFibGVzIGFyZSBtb3N0IGltcG9ydGFudC4NCg0KYGBge3J9DQojIExvYWQgdGh1NyB2aeG7h24gcmFuZG9tRm9yZXN0DQpsaWJyYXJ5KCJyYW5kb21Gb3Jlc3QiKQ0KYGBgDQoNCg0KYGBge3J9DQojIETDuW5nIHJhbmRvbSBmb3Jlc3QgxJHhu4MgdHJhaW4gbW9kZWwgduG7m2kgc+G7kSBsxrDhu6NuZyBiaeG6v24gxJHGsOG7o2MgbOG6pXkg4bufIG3hu5dpIGzhuqduIGNoaWEgbmjDoW5oID0gMTAsIHPhu5EgbMaw4bujbmcgY8OieSA9IDUwMA0KYmFnLmNhcnNlYXRzIDwtIHJhbmRvbUZvcmVzdChTYWxlcyB+IC4sIGRhdGEgPSBDYXJzZWF0cy50cmFpbiwgbXRyeSA9IDEwLCBudHJlZSA9IDUwMCwgaW1wb3J0YW5jZSA9IFRSVUUpDQojIFRp4bq/biBow6BuaCBk4buxIMSRb8OhbiB0csOqbiB04bqtcCB0ZXN0IA0KeWhhdC5iYWcgPC0gcHJlZGljdChiYWcuY2Fyc2VhdHMsIG5ld2RhdGEgPSBDYXJzZWF0cy50ZXN0KQ0KIyBUw61uaCBNZWFuIFNxdWFyZWQgRXJyb3IgKE1TRSkgDQptZWFuKCh5aGF0LmJhZyAtIENhcnNlYXRzLnRlc3QkU2FsZXMpXjIpDQpgYGANCg0KQ2jDum5nIHRhIHRo4bqleSBy4bqxbmcgZMO5bmcgcGjGsMahbmcgcGjDoXAgYmFnZ2luZyBraGnhur9uIE1TRSBnaeG6o20gY8OybiAyLjU2MjQ0Mg0KDQpgYGB7cn0NCiMgSGnhu4NuIHRo4buLIG3hu6ljIMSR4buZIHF1YW4gdHLhu41uZyBj4bunYSBjw6FjIGJp4bq/bg0KaW1wb3J0YW5jZShiYWcuY2Fyc2VhdHMpDQpgYGANCg0KQ2jDum5nIHRhIGvhur90IGx14bqtbiBy4bqxbmcgMiBiaeG6v24gUHJpY2UgdsOgIFNoZWx2ZWxvYyBsw6AgMiBiaeG6v24gcXVhbiB0cuG7jW5nIG5o4bqldA0KDQojIyMgZSkgVXNlIHJhbmRvbSBmb3Jlc3RzIHRvIGFuYWx5emUgdGhpcyBkYXRhLiBXaGF0IHRlc3QgZXJyb3IgcmF0ZSBkbyB5b3Ugb2J0YWluID8gVXNlIHRoZSDigJxpbXBvcnRhbmNlKCnigJ0gZnVuY3Rpb24gdG8gZGV0ZXJtaW5lIHdoaWNoIHZhcmlhYmxlcyBhcmUgbW9zdCBpbXBvcnRhbnQuIERlc2NyaWJlIHRoZSBlZmZlY3Qgb2YgbSwgdGhlIG51bWJlciBvZiB2YXJpYWJsZXMgY29uc2lkZXJlZCBhdCBlYWNoIHNwbGl0LCBvbiB0aGUgZXJyb3IgcmF0ZSBvYnRhaW5lZC4NCg0KYGBge3J9DQojIETDuW5nIHJhbmRvbSBmb3Jlc3QgxJHhu4MgdHJhaW4gbW9kZWwgduG7m2kgc+G7kSBsxrDhu6NuZyBiaeG6v24gxJHGsOG7o2MgbOG6pXkg4bufIG3hu5dpIGzhuqduIGNoaWEgbmjDoW5oID0gMywgc+G7kSBsxrDhu6NuZyBjw6J5ID0gNTAwDQpyZi5jYXJzZWF0cyA8LSByYW5kb21Gb3Jlc3QoU2FsZXMgfiAuLCBkYXRhID0gQ2Fyc2VhdHMudHJhaW4sIG10cnkgPSAzLCBudHJlZSA9IDUwMCwgaW1wb3J0YW5jZSA9IFRSVUUpDQojIFRp4bq/biBow6BuaCBk4buxIMSRb8OhbiB0csOqbiB04bqtcCB0ZXN0IA0KeWhhdC5yZiA8LSBwcmVkaWN0KHJmLmNhcnNlYXRzLCBuZXdkYXRhID0gQ2Fyc2VhdHMudGVzdCkNCiMgVMOtbmggTWVhbiBTcXVhcmVkIEVycm9yIChNU0UpIA0KbWVhbigoeWhhdC5yZiAtIENhcnNlYXRzLnRlc3QkU2FsZXMpXjIpDQpgYGANCg0KQ2jDum5nIHRhIHRo4bqleSBy4bqxbmcgTVNFIHTEg25nIGzDqm4gMy4yODA5MzYNCg0KYGBge3J9DQojIEhp4buDbiB0aOG7iyBt4bupYyDEkeG7mSBxdWFuIHRy4buNbmcgY+G7p2EgY8OhYyBiaeG6v24NCmltcG9ydGFuY2UocmYuY2Fyc2VhdHMpDQpgYGANCg0KQ2jDum5nIHRhIGvhur90IGx14bqtbiBy4bqxbmcgMiBiaeG6v24gUHJpY2UgdsOgIFNoZWx2ZWxvYyBsw6AgMiBiaeG6v24gcXVhbiB0cuG7jW5nIG5o4bqldA==