Teoría

El Bosque Aleatorio es un algoritmo de aprendizaje automatico que combina el resultado de multiples arboles de decision para llegar a un resultado optimo.

Ejemplo 1 . Melbourne

En esta base de datos tenemos los precios de mas de 13,000 casas en la ciudad de Melbourne:

Instalar paquetes y llamar librerias 

library(tidyverse)
## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr     1.1.4     ✔ readr     2.1.5
## ✔ forcats   1.0.0     ✔ stringr   1.5.1
## ✔ ggplot2   3.5.2     ✔ tibble    3.3.0
## ✔ lubridate 1.9.4     ✔ tidyr     1.3.1
## ✔ purrr     1.1.0     
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors
library(rpart)
#install.packages("randomForest")
library(randomForest)
## randomForest 4.7-1.2
## Type rfNews() to see new features/changes/bug fixes.
## 
## Attaching package: 'randomForest'
## 
## The following object is masked from 'package:dplyr':
## 
##     combine
## 
## The following object is masked from 'package:ggplot2':
## 
##     margin
library(rpart.plot)
#install.packages("modelr")
library(modelr)
library(caret)
## Loading required package: lattice
## 
## Attaching package: 'caret'
## 
## The following object is masked from 'package:purrr':
## 
##     lift

Importar la base de datos 

df <- read.csv("/Users/fedezorrilla/Downloads/melbourne.csv")
head(df)
##       Suburb          Address Rooms Type   Price Method SellerG      Date
## 1 Abbotsford     85 Turner St     2    h 1480000      S  Biggin 3/12/2016
## 2 Abbotsford  25 Bloomburg St     2    h 1035000      S  Biggin 4/02/2016
## 3 Abbotsford     5 Charles St     3    h 1465000     SP  Biggin 4/03/2017
## 4 Abbotsford 40 Federation La     3    h  850000     PI  Biggin 4/03/2017
## 5 Abbotsford      55a Park St     4    h 1600000     VB  Nelson 4/06/2016
## 6 Abbotsford   129 Charles St     2    h  941000      S  Jellis 7/05/2016
##   Distance Postcode Bedroom2 Bathroom Car Landsize BuildingArea YearBuilt
## 1      2.5     3067        2        1   1      202           NA        NA
## 2      2.5     3067        2        1   0      156           79      1900
## 3      2.5     3067        3        2   0      134          150      1900
## 4      2.5     3067        3        2   1       94           NA        NA
## 5      2.5     3067        3        1   2      120          142      2014
## 6      2.5     3067        2        1   0      181           NA        NA
##   CouncilArea Lattitude Longtitude            Regionname Propertycount
## 1       Yarra  -37.7996   144.9984 Northern Metropolitan          4019
## 2       Yarra  -37.8079   144.9934 Northern Metropolitan          4019
## 3       Yarra  -37.8093   144.9944 Northern Metropolitan          4019
## 4       Yarra  -37.7969   144.9969 Northern Metropolitan          4019
## 5       Yarra  -37.8072   144.9941 Northern Metropolitan          4019
## 6       Yarra  -37.8041   144.9953 Northern Metropolitan          4019

Entenderla base de datos 

summary(df)
##     Suburb            Address              Rooms            Type          
##  Length:13580       Length:13580       Min.   : 1.000   Length:13580      
##  Class :character   Class :character   1st Qu.: 2.000   Class :character  
##  Mode  :character   Mode  :character   Median : 3.000   Mode  :character  
##                                        Mean   : 2.938                     
##                                        3rd Qu.: 3.000                     
##                                        Max.   :10.000                     
##                                                                           
##      Price            Method            SellerG              Date          
##  Min.   :  85000   Length:13580       Length:13580       Length:13580      
##  1st Qu.: 650000   Class :character   Class :character   Class :character  
##  Median : 903000   Mode  :character   Mode  :character   Mode  :character  
##  Mean   :1075684                                                           
##  3rd Qu.:1330000                                                           
##  Max.   :9000000                                                           
##                                                                            
##     Distance        Postcode       Bedroom2         Bathroom    
##  Min.   : 0.00   Min.   :3000   Min.   : 0.000   Min.   :0.000  
##  1st Qu.: 6.10   1st Qu.:3044   1st Qu.: 2.000   1st Qu.:1.000  
##  Median : 9.20   Median :3084   Median : 3.000   Median :1.000  
##  Mean   :10.14   Mean   :3105   Mean   : 2.915   Mean   :1.534  
##  3rd Qu.:13.00   3rd Qu.:3148   3rd Qu.: 3.000   3rd Qu.:2.000  
##  Max.   :48.10   Max.   :3977   Max.   :20.000   Max.   :8.000  
##                                                                 
##       Car           Landsize         BuildingArea     YearBuilt   
##  Min.   : 0.00   Min.   :     0.0   Min.   :    0   Min.   :1196  
##  1st Qu.: 1.00   1st Qu.:   177.0   1st Qu.:   93   1st Qu.:1940  
##  Median : 2.00   Median :   440.0   Median :  126   Median :1970  
##  Mean   : 1.61   Mean   :   558.4   Mean   :  152   Mean   :1965  
##  3rd Qu.: 2.00   3rd Qu.:   651.0   3rd Qu.:  174   3rd Qu.:1999  
##  Max.   :10.00   Max.   :433014.0   Max.   :44515   Max.   :2018  
##  NA's   :62                         NA's   :6450    NA's   :5375  
##  CouncilArea          Lattitude        Longtitude     Regionname       
##  Length:13580       Min.   :-38.18   Min.   :144.4   Length:13580      
##  Class :character   1st Qu.:-37.86   1st Qu.:144.9   Class :character  
##  Mode  :character   Median :-37.80   Median :145.0   Mode  :character  
##                     Mean   :-37.81   Mean   :145.0                     
##                     3rd Qu.:-37.76   3rd Qu.:145.1                     
##                     Max.   :-37.41   Max.   :145.5                     
##                                                                        
##  Propertycount  
##  Min.   :  249  
##  1st Qu.: 4380  
##  Median : 6555  
##  Mean   : 7454  
##  3rd Qu.:10331  
##  Max.   :21650  
## 
str(df)
## 'data.frame':    13580 obs. of  21 variables:
##  $ Suburb       : chr  "Abbotsford" "Abbotsford" "Abbotsford" "Abbotsford" ...
##  $ Address      : chr  "85 Turner St" "25 Bloomburg St" "5 Charles St" "40 Federation La" ...
##  $ Rooms        : int  2 2 3 3 4 2 3 2 1 2 ...
##  $ Type         : chr  "h" "h" "h" "h" ...
##  $ Price        : num  1480000 1035000 1465000 850000 1600000 ...
##  $ Method       : chr  "S" "S" "SP" "PI" ...
##  $ SellerG      : chr  "Biggin" "Biggin" "Biggin" "Biggin" ...
##  $ Date         : chr  "3/12/2016" "4/02/2016" "4/03/2017" "4/03/2017" ...
##  $ Distance     : num  2.5 2.5 2.5 2.5 2.5 2.5 2.5 2.5 2.5 2.5 ...
##  $ Postcode     : num  3067 3067 3067 3067 3067 ...
##  $ Bedroom2     : num  2 2 3 3 3 2 4 2 1 3 ...
##  $ Bathroom     : num  1 1 2 2 1 1 2 1 1 1 ...
##  $ Car          : num  1 0 0 1 2 0 0 2 1 2 ...
##  $ Landsize     : num  202 156 134 94 120 181 245 256 0 220 ...
##  $ BuildingArea : num  NA 79 150 NA 142 NA 210 107 NA 75 ...
##  $ YearBuilt    : num  NA 1900 1900 NA 2014 ...
##  $ CouncilArea  : chr  "Yarra" "Yarra" "Yarra" "Yarra" ...
##  $ Lattitude    : num  -37.8 -37.8 -37.8 -37.8 -37.8 ...
##  $ Longtitude   : num  145 145 145 145 145 ...
##  $ Regionname   : chr  "Northern Metropolitan" "Northern Metropolitan" "Northern Metropolitan" "Northern Metropolitan" ...
##  $ Propertycount: num  4019 4019 4019 4019 4019 ...
df <- na.omit(df)

Arbol de decisión

arbol <- rpart(Price ~ Rooms + Distance + Bathroom + Bedroom2 + Car + Landsize + BuildingArea + Propertycount + YearBuilt, data=df)
plot(arbol, uniform =TRUE)
text(arbol, cex=.6)

predict(arbol,head(df))
##       2       3       5       7       8      10 
## 1095996 1562641 1070605 2422140 1095996 1095996
head(df$Price)
## [1] 1035000 1465000 1600000 1876000 1636000 1097000
prueba_arbol <- head(df)

mae_arbol <- mae(arbol, prueba_arbol)

Bosques Aleatorios 

set.seed(123)
renglones_entrenamiento <- createDataPartition(df$Price, p=0.8, list=FALSE)
entrenamiento <- df[renglones_entrenamiento, ]
prueba <- df[-renglones_entrenamiento, ]


rf <- randomForest(Price ~ Rooms + Distance + Bathroom + Bedroom2 + Car + Landsize + BuildingArea + Propertycount + YearBuilt, data=entrenamiento, ntree=500, mtry=3, importance=TRUE)

resultado_entrenamiento <- predict(rf, entrenamiento)
resultado_prueba <- predict(rf,prueba)

mae_rf <- mae(rf,prueba)

resultados <- tibble(Modelo = c("Árbol de Decisión","Bosque Aleatorio"), MAE = c(mae_arbol, mae_rf))
resultados
## # A tibble: 2 × 2
##   Modelo                MAE
##   <chr>               <dbl>
## 1 Árbol de Decisión 295863.
## 2 Bosque Aleatorio  212669.

Ejercicio 1. Rendimiento Automotriz

Importar la base de datos 

df <- mtcars
str(df)
## 'data.frame':    32 obs. of  11 variables:
##  $ mpg : num  21 21 22.8 21.4 18.7 18.1 14.3 24.4 22.8 19.2 ...
##  $ cyl : num  6 6 4 6 8 6 8 4 4 6 ...
##  $ disp: num  160 160 108 258 360 ...
##  $ hp  : num  110 110 93 110 175 105 245 62 95 123 ...
##  $ drat: num  3.9 3.9 3.85 3.08 3.15 2.76 3.21 3.69 3.92 3.92 ...
##  $ wt  : num  2.62 2.88 2.32 3.21 3.44 ...
##  $ qsec: num  16.5 17 18.6 19.4 17 ...
##  $ vs  : num  0 0 1 1 0 1 0 1 1 1 ...
##  $ am  : num  1 1 1 0 0 0 0 0 0 0 ...
##  $ gear: num  4 4 4 3 3 3 3 4 4 4 ...
##  $ carb: num  4 4 1 1 2 1 4 2 2 4 ...

Arbol 

arbol <- rpart(mpg ~ cyl + disp + hp + drat + wt + qsec + gear + carb, data=df)
plot(arbol, uniform =TRUE)
text(arbol, cex=.6)

predict(arbol,head(df))
##         Mazda RX4     Mazda RX4 Wag        Datsun 710    Hornet 4 Drive 
##          18.26429          18.26429          26.66364          18.26429 
## Hornet Sportabout           Valiant 
##          18.26429          18.26429
head(df$mpg)
## [1] 21.0 21.0 22.8 21.4 18.7 18.1
prueba_arbol <- head(df)

mae_arbol <- mae(arbol, prueba_arbol)

Bosque Aleatorio 

set.seed(123)
renglones_entrenamiento <- createDataPartition(df$mpg, p=0.8, list=FALSE)
entrenamiento <- df[renglones_entrenamiento, ]
prueba <- df[-renglones_entrenamiento, ]


rf <- randomForest(mpg ~ cyl + disp + hp + drat + wt + qsec + gear + carb, data=entrenamiento, ntree=500, mtry=3, importance=TRUE)

resultado_entrenamiento <- predict(rf, entrenamiento)
resultado_prueba <- predict(rf,prueba)

mae_rf <- mae(rf,prueba)

resultados <- tibble(Modelo = c("Árbol de Decisión","Bosque Aleatorio"), MAE = c(mae_arbol, mae_rf))
resultados
## # A tibble: 2 × 2
##   Modelo              MAE
##   <chr>             <dbl>
## 1 Árbol de Decisión  2.18
## 2 Bosque Aleatorio   1.75
LS0tCnRpdGxlOiAiQm9zcXVlcyBBbGVhdG9yaW9zIgphdXRob3I6ICJGZWRlcmljbyBab3JyaWxsYSIKZGF0ZTogIjIwMjUtMDgtMjAiCm91dHB1dDogCiAgaHRtbF9kb2N1bWVudDoKICAgIHRvYzogdHJ1ZQogICAgdG9jX2Zsb2F0OiB0cnVlCiAgICBjb2RlX2Rvd25sb2FkOiBUUlVFCiAgICB0aGVtZTogam91cm5hbAotLS0KCmBgYHtyIHNldHVwLCBpbmNsdWRlPUZBTFNFfQprbml0cjo6b3B0c19jaHVuayRzZXQoZWNobyA9IFRSVUUpCmBgYAoKIyA8c3BhbiBzdHlsZT0iY29sb3I6YnJvd247Ij4gVGVvcsOtYSA8L3NwYW4+IAoKRWwgKipCb3NxdWUgQWxlYXRvcmlvKiogZXMgdW4gYWxnb3JpdG1vIGRlIGFwcmVuZGl6YWplIGF1dG9tYXRpY28gcXVlIGNvbWJpbmEgZWwgcmVzdWx0YWRvIGRlIG11bHRpcGxlcyBhcmJvbGVzIGRlIGRlY2lzaW9uIHBhcmEgbGxlZ2FyIGEgdW4gcmVzdWx0YWRvIG9wdGltby4KCiMgPHNwYW4gc3R5bGU9ImNvbG9yOmJyb3duOyI+IEVqZW1wbG8gMSAuIE1lbGJvdXJuZSA8L3NwYW4+IAoKRW4gZXN0YSBiYXNlIGRlIGRhdG9zIHRlbmVtb3MgbG9zIHByZWNpb3MgZGUgbWFzIGRlIDEzLDAwMCBjYXNhcyBlbiBsYSBjaXVkYWQgZGUgTWVsYm91cm5lOiAKCiMgPHNwYW4gc3R5bGU9ImNvbG9yOmJyb3duOyI+IEluc3RhbGFyIHBhcXVldGVzIHkgbGxhbWFyIGxpYnJlcmlhcyA8L3NwYW4+IAoKYGBge3J9CmxpYnJhcnkodGlkeXZlcnNlKQpsaWJyYXJ5KHJwYXJ0KQojaW5zdGFsbC5wYWNrYWdlcygicmFuZG9tRm9yZXN0IikKbGlicmFyeShyYW5kb21Gb3Jlc3QpCmxpYnJhcnkocnBhcnQucGxvdCkKI2luc3RhbGwucGFja2FnZXMoIm1vZGVsciIpCmxpYnJhcnkobW9kZWxyKQpsaWJyYXJ5KGNhcmV0KQpgYGAKCgojIDxzcGFuIHN0eWxlPSJjb2xvcjpicm93bjsiPiBJbXBvcnRhciBsYSBiYXNlIGRlIGRhdG9zIDwvc3Bhbj4gCmBgYHtyfQpkZiA8LSByZWFkLmNzdigiL1VzZXJzL2ZlZGV6b3JyaWxsYS9Eb3dubG9hZHMvbWVsYm91cm5lLmNzdiIpCmhlYWQoZGYpCmBgYAoKIyA8c3BhbiBzdHlsZT0iY29sb3I6YnJvd247Ij4gRW50ZW5kZXJsYSBiYXNlIGRlIGRhdG9zIDwvc3Bhbj4gCmBgYHtyfQpzdW1tYXJ5KGRmKQpzdHIoZGYpCmRmIDwtIG5hLm9taXQoZGYpCmBgYAoKCiMgPHNwYW4gc3R5bGU9ImNvbG9yOmJyb3duOyI+IEFyYm9sIGRlIGRlY2lzacOzbjwvc3Bhbj4gCmBgYHtyfQphcmJvbCA8LSBycGFydChQcmljZSB+IFJvb21zICsgRGlzdGFuY2UgKyBCYXRocm9vbSArIEJlZHJvb20yICsgQ2FyICsgTGFuZHNpemUgKyBCdWlsZGluZ0FyZWEgKyBQcm9wZXJ0eWNvdW50ICsgWWVhckJ1aWx0LCBkYXRhPWRmKQpwbG90KGFyYm9sLCB1bmlmb3JtID1UUlVFKQp0ZXh0KGFyYm9sLCBjZXg9LjYpCgpwcmVkaWN0KGFyYm9sLGhlYWQoZGYpKQpoZWFkKGRmJFByaWNlKQpwcnVlYmFfYXJib2wgPC0gaGVhZChkZikKCm1hZV9hcmJvbCA8LSBtYWUoYXJib2wsIHBydWViYV9hcmJvbCkKYGBgCgojIDxzcGFuIHN0eWxlPSJjb2xvcjpicm93bjsiPiBCb3NxdWVzIEFsZWF0b3Jpb3MgPC9zcGFuPiAKYGBge3J9CnNldC5zZWVkKDEyMykKcmVuZ2xvbmVzX2VudHJlbmFtaWVudG8gPC0gY3JlYXRlRGF0YVBhcnRpdGlvbihkZiRQcmljZSwgcD0wLjgsIGxpc3Q9RkFMU0UpCmVudHJlbmFtaWVudG8gPC0gZGZbcmVuZ2xvbmVzX2VudHJlbmFtaWVudG8sIF0KcHJ1ZWJhIDwtIGRmWy1yZW5nbG9uZXNfZW50cmVuYW1pZW50bywgXQoKCnJmIDwtIHJhbmRvbUZvcmVzdChQcmljZSB+IFJvb21zICsgRGlzdGFuY2UgKyBCYXRocm9vbSArIEJlZHJvb20yICsgQ2FyICsgTGFuZHNpemUgKyBCdWlsZGluZ0FyZWEgKyBQcm9wZXJ0eWNvdW50ICsgWWVhckJ1aWx0LCBkYXRhPWVudHJlbmFtaWVudG8sIG50cmVlPTUwMCwgbXRyeT0zLCBpbXBvcnRhbmNlPVRSVUUpCgpyZXN1bHRhZG9fZW50cmVuYW1pZW50byA8LSBwcmVkaWN0KHJmLCBlbnRyZW5hbWllbnRvKQpyZXN1bHRhZG9fcHJ1ZWJhIDwtIHByZWRpY3QocmYscHJ1ZWJhKQoKbWFlX3JmIDwtIG1hZShyZixwcnVlYmEpCgpyZXN1bHRhZG9zIDwtIHRpYmJsZShNb2RlbG8gPSBjKCLDgXJib2wgZGUgRGVjaXNpw7NuIiwiQm9zcXVlIEFsZWF0b3JpbyIpLCBNQUUgPSBjKG1hZV9hcmJvbCwgbWFlX3JmKSkKcmVzdWx0YWRvcwpgYGAKCgoKCiMgPHNwYW4gc3R5bGU9ImNvbG9yOmJyb3duOyI+IEVqZXJjaWNpbyAxLiBSZW5kaW1pZW50byBBdXRvbW90cml6PC9zcGFuPiAKCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjpicm93bjsiPiBJbXBvcnRhciBsYSBiYXNlIGRlIGRhdG9zIDwvc3Bhbj4gCmBgYHtyfQpkZiA8LSBtdGNhcnMKYGBgCgpgYGB7cn0Kc3RyKGRmKQpgYGAKCgoKIyMgPHNwYW4gc3R5bGU9ImNvbG9yOmJyb3duOyI+IEFyYm9sIDwvc3Bhbj4gCmBgYHtyfQphcmJvbCA8LSBycGFydChtcGcgfiBjeWwgKyBkaXNwICsgaHAgKyBkcmF0ICsgd3QgKyBxc2VjICsgZ2VhciArIGNhcmIsIGRhdGE9ZGYpCnBsb3QoYXJib2wsIHVuaWZvcm0gPVRSVUUpCnRleHQoYXJib2wsIGNleD0uNikKCnByZWRpY3QoYXJib2wsaGVhZChkZikpCmhlYWQoZGYkbXBnKQpwcnVlYmFfYXJib2wgPC0gaGVhZChkZikKCm1hZV9hcmJvbCA8LSBtYWUoYXJib2wsIHBydWViYV9hcmJvbCkKYGBgCgoKIyMgPHNwYW4gc3R5bGU9ImNvbG9yOmJyb3duOyI+IEJvc3F1ZSBBbGVhdG9yaW8gPC9zcGFuPiAKCmBgYHtyfQpzZXQuc2VlZCgxMjMpCnJlbmdsb25lc19lbnRyZW5hbWllbnRvIDwtIGNyZWF0ZURhdGFQYXJ0aXRpb24oZGYkbXBnLCBwPTAuOCwgbGlzdD1GQUxTRSkKZW50cmVuYW1pZW50byA8LSBkZltyZW5nbG9uZXNfZW50cmVuYW1pZW50bywgXQpwcnVlYmEgPC0gZGZbLXJlbmdsb25lc19lbnRyZW5hbWllbnRvLCBdCgoKcmYgPC0gcmFuZG9tRm9yZXN0KG1wZyB+IGN5bCArIGRpc3AgKyBocCArIGRyYXQgKyB3dCArIHFzZWMgKyBnZWFyICsgY2FyYiwgZGF0YT1lbnRyZW5hbWllbnRvLCBudHJlZT01MDAsIG10cnk9MywgaW1wb3J0YW5jZT1UUlVFKQoKcmVzdWx0YWRvX2VudHJlbmFtaWVudG8gPC0gcHJlZGljdChyZiwgZW50cmVuYW1pZW50bykKcmVzdWx0YWRvX3BydWViYSA8LSBwcmVkaWN0KHJmLHBydWViYSkKCm1hZV9yZiA8LSBtYWUocmYscHJ1ZWJhKQoKcmVzdWx0YWRvcyA8LSB0aWJibGUoTW9kZWxvID0gYygiw4FyYm9sIGRlIERlY2lzacOzbiIsIkJvc3F1ZSBBbGVhdG9yaW8iKSwgTUFFID0gYyhtYWVfYXJib2wsIG1hZV9yZikpCnJlc3VsdGFkb3MKYGBgCgoKCgoKCgoKCgo=