Caso de estudio :Predicción de Ventas

En este Rpubs se reforzarán algunos conceptos como el algoritmo de particionamiento recursivo, el cálculo de impureza y ganancia de información, los hiperparámetros, la poda y la predicción. Utilizaremos un conjunto de datos que contiene información sobre la inversión en publicidad en televisión, radio y periódicos, así como las ventas correspondientes del producto en 200 mercados diferentes. Aplicaremos el algoritmo de árbol de regresión para predecir las ventas del producto considerando los gastos publicitarios en diferentes medios.

Archivo : Advertising.csv

Varibles :

  • TV: Presupuesto publicitario en televisión.

  • Radio: Presupuesto publicitario en radio.

  • Newspaper: Presupuesto publicitario en periódicos.

  • Sales: Cantidad de ventas de productos.

Carga las bibliotecas necesarias

library(rpart)
library(rpart.plot)

Lectura de datos

options(scipen=999) #quitar notacion cientifica 
Datos <- read.csv("Advertising.csv", header = TRUE)
Datos <- Datos[,-1]  # Se elimina la primera columna si es un índice
knitr::kable(head(Datos,20))
TV Radio Newspaper Sales
230.1 37.8 69.2 22.1
44.5 39.3 45.1 10.4
17.2 45.9 69.3 9.3
151.5 41.3 58.5 18.5
180.8 10.8 58.4 12.9
8.7 48.9 75.0 7.2
57.5 32.8 23.5 11.8
120.2 19.6 11.6 13.2
8.6 2.1 1.0 4.8
199.8 2.6 21.2 10.6
66.1 5.8 24.2 8.6
214.7 24.0 4.0 17.4
23.8 35.1 65.9 9.2
97.5 7.6 7.2 9.7
204.1 32.9 46.0 19.0
195.4 47.7 52.9 22.4
67.8 36.6 114.0 12.5
281.4 39.6 55.8 24.4
69.2 20.5 18.3 11.3
147.3 23.9 19.1 14.6

Partición del conjunto de entrenamiento y de prueba

set.seed(1000)
indice <- sample(2, nrow(Datos), replace = TRUE, prob = c(0.7, 0.3))
Datos_E <- Datos[indice == 1,]  # Conjunto de entrenamiento
Datos_P <- Datos[indice == 2,]  # Conjunto de prueba

Classification and Regression Tree (CART)

Arbol <- rpart(formula = Sales ~ ., data = Datos_E)
#summary(Arbol)

Grafico de Arbol de Regresion

rpart.plot(Arbol,
           digits = 6,extra = 101,nn=TRUE,type =2, cex = 0.80)

Algoritmo de Particionamiento Recursivo

Criterios seleccionado : TV<150.65

Descripción de la imagen

Calculo de la impureza e Ganancia de Información

Impureza :

\[ i( \tau ) = \frac{1}{n} \sum_{i=1}^{n} (y_i - \bar{y}(\tau ))^2 \]

Donde:

  • \(i( \tau )\) es la impureza en el nodo (MSE).

  • \(n\) es el número de observaciones en el nodo.

  • \(y_i\) son los valores de respuesta.

  • \(\bar{y}( \tau )\) es la media de los valores de respuesta en el nodo .

Ganancia de Informacion

\[\phi=i( \tau )-p_{L}*i( \tau_{L})-p_{R}*i( \tau_{R} )\]

criteriovariable<- function(x){
  N <- length(Datos_E$Sales)

### Generar una secuencia de posibles puntos de corte(en el intervalos de valores de variable)
  criterio <-as.vector(seq(from = min(Datos_E[[x]]),
                           to = max(Datos_E[[x]]), 
                           by = 0.01))
### Impureza del nodo padre 
  yitotal <- Datos_E$Sales
  ybartotal <- mean(Datos_E$Sales)#promedio del nodo padre
  ipadre <- mean((yitotal - ybartotal) ^ 2) #error cuadratico medio (MCE)
  
  ### Impureza de los nodos hijos  
  iL <- c()
  for(i in 1:length(criterio)){
    ybar <- mean(Datos_E[Datos_E[[x]]<=criterio[i],]$Sales) 
    yi <- Datos_E[Datos_E[[x]]<=criterio[i],]$Sales 
    iL[i] <- mean((yi - ybar) ^ 2)
    }
  
  iR <- c()
    for(i in 1:length(criterio)){
      ybar <- mean(Datos_E[Datos_E[[x]]>criterio[i],]$Sales) 
      yi <- Datos_E[Datos_E[[x]]>criterio[i],]$Sales 
      iR[i] <- mean((yi - ybar) ^ 2)
    }
    ganancia <- c()
    nLc <- c()
    nRc <- c()
    for(i in 1:length(criterio)){
      nLc[i] <- length(Datos_E[Datos_E[[x]]<=criterio[i],]$Sales)
      nRc[i] <- length(Datos_E[Datos_E[[x]]>criterio[i],]$Sales)
      ganancia[i] <- ipadre-((nLc[i]/N)*iL[i]+(nRc[i]/N)*iR[i])
    }
    ganaciamax <- max(na.omit(ganancia)) 
    tabla <- data.frame(criterio,nLc,nRc,iL,iR,ganancia)
    criteriosmaxganancia <- tabla[tabla$ganancia==ganaciamax,]
    interval <- c(min(na.omit(criteriosmaxganancia$criterio)),max(na.omit(criteriosmaxganancia$criterio)))
    return(list(ganaciamax=ganaciamax,interval=interval))
  }
criteriovariable('TV')
$ganaciamax
[1] 16.55819

$interval
[1] 149.81 151.49
criteriovariable('Radio')
$ganaciamax
[1] 9.791002

$interval
[1] 26.70 26.89
criteriovariable('Newspaper')
$ganaciamax
[1] 3.059557

$interval
[1] 36.90 36.99

“Los criterios que tienen mayor ganancia de informacion en la variable TV estan en el intervalo de [149.81,151.49].El critero elegido es 150.65”

Hiperparámetros

Dashboard :Ajustando hiperparámetros(clickaqui)

Poda

Construye el árbol más grande posible (sin restricción)

set.seed(123)
arbol.completo <- rpart(Sales ~ . ,
                        data = Datos_E,
                        method = "anova",
                        cp = 0, 
                        minbucket = 1)
rpart.plot(arbol.completo,
           digits = 6,extra = 101,nn=TRUE,type =2, cex = 0.80)

cp Optimo

plotcp(arbol.completo)

Recortar el árbol (prune)

Arbol_Podado <-  rpart(Sales ~ . ,
                        data = Datos_E,
                        method = "anova",
                        cp = 0.003)
rpart.plot(Arbol_Podado,
           digits = 6,extra = 101,nn=TRUE,type =2, cex = 0.80)

Predicción

Datos_P[1,]
    TV Radio Newspaper Sales
2 44.5  39.3      45.1  10.4
predict(Arbol_Podado, Datos_P[1,])
       2 
9.818182

TV 44.5,Radio=39.3,Newspaper 45.1

Valor Real Sales 10.4

Valor Predicho Sales 9.818182