library(knitr)
library(rmdformats)

## Global options
options(max.print="75")
opts_chunk$set(echo=FALSE,
                 cache=TRUE,
               prompt=FALSE,
               tidy=TRUE,
               comment=NA,
               message=FALSE,
               warning=FALSE)
opts_knit$set(width=75)

Introducción

Este ejemplo del uso de la biblioteca neural_net y neural_net_tools para introducirnos en este grupo de herramientas.

Conceptualmente las Redes Nueronales Artificiales o ANN (por sus siglas en inglés), es un mecanismo que puede operar como un clasificador semejante a un árbol que reparte en diferentes categorías, pero tambien puede limitarse a un modelador del tipo dicotómico (falso/verdadero).

Entrenador de red neuronal que calcula el cuadrado de un número

Generaremos una matriz de dos columnas que tenga como valores números del 0 al 10 en una columna y el cuadrado de esto números en la segunada columna.

x<-c(0:10)
y<-x^2
z <- c(x,y)
entrenador <- matrix(z,ncol=2, byrow = FALSE)
colnames(entrenador)<- c("nro","cuadrado")
entrenador
      nro cuadrado
 [1,]   0        0
 [2,]   1        1
 [3,]   2        4
 [4,]   3        9
 [5,]   4       16
 [6,]   5       25
 [7,]   6       36
 [8,]   7       49
 [9,]   8       64
[10,]   9       81
[11,]  10      100

Carga de las bibliotecas

library("neuralnet")

Entrenamieto de la red con los datos seleccionados

modelo=neuralnet(formula = cuadrado~nro, 
                data = entrenador, 
                hidden=10,threshold=0.01 )

Visualización del modelo

print(modelo)
$call
neuralnet(formula = cuadrado ~ nro, data = entrenador, hidden = 10, 
    threshold = 0.01)

$response
   cuadrado
1         0
2         1
3         4
4         9
5        16
6        25
7        36
8        49
9        64
10       81
11      100

$covariate
        
 [1,]  0
 [2,]  1
 [3,]  2
 [4,]  3
 [5,]  4
 [6,]  5
 [7,]  6
 [8,]  7
 [9,]  8
[10,]  9
[11,] 10

$model.list
$model.list$response
[1] "cuadrado"

$model.list$variables
[1] "nro"


$err.fct
function (x, y) 
{
    1/2 * (y - x)^2
}
<bytecode: 0x55f126af6560>
<environment: 0x55f126afaf70>
attr(,"type")
[1] "sse"

$act.fct
function (x) 
{
    1/(1 + exp(-x))
}
<bytecode: 0x55f126af2d40>
<environment: 0x55f126af2448>
attr(,"type")
[1] "logistic"

$linear.output
[1] TRUE

$data
   nro cuadrado
1    0        0
2    1        1
3    2        4
4    3        9
5    4       16
6    5       25
7    6       36
8    7       49
9    8       64
10   9       81
11  10      100

$exclude
NULL

$net.result
$net.result[[1]]
              [,1]
 [1,] -0.008417693
 [2,]  1.011559843
 [3,]  3.992665532
 [4,]  9.005531083
 [5,] 15.995925735
 [6,] 25.003377560
 [7,] 35.996796764
 [8,] 49.002479599
 [9,] 63.998074046
[10,] 81.000857385
[11,] 99.999629769


$weights
$weights[[1]]
$weights[[1]][[1]]
          [,1]      [,2]      [,3]         [,4]       [,5]       [,6]      [,7]
[1,] 10.335405  8.745124 12.626059 31.470116851 -14.684255 -4.6165210  6.690530
[2,] -1.430128 -1.472157 -1.663049 -0.002073829   1.566784  0.9092756 -1.773624
           [,8]      [,9]     [,10]
[1,] 0.85845176  3.745378 15.665385
[2,] 0.01114358 -1.786620 -1.615422

$weights[[1]][[2]]
            [,1]
 [1,]  18.963113
 [2,]  -9.525356
 [3,]  -9.027391
 [4,] -13.261266
 [5,]  21.147343
 [6,]  31.905854
 [7,]  26.504249
 [8,]  -4.956070
 [9,]  22.302911
[10,]  -5.538531
[11,] -13.869700



$generalized.weights
$generalized.weights[[1]]
               [,1]
 [1,] -6.152606e+01
 [2,] -1.506934e+02
 [3,] -3.523785e-01
 [4,] -8.056325e-02
 [5,] -3.392531e-02
 [6,] -1.654157e-02
 [7,] -9.524225e-03
 [8,] -6.016718e-03
 [9,] -3.851841e-03
[10,] -2.957394e-03
[11,] -1.633375e-03


$startweights
$startweights[[1]]
$startweights[[1]][[1]]
           [,1]       [,2]       [,3]      [,4]       [,5]      [,6]       [,7]
[1,]  0.2302261  0.1926049  0.7127869  2.346737 -1.5507341 0.4290785  0.4528844
[2,] -1.0562068 -0.6984664 -1.6224010 -2.302108  0.5588471 0.8923809 -0.3806499
         [,8]       [,9]     [,10]
[1,] 1.673144 -0.2359057  1.523680
[2,] 1.051994 -1.2861210 -1.289965

$startweights[[1]][[2]]
            [,1]
 [1,] -1.3400293
 [2,] -1.3025380
 [3,] -1.4917823
 [4,] -1.2883318
 [5,]  0.8442001
 [6,]  0.8205680
 [7,] -2.5777658
 [8,] -0.7527767
 [9,]  0.5245923
[10,] -0.9747923
[11,] -0.4741955



$result.matrix
                                [,1]
error                   1.689365e-04
reached.threshold       7.782981e-03
steps                   1.032800e+04
Intercept.to.1layhid1   1.033540e+01
nro.to.1layhid1        -1.430128e+00
Intercept.to.1layhid2   8.745124e+00
nro.to.1layhid2        -1.472157e+00
Intercept.to.1layhid3   1.262606e+01
nro.to.1layhid3        -1.663049e+00
Intercept.to.1layhid4   3.147012e+01
nro.to.1layhid4        -2.073829e-03
Intercept.to.1layhid5  -1.468426e+01
nro.to.1layhid5         1.566784e+00
Intercept.to.1layhid6  -4.616521e+00
nro.to.1layhid6         9.092756e-01
Intercept.to.1layhid7   6.690530e+00
nro.to.1layhid7        -1.773624e+00
Intercept.to.1layhid8   8.584518e-01
nro.to.1layhid8         1.114358e-02
Intercept.to.1layhid9   3.745378e+00
nro.to.1layhid9        -1.786620e+00
Intercept.to.1layhid10  1.566539e+01
nro.to.1layhid10       -1.615422e+00
Intercept.to.cuadrado   1.896311e+01
1layhid1.to.cuadrado   -9.525356e+00
1layhid2.to.cuadrado   -9.027391e+00
1layhid3.to.cuadrado   -1.326127e+01
1layhid4.to.cuadrado    2.114734e+01
1layhid5.to.cuadrado    3.190585e+01
1layhid6.to.cuadrado    2.650425e+01
1layhid7.to.cuadrado   -4.956070e+00
1layhid8.to.cuadrado    2.230291e+01
1layhid9.to.cuadrado   -5.538531e+00
1layhid10.to.cuadrado  -1.386970e+01

attr(,"class")
[1] "nn"

Ploteo de la red neuronal

library(NeuralNetTools)
library(nnet)
plot(modelo)
plotnet(modelo)

Red Neuronal con pesos Red figurativa (con pesos graficados)

Grafo de la red Resultados obtenidos con el set de entrenamiento:

modelo$net.result
[[1]]
              [,1]
 [1,] -0.008417693
 [2,]  1.011559843
 [3,]  3.992665532
 [4,]  9.005531083
 [5,] 15.995925735
 [6,] 25.003377560
 [7,] 35.996796764
 [8,] 49.002479599
 [9,] 63.998074046
[10,] 81.000857385
[11,] 99.999629769

Uso de la red para predecir

Trataremos de indagar sobre cual es el cuadrado del número 12

test <- data.frame(entrenador = 12)
 prediccion <- compute(x=modelo, covariate=test)
 prediccion
$neurons
$neurons[[1]]
       entrenador
[1,] 1         12

$neurons[[2]]
     [,1]        [,2]         [,3]         [,4] [,5]      [,6]      [,7]
[1,]    1 0.001083866 0.0001335687 0.0006547994    1 0.9839702 0.9981575
             [,8]      [,9]        [,10]      [,11]
[1,] 4.595771e-07 0.7295173 2.068073e-08 0.02366787


$net.result
         [,1]
[1,] 113.8822
 12*12
[1] 144

Ejemplo de uso con emprendedores logísticos

Carga de Bibliotecas

library(neuralnet)  # regression

library(nnet) # classification 

library(NeuralNetTools)

library(plyr)

Carga de datos de emprendimientos logísticos

library(readr)

Categoric <- read_csv("https://themys.sid.uncu.edu.ar/rpalma/R-cran/50_Startups_Categoric_LAC.csv")
str(Categoric)
tibble [50 × 6] (S3: spec_tbl_df/tbl_df/tbl/data.frame)
 $ R_D_Spend    : num [1:50] 165349 162598 153442 144372 142107 ...
 $ POM          : num [1:50] 136898 151378 101146 118672 91392 ...
 $ Logist_Market: num [1:50] 471784 443899 407935 383200 366168 ...
 $ Pais         : chr [1:50] "Colombia" "Ecuador" "Chile" "Colombia" ...
 $ Profit       : num [1:50] 192262 191792 191050 182902 166188 ...
 $ Supervivencia: chr [1:50] "SpinOff" "SpinOff" "SpinOff" "SpinOff" ...
 - attr(*, "spec")=
  .. cols(
  ..   R_D_Spend = col_double(),
  ..   POM = col_double(),
  ..   Logist_Market = col_double(),
  ..   Pais = col_character(),
  ..   Profit = col_double(),
  ..   Supervivencia = col_character()
  .. )
library(readr)
Startups <- read_csv("/media/rpalma/OS/AAA_Datos/2020/Posgrado/Di3/Datasets/50 Start Ups/50_Startups_LAC.csv")
Categoric <- read_csv("/media/rpalma/OS/AAA_Datos/2020/Posgrado/Di3/Datasets/50 Start Ups/50_Startups_Categoric_LAC.csv")

Tratamiento de variables categóricas

tabla1 <- table(Categoric$Pais)
tabla2 <- table(Categoric$Supervivencia)
tabla3 <- table(Categoric$Pais,Categoric$Supervivencia)
plot(tabla1, col=c("red","green","blue"))

plot(tabla2, col=c("red","green","blue"))

plot(tabla3, col=c("red","green","blue"))

Histogramas superpuestos

ind_1 <- which(Categoric$Pais=="Colombia")
p1 <- as.matrix(Categoric[ind_1,5])

ind_2 <- which(Categoric$Pais=="Ecuador")
p2 <- as.matrix(Categoric[ind_2,5])

ind_3 <- which(Categoric$Pais=="Chile")
p3 <- as.matrix(Categoric[ind_3,5])
hp1 <- hist(p1)

hp2 <- hist(p2)

hp3 <- hist(p3)

par(mfrow=c(3,1))
plot( hp1, col=rgb(0,0,1,1/4), xlim=c(30000,200000),ylim=c(0,5),main="Ecuador")
plot( hp2, col=rgb(1,0,0,1/4),xlim=c(30000,200000),ylim=c(0,10),main="Colombia") 
plot( hp3, col=rgb(1,0,0,1/4),xlim=c(30000,200000),ylim=c(0,10),main="Chile") 

par(mfrow=c(1,3))
plot( hp1, col=rgb(0,0,1,1/4), xlim=c(30000,200000),ylim=c(0,5),main="Ecuador")
plot( hp2, col=rgb(1,0,0,1/4),xlim=c(30000,200000),ylim=c(0,10),main="Colombia") 
plot( hp3, col=rgb(1,0,0,1/4),xlim=c(30000,200000),ylim=c(0,10),main="Chile") 

pairs(Categoric[ ,1:3])

boxplot(Categoric[ ,1:3])

Categoric$Pais <- as.numeric(revalue(Categoric$Pais,
                          c("Colombia"="0", "Ecuador"="1",
                            "Chile"="2")))

Cuadro de campos categóricos

Categoric$Supervivencia <- as.numeric(revalue(Categoric$Supervivencia,
                          c("BankR"="0", "RevEq"="1",
                            "SpinOff"="2")))

Profit versus País

plot(Categoric$Pais, Categoric$Profit)

Visualización de Tablas

Tabla Textual

library(kableExtra)
kable(head(Categoric), "pipe")
R_D_Spend POM Logist_Market Pais Profit Supervivencia
165349.2 136897.80 471784.1 0 192261.8 2
162597.7 151377.59 443898.5 1 191792.1 2
153441.5 101145.55 407934.5 2 191050.4 2
144372.4 118671.85 383199.6 0 182902.0 2
142107.3 91391.77 366168.4 2 166187.9 2
131876.9 99814.71 362861.4 0 156991.1 2

Tabla Simple

kable(head(Categoric), "simple")
R_D_Spend POM Logist_Market Pais Profit Supervivencia
165349.2 136897.80 471784.1 0 192261.8 2
162597.7 151377.59 443898.5 1 191792.1 2
153441.5 101145.55 407934.5 2 191050.4 2
144372.4 118671.85 383199.6 0 182902.0 2
142107.3 91391.77 366168.4 2 166187.9 2
131876.9 99814.71 362861.4 0 156991.1 2

Normailización

normalize<-function(x){
  return ( (x-min(x))/(max(x)-min(x)))
}

Startups_norm<-as.data.frame(lapply(Categoric,FUN=normalize))
summary(Startups_norm$Profit)
   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
 0.0000  0.4249  0.5254  0.5481  0.7044  1.0000

Datos Originales y Datos normalizados

head(Categoric$Profit)
[1] 192261.8 191792.1 191050.4 182902.0 166187.9 156991.1
head(Startups_norm)
  R_D_Spend       POM Logist_Market Pais    Profit Supervivencia
1 1.0000000 0.6517439     1.0000000  0.0 1.0000000             1
2 0.9833595 0.7619717     0.9408934  0.5 0.9973546             1
3 0.9279846 0.3795790     0.8646636  1.0 0.9931781             1
4 0.8731364 0.5129984     0.8122351  0.0 0.9472924             1
5 0.8594377 0.3053280     0.7761356  1.0 0.8531714             1
6 0.7975660 0.3694479     0.7691259  0.0 0.8013818             1

Muestreo para entrenamento

indice <- sample(2, nrow(Startups_norm), replace = TRUE, prob = c(0.7,0.3))
startups_train <- Startups_norm[indice==1,]
startups_test  <- Startups_norm[indice==2,]

Modelo de Neural Net

attach(Categoric)

startups_model <- neuralnet(Profit~R_D_Spend+ POM + Logist_Market + Pais
, data = startups_train)
str(startups_model)
List of 14
 $ call               : language neuralnet(formula = Profit ~ R_D_Spend + POM + Logist_Market + Pais, data = startups_train)
 $ response           : num [1:37, 1] 1 0.997 0.993 0.947 0.853 ...
  ..- attr(*, "dimnames")=List of 2
  .. ..$ : chr [1:37] "1" "2" "3" "4" ...
  .. ..$ : chr "Profit"
 $ covariate          : num [1:37, 1:4] 1 0.983 0.928 0.873 0.859 ...
  ..- attr(*, "dimnames")=List of 2
  .. ..$ : chr [1:37] "1" "2" "3" "4" ...
  .. ..$ : chr [1:4] "R_D_Spend" "POM" "Logist_Market" "Pais"
 $ model.list         :List of 2
  ..$ response : chr "Profit"
  ..$ variables: chr [1:4] "R_D_Spend" "POM" "Logist_Market" "Pais"
 $ err.fct            :function (x, y)  
  ..- attr(*, "type")= chr "sse"
 $ act.fct            :function (x)  
  ..- attr(*, "type")= chr "logistic"
 $ linear.output      : logi TRUE
 $ data               :'data.frame':    37 obs. of  6 variables:
  ..$ R_D_Spend    : num [1:37] 1 0.983 0.928 0.873 0.859 ...
  ..$ POM          : num [1:37] 0.652 0.762 0.38 0.513 0.305 ...
  ..$ Logist_Market: num [1:37] 1 0.941 0.865 0.812 0.776 ...
  ..$ Pais         : num [1:37] 0 0.5 1 0 1 0 0.5 1 0 0.5 ...
  ..$ Profit       : num [1:37] 1 0.997 0.993 0.947 0.853 ...
  ..$ Supervivencia: num [1:37] 1 1 1 1 1 1 1 1 1 0.5 ...
 $ exclude            : NULL
 $ net.result         :List of 1
  ..$ : num [1:37, 1] 0.961 0.949 0.924 0.881 0.881 ...
  .. ..- attr(*, "dimnames")=List of 2
  .. .. ..$ : chr [1:37] "1" "2" "3" "4" ...
  .. .. ..$ : NULL
 $ weights            :List of 1
  ..$ :List of 2
  .. ..$ : num [1:5, 1] 0.952 -2.0694 0.0684 -0.192 -0.0203
  .. ..$ : num [1:2, 1] 1.29 -1.49
 $ generalized.weights:List of 1
  ..$ : num [1:37, 1:4] 13.92 11.25 8.13 5.83 5.82 ...
  .. ..- attr(*, "dimnames")=List of 2
  .. .. ..$ : chr [1:37] "1" "2" "3" "4" ...
  .. .. ..$ : NULL
 $ startweights       :List of 1
  ..$ :List of 2
  .. ..$ : num [1:5, 1] 0.107 0.314 0.392 0.351 0.601
  .. ..$ : num [1:2, 1] -0.0327 -1.632
 $ result.matrix      : num [1:10, 1] 0.03467 0.00952 495 0.95198 -2.06939 ...
  ..- attr(*, "dimnames")=List of 2
  .. ..$ : chr [1:10] "error" "reached.threshold" "steps" "Intercept.to.1layhid1" ...
  .. ..$ : NULL
 - attr(*, "class")= chr "nn"

Ploteo de la red Neuronal

plot(startups_model, rep = "best")

Ploteo de la red proporcional

Esto me indica cuales son los KPI

par(mar = numeric(4), family = 'serif')
plotnet(startups_model, alpha = 0.6)

Evaluación de la performance del modelo

model_results <- compute(startups_model,startups_test[1:4])
predicted_profit <- model_results$net.result

Predicted profit Vs Actual profit of test data.

cor(predicted_profit,startups_test$Profit)
          [,1]
[1,] 0.9492542

Desnormalización de los resultados

Dado que hicimos la predicciones con los datos normalizados, ahora deberemos des-normalizarlos

str_max <- max(Startups$Profit)
str_min <- min(Startups$Profit)

unnormalize <- function(x, min, max) { 
  return( (max - min)*x + min )
}

ActualProfit_pred <- unnormalize(predicted_profit,str_min,str_max)
head(ActualProfit_pred)
       [,1]
11 137822.3
13 131363.6
14 128993.6
15 150973.3
23 116700.1
25 114319.5

Mejoramiento de la performance del modelo

Es posible mejorar la performance con el agregado de más capas ocultas.

Startups_model2 <- neuralnet(Profit~R_D_Spend+ POM + Logist_Market + Pais
, data = startups_train, hidden = 2)
plot(Startups_model2 ,rep = "best")

Performance del modelo mejorado

model_results2<-compute(Startups_model2,startups_test[1:4])
predicted_Profit2<-model_results2$net.result
cor(predicted_Profit2,startups_test$Profit)
          [,1]
[1,] 0.9617178

Modelo Mejorado KPI

par(mar = numeric(4), family = 'serif')
plotnet(Startups_model2, alpha = 0.6)

Neural Net Clasificación

Armamos el dataset de datos a clasificar

library(nnet)

supervivencia <- as.factor(Categoric$Supervivencia)
R_D_Spend <- as.matrix(Categoric$R_D_Spend)
POM <- as.matrix(Categoric$POM)
Logist_Market <- as.matrix(Categoric$Logist_Market)
Clasificar <- data.frame (supervivencia,R_D_Spend,POM,Logist_Market)

Muestreo

indice <- sample(2, nrow(Clasificar), replace = TRUE, prob = c(0.7,0.3))

clasificar_train <- Startups_norm[indice==1,]
clasificar_test  <- Startups_norm[indice==2,]

supervivientes_clasificados <- factor(clasificar_train$Supervivencia)

Entrenamiento de nnet como clasificador

supervivientes_train<-nnet(supervivientes_clasificados~clasificar_train$R_D_Spend + clasificar_train$POM+ clasificar_train$Logist_Market ,data=clasificar_train,size=5, decay=5e-4, maxit=2000)
# weights:  38
initial  value 54.781195 
iter  10 value 10.534012
iter  20 value 4.513268
iter  30 value 2.815274
iter  40 value 1.825117
iter  50 value 1.543713
iter  60 value 1.458589
iter  70 value 1.399277
iter  80 value 1.369608
iter  90 value 1.336821
iter 100 value 1.286628
iter 110 value 1.271607
iter 120 value 1.248965
iter 130 value 1.222945
iter 140 value 1.184048
iter 150 value 1.141371
iter 160 value 1.110091
iter 170 value 1.102332
iter 180 value 1.098195
iter 190 value 1.095244
iter 200 value 1.092794
iter 210 value 1.089102
iter 220 value 1.088169
iter 230 value 1.087559
iter 240 value 1.087249
iter 250 value 1.086901
iter 260 value 1.086409
iter 270 value 1.085977
iter 280 value 1.085706
iter 290 value 1.085209
iter 300 value 1.084830
iter 310 value 1.084525
iter 320 value 1.084460
iter 330 value 1.084415
iter 340 value 1.084384
iter 350 value 1.084359
iter 360 value 1.084326
iter 370 value 1.084279
iter 380 value 1.084249
iter 390 value 1.084235
iter 400 value 1.084233
iter 410 value 1.084230
iter 420 value 1.084230
final  value 1.084229 
converged

Visualización del clasificador

plotnet(supervivientes_train, alpha = 0.6)

Aramdos de set de entrenamiento y de predicción

Ver ejemplos

https://stackoverrun.com/es/q/3338607

crs\(nnet <- nnet(as.factor(Target) ~ ., data=crs\)dataset[crs\(sample,c(crs\)input, crs$target)], size=10, skip=TRUE, MaxNWts=10000, trace=FALSE, maxit=100)