Tên: Mai Huy

MSSV: 43.01.104.065

Số thứ tự: 08

Câu a) Create a training set consisting of the first 1,000 observations, and a test set consisting of the remaining observations.

# 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(1)
# Tập train gồm 1000 quan sát đầu
train <- 1:1000
# Gán lại biến purchase = 1 nếu mang giá trị 'Yes' và bằng 0 nếu là 'No'
Caravan$Purchase <- ifelse(Caravan$Purchase == "Yes", 1, 0)
# Tập train gồm 1000 quan sát đầu trong dữ liệu Caravan
Caravan.train <- Caravan[train, ]
# Các quan sát còn lại là tập test
Caravan.test <- Caravan[-train, ]

Câu b) Fit a boosting model to the training set with Purchase as the response and the other variables as predictors. Use 1,000 trees, and a shrinkage value of 0.01. Which predictors appear to be the most important?

# 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(1)
# Tạo mô hình hồi quy ổng quan boosting với biến đầu ra là Purchase, biến đầu vào là tất cả các biến còn lại, với số lượng cây là 1000, learning rate = 0.01, mô hình theo phân phối gaussian
boost.caravan <- gbm(Purchase ~ ., data = Caravan.train, distribution = "gaussian", n.trees = 1000, shrinkage = 0.01)
variable 50: PVRAAUT has no variation.variable 71: AVRAAUT has no variation.
# Phân tích mô hình boosting được tạo
summary(boost.caravan)

Hàm summary đưa ra bảng và biểu đồ biểu diễn độ quan trọng các biến

Ta thấy 2 biến “PPERSAUT” và “MKOOPKLA” có mức độ ảnh hưởng lớn nhất

Câu c) Use the boosting model to predict the response on the test data. Predict that a person will make a purchase if the estimated probability of purchase is greater than 20%. Form a confusion matrix. What fraction of the people predicted to make a purchase do in fact make one? How does this compare with the results obtained from applying KNN or logistic regression to this data set?

# Dùng mô hình boos.caravan ở trên để tự đoán tập Caravan.test với số lượng cậy là 1000, kiểu trả về 'response' là xác suất mà mô hình dự đoán
probs.test <- predict(boost.caravan, Caravan.test, n.trees = 1000, type = "response")
# Gán các giá trị dự đoán của mô hình, nếu xác suất lớn hơn 0.2 thì là 1, ngược lại là 0
pred.test <- ifelse(probs.test > 0.2, 1, 0)
# Dùng hàm table() để tạo ra một ma trận để quyết định xem có bao nhiêu quan sát được phân loại đúng, bao nhiêu bị phân loại sai
table(Caravan.test$Purchase, pred.test)
   pred.test
       0    1
  0 4493   40
  1  278   11

Tỉ lệ số người được dự đoán đúng là sẽ mua hàng là: 11/(4493+40+11+278) * 100 = 0.22

# Tạo mô hình logistic regression với biến đầu ra là Purchase, biến đầu vào là tất cả các biến còn lại
logit.caravan <- glm(Purchase ~ ., data = Caravan.train, family = "binomial")
glm.fit: fitted probabilities numerically 0 or 1 occurred
# Dùng mô hình logistic regression ở trên để tự đoán tập Caravan.test với số lượng cậy là 1000, kiểu trả về 'response' là xác suất mà mô hình dự đoán
probs.test2 <- predict(logit.caravan, Caravan.test, type = "response")
prediction from a rank-deficient fit may be misleading
# Gán các giá trị dự đoán của mô hình, nếu xác suất lớn hơn 0.2 thì là 1, ngược lại là 0
pred.test2 <- ifelse(probs.test > 0.2, 1, 0)
# Dùng hàm table() để tạo ra một ma trận để quyết định xem có bao nhiêu quan sát được phân loại đúng, bao nhiêu bị phân loại sai
table(Caravan.test$Purchase, pred.test2)
   pred.test2
       0    1
  0 4493   40
  1  278   11

Tỉ lệ số người được dự đoán đúng là sẽ mua hàng là: 11/(4493+40+11+278) * 100 = 0.22 tương tự mô hình boosting

LS0tDQp0aXRsZTogIkLDoGkgdOG6rXAgMl8gdHXhuqduIDEwIg0Kb3V0cHV0OiBodG1sX25vdGVib29rDQotLS0NCg0KIyMjIFTDqm46IE1haSBIdXkNCiMjIyBNU1NWOiA0My4wMS4xMDQuMDY1DQojIyMgU+G7kSB0aOG7qSB04buxOiAwOA0KDQojIyMgQ8OidSBhKSBDcmVhdGUgYSB0cmFpbmluZyBzZXQgY29uc2lzdGluZyBvZiB0aGUgZmlyc3QgMSwwMDAgb2JzZXJ2YXRpb25zLCBhbmQgYSB0ZXN0IHNldCBjb25zaXN0aW5nIG9mIHRoZSByZW1haW5pbmcgb2JzZXJ2YXRpb25zLg0KDQpgYGB7cn0NCiMgc2V0LnNlZWQgZMO5bmcgxJHhu4MgdMOhaSB04bqhbyBuaOG7r25nIHZlY3RvciByYW5kb20gZ2nhu5FuZyBuaGF1IHRoZW8gdMawxqFuZyDhu6luZyB24bubaSBnacOhIHRy4buLIMSRxrDhu6NjIMSRxrBhIHbDoG8gaMOgbSBzZWVkDQpzZXQuc2VlZCgxKQ0KIyBU4bqtcCB0cmFpbiBn4buTbSAxMDAwIHF1YW4gc8OhdCDEkeG6p3UNCnRyYWluIDwtIDE6MTAwMA0KIyBHw6FuIGzhuqFpIGJp4bq/biBwdXJjaGFzZSA9IDEgbuG6v3UgbWFuZyBnacOhIHRy4buLICdZZXMnIHbDoCBi4bqxbmcgMCBu4bq/dSBsw6AgJ05vJw0KQ2FyYXZhbiRQdXJjaGFzZSA8LSBpZmVsc2UoQ2FyYXZhbiRQdXJjaGFzZSA9PSAiWWVzIiwgMSwgMCkNCiMgVOG6rXAgdHJhaW4gZ+G7k20gMTAwMCBxdWFuIHPDoXQgxJHhuqd1IHRyb25nIGThu68gbGnhu4d1IENhcmF2YW4NCkNhcmF2YW4udHJhaW4gPC0gQ2FyYXZhblt0cmFpbiwgXQ0KIyBDw6FjIHF1YW4gc8OhdCBjw7JuIGzhuqFpIGzDoCB04bqtcCB0ZXN0DQpDYXJhdmFuLnRlc3QgPC0gQ2FyYXZhblstdHJhaW4sIF0NCg0KYGBgDQoNCiMjIyBDw6J1IGIpIEZpdCBhIGJvb3N0aW5nIG1vZGVsIHRvIHRoZSB0cmFpbmluZyBzZXQgd2l0aCBQdXJjaGFzZSBhcyB0aGUgcmVzcG9uc2UgYW5kIHRoZSBvdGhlciB2YXJpYWJsZXMgYXMgcHJlZGljdG9ycy4gVXNlIDEsMDAwIHRyZWVzLCBhbmQgYSBzaHJpbmthZ2UgdmFsdWUgb2YgMC4wMS4gV2hpY2ggcHJlZGljdG9ycyBhcHBlYXIgdG8gYmUgdGhlIG1vc3QgaW1wb3J0YW50Pw0KDQpgYGB7cn0NCiMgc2V0LnNlZWQgZMO5bmcgxJHhu4MgdMOhaSB04bqhbyBuaOG7r25nIHZlY3RvciByYW5kb20gZ2nhu5FuZyBuaGF1IHRoZW8gdMawxqFuZyDhu6luZyB24bubaSBnacOhIHRy4buLIMSRxrDhu6NjIMSRxrBhIHbDoG8gaMOgbSBzZWVkDQpzZXQuc2VlZCgxKQ0KIyBU4bqhbyBtw7QgaMOsbmggaOG7k2kgcXV5IOG7lW5nIHF1YW4gYm9vc3RpbmcgduG7m2kgYmnhur9uIMSR4bqndSByYSBsw6AgUHVyY2hhc2UsIGJp4bq/biDEkeG6p3UgdsOgbyBsw6AgdOG6pXQgY+G6oyBjw6FjIGJp4bq/biBjw7JuIGzhuqFpLCB24bubaSBz4buRIGzGsOG7o25nIGPDonkgbMOgIDEwMDAsIGxlYXJuaW5nIHJhdGUgPSAwLjAxLCBtw7QgaMOsbmggdGhlbyBwaMOibiBwaOG7kWkgZ2F1c3NpYW4NCmJvb3N0LmNhcmF2YW4gPC0gZ2JtKFB1cmNoYXNlIH4gLiwgZGF0YSA9IENhcmF2YW4udHJhaW4sIGRpc3RyaWJ1dGlvbiA9ICJnYXVzc2lhbiIsIG4udHJlZXMgPSAxMDAwLCBzaHJpbmthZ2UgPSAwLjAxKQ0KDQpgYGANCmBgYHtyfQ0KIyBQaMOibiB0w61jaCBtw7QgaMOsbmggYm9vc3RpbmcgxJHGsOG7o2MgdOG6oW8NCnN1bW1hcnkoYm9vc3QuY2FyYXZhbikNCmBgYA0KDQpIw6BtIHN1bW1hcnkgxJHGsGEgcmEgYuG6o25nIHbDoCBiaeG7g3UgxJHhu5MgYmnhu4N1IGRp4buFbiDEkeG7mSBxdWFuIHRy4buNbmcgY8OhYyBiaeG6v24NCg0KVGEgdGjhuqV5IDIgYmnhur9uICJQUEVSU0FVVCIgdsOgICJNS09PUEtMQSIgY8OzIG3hu6ljIMSR4buZIOG6o25oIGjGsOG7n25nIGzhu5tuIG5o4bqldA0KDQojIyMgQ8OidSBjKSBVc2UgdGhlIGJvb3N0aW5nIG1vZGVsIHRvIHByZWRpY3QgdGhlIHJlc3BvbnNlIG9uIHRoZSB0ZXN0IGRhdGEuIFByZWRpY3QgdGhhdCBhIHBlcnNvbiB3aWxsIG1ha2UgYSBwdXJjaGFzZSBpZiB0aGUgZXN0aW1hdGVkIHByb2JhYmlsaXR5IG9mIHB1cmNoYXNlIGlzIGdyZWF0ZXIgdGhhbiAyMCUuIEZvcm0gYSBjb25mdXNpb24gbWF0cml4LiBXaGF0IGZyYWN0aW9uIG9mIHRoZSBwZW9wbGUgcHJlZGljdGVkIHRvIG1ha2UgYSBwdXJjaGFzZSBkbyBpbiBmYWN0IG1ha2Ugb25lPyBIb3cgZG9lcyB0aGlzIGNvbXBhcmUgd2l0aCB0aGUgcmVzdWx0cyBvYnRhaW5lZCBmcm9tIGFwcGx5aW5nIEtOTiBvciBsb2dpc3RpYyByZWdyZXNzaW9uIHRvIHRoaXMgZGF0YSBzZXQ/DQoNCmBgYHtyfQ0KIyBEw7luZyBtw7QgaMOsbmggYm9vcy5jYXJhdmFuIOG7nyB0csOqbiDEkeG7gyB04buxIMSRb8OhbiB04bqtcCBDYXJhdmFuLnRlc3QgduG7m2kgc+G7kSBsxrDhu6NuZyBj4bqteSBsw6AgMTAwMCwga2nhu4N1IHRy4bqjIHbhu4EgJ3Jlc3BvbnNlJyBsw6AgeMOhYyBzdeG6pXQgbcOgIG3DtCBow6xuaCBk4buxIMSRb8Ohbg0KcHJvYnMudGVzdCA8LSBwcmVkaWN0KGJvb3N0LmNhcmF2YW4sIENhcmF2YW4udGVzdCwgbi50cmVlcyA9IDEwMDAsIHR5cGUgPSAicmVzcG9uc2UiKQ0KIyBHw6FuIGPDoWMgZ2nDoSB0cuG7iyBk4buxIMSRb8OhbiBj4bunYSBtw7QgaMOsbmgsIG7hur91IHjDoWMgc3XhuqV0IGzhu5tuIGjGoW4gMC4yIHRow6wgbMOgIDEsIG5nxrDhu6NjIGzhuqFpIGzDoCAwDQpwcmVkLnRlc3QgPC0gaWZlbHNlKHByb2JzLnRlc3QgPiAwLjIsIDEsIDApDQojIETDuW5nIGjDoG0gdGFibGUoKSDEkeG7gyB04bqhbyByYSBt4buZdCBtYSB0cuG6rW4gxJHhu4MgcXV54bq/dCDEkeG7i25oIHhlbSBjw7MgYmFvIG5oacOqdSBxdWFuIHPDoXQgxJHGsOG7o2MgcGjDom4gbG/huqFpIMSRw7puZywgYmFvIG5oacOqdSBi4buLIHBow6JuIGxv4bqhaSBzYWkNCnRhYmxlKENhcmF2YW4udGVzdCRQdXJjaGFzZSwgcHJlZC50ZXN0KQ0KYGBgDQoNClThu4kgbOG7hyBz4buRIG5nxrDhu51pIMSRxrDhu6NjIGThu7EgxJFvw6FuIMSRw7puZyBsw6Agc+G6vSBtdWEgaMOgbmcgbMOgOiAxMS8oNDQ5Mys0MCsxMSsyNzgpICogMTAwID0gMC4yMg0KDQpgYGB7cn0NCiMgVOG6oW8gbcO0IGjDrG5oIGxvZ2lzdGljIHJlZ3Jlc3Npb24gduG7m2kgYmnhur9uIMSR4bqndSByYSBsw6AgUHVyY2hhc2UsIGJp4bq/biDEkeG6p3UgdsOgbyBsw6AgdOG6pXQgY+G6oyBjw6FjIGJp4bq/biBjw7JuIGzhuqFpDQpsb2dpdC5jYXJhdmFuIDwtIGdsbShQdXJjaGFzZSB+IC4sIGRhdGEgPSBDYXJhdmFuLnRyYWluLCBmYW1pbHkgPSAiYmlub21pYWwiKQ0KYGBgDQoNCmBgYHtyfQ0KIyBEw7luZyBtw7QgaMOsbmggbG9naXN0aWMgcmVncmVzc2lvbiDhu58gdHLDqm4gxJHhu4MgdOG7sSDEkW/DoW4gdOG6rXAgQ2FyYXZhbi50ZXN0IHbhu5tpIHPhu5EgbMaw4bujbmcgY+G6rXkgbMOgIDEwMDAsIGtp4buDdSB0cuG6oyB24buBICdyZXNwb25zZScgbMOgIHjDoWMgc3XhuqV0IG3DoCBtw7QgaMOsbmggZOG7sSDEkW/DoW4NCnByb2JzLnRlc3QyIDwtIHByZWRpY3QobG9naXQuY2FyYXZhbiwgQ2FyYXZhbi50ZXN0LCB0eXBlID0gInJlc3BvbnNlIikNCmBgYA0KDQpgYGB7cn0NCiMgR8OhbiBjw6FjIGdpw6EgdHLhu4sgZOG7sSDEkW/DoW4gY+G7p2EgbcO0IGjDrG5oLCBu4bq/dSB4w6FjIHN14bqldCBs4bubbiBoxqFuIDAuMiB0aMOsIGzDoCAxLCBuZ8aw4bujYyBs4bqhaSBsw6AgMA0KcHJlZC50ZXN0MiA8LSBpZmVsc2UocHJvYnMudGVzdCA+IDAuMiwgMSwgMCkNCiMgRMO5bmcgaMOgbSB0YWJsZSgpIMSR4buDIHThuqFvIHJhIG3hu5l0IG1hIHRy4bqtbiDEkeG7gyBxdXnhur90IMSR4buLbmggeGVtIGPDsyBiYW8gbmhpw6p1IHF1YW4gc8OhdCDEkcaw4bujYyBwaMOibiBsb+G6oWkgxJHDum5nLCBiYW8gbmhpw6p1IGLhu4sgcGjDom4gbG/huqFpIHNhaQ0KdGFibGUoQ2FyYXZhbi50ZXN0JFB1cmNoYXNlLCBwcmVkLnRlc3QyKQ0KYGBgDQoNClThu4kgbOG7hyBz4buRIG5nxrDhu51pIMSRxrDhu6NjIGThu7EgxJFvw6FuIMSRw7puZyBsw6Agc+G6vSBtdWEgaMOgbmcgbMOgOiAxMS8oNDQ5Mys0MCsxMSsyNzgpICogMTAwID0gMC4yMiB0xrDGoW5nIHThu7EgbcO0IGjDrG5oIGJvb3N0aW5nDQo=