Teoría

Una Red Nueronal Artificial (ANN) modela la relación entre un conjunto de entradas y salidas, resolviendo problema de aprendizaje.

Algunos ejemplos de aplicación de ANN son:

  • La recomendación de contenido de Netflix
  • El feed de Instagram
  • Determinar el número escrito a mano

Ejercicio 1. ¿Pasé la materia?

A. Intalar paquetes y llamar librerias

#install.packages("neuralnet")
library(neuralnet)
library(dplyr)
## 
## Attaching package: 'dplyr'
## The following object is masked from 'package:neuralnet':
## 
##     compute
## The following objects are masked from 'package:stats':
## 
##     filter, lag
## The following objects are masked from 'package:base':
## 
##     intersect, setdiff, setequal, union
library(tidyverse)
## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ forcats   1.0.0     ✔ readr     2.1.4
## ✔ ggplot2   3.4.4     ✔ stringr   1.5.0
## ✔ lubridate 1.9.2     ✔ tibble    3.2.1
## ✔ purrr     1.0.1     ✔ tidyr     1.3.0
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::compute() masks neuralnet::compute()
## ✖ dplyr::filter()  masks stats::filter()
## ✖ dplyr::lag()     masks stats::lag()
## ℹ Use the ]8;;http://conflicted.r-lib.org/conflicted package]8;; to force all conflicts to become errors

B. Obtener Datos

examen <- c(20,10,30,20,80,30)
proyecto <- c(90,20,40,50,50,80)
estatus <- c(1,0,0,0,0,1)
df1 <- data.frame(examen,proyecto,estatus)

C. Generar Red Neuronal

set.seed(123)
rn1 <- neuralnet(estatus ~.,data = df1)
plot(rn1, rep = "best")

D. Predecir Resultados

prueba_examen <- c(30,40,85)
prueba_proyecto <- c(85,50,40)
prueba1 <- data.frame(prueba_examen,prueba_proyecto)
prediccion <- neuralnet::compute(rn1,prueba1)
prediccion$net.result
##             [,1]
## [1,]  1.04011743
## [2,] -0.02359178
## [3,] -0.02359178
probabilidad <- prediccion$net.result
resultado <- ifelse(probabilidad>0.5,1,0)
resultado
##      [,1]
## [1,]    1
## [2,]    0
## [3,]    0

Ejercicio 2. Determinar Cancer de Mama

A. Obtener Datos

canmama <- read.csv("/Users/marcelotam/Desktop/concentracion AI/M2/cancer_de_mama.csv")
canmama_og <- read.csv("/Users/marcelotam/Desktop/concentracion AI/M2/cancer_de_mama.csv")
canmama$diagnosis <- ifelse(canmama$diagnosis == "M", 1, 0)
canmama_filtrado <- canmama[19:23,]

B. Entender la base de datos

summary(canmama)
##    diagnosis       radius_mean      texture_mean   perimeter_mean  
##  Min.   :0.0000   Min.   : 6.981   Min.   : 9.71   Min.   : 43.79  
##  1st Qu.:0.0000   1st Qu.:11.700   1st Qu.:16.17   1st Qu.: 75.17  
##  Median :0.0000   Median :13.370   Median :18.84   Median : 86.24  
##  Mean   :0.3726   Mean   :14.127   Mean   :19.29   Mean   : 91.97  
##  3rd Qu.:1.0000   3rd Qu.:15.780   3rd Qu.:21.80   3rd Qu.:104.10  
##  Max.   :1.0000   Max.   :28.110   Max.   :39.28   Max.   :188.50  
##    area_mean      smoothness_mean   compactness_mean  concavity_mean   
##  Min.   : 143.5   Min.   :0.05263   Min.   :0.01938   Min.   :0.00000  
##  1st Qu.: 420.3   1st Qu.:0.08637   1st Qu.:0.06492   1st Qu.:0.02956  
##  Median : 551.1   Median :0.09587   Median :0.09263   Median :0.06154  
##  Mean   : 654.9   Mean   :0.09636   Mean   :0.10434   Mean   :0.08880  
##  3rd Qu.: 782.7   3rd Qu.:0.10530   3rd Qu.:0.13040   3rd Qu.:0.13070  
##  Max.   :2501.0   Max.   :0.16340   Max.   :0.34540   Max.   :0.42680  
##  concave.points_mean symmetry_mean    fractal_dimension_mean   radius_se     
##  Min.   :0.00000     Min.   :0.1060   Min.   :0.04996        Min.   :0.1115  
##  1st Qu.:0.02031     1st Qu.:0.1619   1st Qu.:0.05770        1st Qu.:0.2324  
##  Median :0.03350     Median :0.1792   Median :0.06154        Median :0.3242  
##  Mean   :0.04892     Mean   :0.1812   Mean   :0.06280        Mean   :0.4052  
##  3rd Qu.:0.07400     3rd Qu.:0.1957   3rd Qu.:0.06612        3rd Qu.:0.4789  
##  Max.   :0.20120     Max.   :0.3040   Max.   :0.09744        Max.   :2.8730  
##    texture_se      perimeter_se       area_se        smoothness_se     
##  Min.   :0.3602   Min.   : 0.757   Min.   :  6.802   Min.   :0.001713  
##  1st Qu.:0.8339   1st Qu.: 1.606   1st Qu.: 17.850   1st Qu.:0.005169  
##  Median :1.1080   Median : 2.287   Median : 24.530   Median :0.006380  
##  Mean   :1.2169   Mean   : 2.866   Mean   : 40.337   Mean   :0.007041  
##  3rd Qu.:1.4740   3rd Qu.: 3.357   3rd Qu.: 45.190   3rd Qu.:0.008146  
##  Max.   :4.8850   Max.   :21.980   Max.   :542.200   Max.   :0.031130  
##  compactness_se      concavity_se     concave.points_se   symmetry_se      
##  Min.   :0.002252   Min.   :0.00000   Min.   :0.000000   Min.   :0.007882  
##  1st Qu.:0.013080   1st Qu.:0.01509   1st Qu.:0.007638   1st Qu.:0.015160  
##  Median :0.020450   Median :0.02589   Median :0.010930   Median :0.018730  
##  Mean   :0.025478   Mean   :0.03189   Mean   :0.011796   Mean   :0.020542  
##  3rd Qu.:0.032450   3rd Qu.:0.04205   3rd Qu.:0.014710   3rd Qu.:0.023480  
##  Max.   :0.135400   Max.   :0.39600   Max.   :0.052790   Max.   :0.078950  
##  fractal_dimension_se  radius_worst   texture_worst   perimeter_worst 
##  Min.   :0.0008948    Min.   : 7.93   Min.   :12.02   Min.   : 50.41  
##  1st Qu.:0.0022480    1st Qu.:13.01   1st Qu.:21.08   1st Qu.: 84.11  
##  Median :0.0031870    Median :14.97   Median :25.41   Median : 97.66  
##  Mean   :0.0037949    Mean   :16.27   Mean   :25.68   Mean   :107.26  
##  3rd Qu.:0.0045580    3rd Qu.:18.79   3rd Qu.:29.72   3rd Qu.:125.40  
##  Max.   :0.0298400    Max.   :36.04   Max.   :49.54   Max.   :251.20  
##    area_worst     smoothness_worst  compactness_worst concavity_worst 
##  Min.   : 185.2   Min.   :0.07117   Min.   :0.02729   Min.   :0.0000  
##  1st Qu.: 515.3   1st Qu.:0.11660   1st Qu.:0.14720   1st Qu.:0.1145  
##  Median : 686.5   Median :0.13130   Median :0.21190   Median :0.2267  
##  Mean   : 880.6   Mean   :0.13237   Mean   :0.25427   Mean   :0.2722  
##  3rd Qu.:1084.0   3rd Qu.:0.14600   3rd Qu.:0.33910   3rd Qu.:0.3829  
##  Max.   :4254.0   Max.   :0.22260   Max.   :1.05800   Max.   :1.2520  
##  concave.points_worst symmetry_worst   fractal_dimension_worst
##  Min.   :0.00000      Min.   :0.1565   Min.   :0.05504        
##  1st Qu.:0.06493      1st Qu.:0.2504   1st Qu.:0.07146        
##  Median :0.09993      Median :0.2822   Median :0.08004        
##  Mean   :0.11461      Mean   :0.2901   Mean   :0.08395        
##  3rd Qu.:0.16140      3rd Qu.:0.3179   3rd Qu.:0.09208        
##  Max.   :0.29100      Max.   :0.6638   Max.   :0.20750
str(canmama)
## 'data.frame':    569 obs. of  31 variables:
##  $ diagnosis              : num  1 1 1 1 1 1 1 1 1 1 ...
##  $ radius_mean            : num  18 20.6 19.7 11.4 20.3 ...
##  $ texture_mean           : num  10.4 17.8 21.2 20.4 14.3 ...
##  $ perimeter_mean         : num  122.8 132.9 130 77.6 135.1 ...
##  $ area_mean              : num  1001 1326 1203 386 1297 ...
##  $ smoothness_mean        : num  0.1184 0.0847 0.1096 0.1425 0.1003 ...
##  $ compactness_mean       : num  0.2776 0.0786 0.1599 0.2839 0.1328 ...
##  $ concavity_mean         : num  0.3001 0.0869 0.1974 0.2414 0.198 ...
##  $ concave.points_mean    : num  0.1471 0.0702 0.1279 0.1052 0.1043 ...
##  $ symmetry_mean          : num  0.242 0.181 0.207 0.26 0.181 ...
##  $ fractal_dimension_mean : num  0.0787 0.0567 0.06 0.0974 0.0588 ...
##  $ radius_se              : num  1.095 0.543 0.746 0.496 0.757 ...
##  $ texture_se             : num  0.905 0.734 0.787 1.156 0.781 ...
##  $ perimeter_se           : num  8.59 3.4 4.58 3.44 5.44 ...
##  $ area_se                : num  153.4 74.1 94 27.2 94.4 ...
##  $ smoothness_se          : num  0.0064 0.00522 0.00615 0.00911 0.01149 ...
##  $ compactness_se         : num  0.049 0.0131 0.0401 0.0746 0.0246 ...
##  $ concavity_se           : num  0.0537 0.0186 0.0383 0.0566 0.0569 ...
##  $ concave.points_se      : num  0.0159 0.0134 0.0206 0.0187 0.0188 ...
##  $ symmetry_se            : num  0.03 0.0139 0.0225 0.0596 0.0176 ...
##  $ fractal_dimension_se   : num  0.00619 0.00353 0.00457 0.00921 0.00511 ...
##  $ radius_worst           : num  25.4 25 23.6 14.9 22.5 ...
##  $ texture_worst          : num  17.3 23.4 25.5 26.5 16.7 ...
##  $ perimeter_worst        : num  184.6 158.8 152.5 98.9 152.2 ...
##  $ area_worst             : num  2019 1956 1709 568 1575 ...
##  $ smoothness_worst       : num  0.162 0.124 0.144 0.21 0.137 ...
##  $ compactness_worst      : num  0.666 0.187 0.424 0.866 0.205 ...
##  $ concavity_worst        : num  0.712 0.242 0.45 0.687 0.4 ...
##  $ concave.points_worst   : num  0.265 0.186 0.243 0.258 0.163 ...
##  $ symmetry_worst         : num  0.46 0.275 0.361 0.664 0.236 ...
##  $ fractal_dimension_worst: num  0.1189 0.089 0.0876 0.173 0.0768 ...

C. Generar Arbol de Decisión

# install.packages("rpart")
library(rpart)
arbol <- rpart(formula=diagnosis ~ ., data = canmama_og)
arbol
## n= 569 
## 
## node), split, n, loss, yval, (yprob)
##       * denotes terminal node
## 
##  1) root 569 212 B (0.62741652 0.37258348)  
##    2) radius_worst< 16.795 379  33 B (0.91292876 0.08707124)  
##      4) concave.points_worst< 0.1358 333   5 B (0.98498498 0.01501502) *
##      5) concave.points_worst>=0.1358 46  18 M (0.39130435 0.60869565)  
##       10) texture_worst< 25.67 19   4 B (0.78947368 0.21052632) *
##       11) texture_worst>=25.67 27   3 M (0.11111111 0.88888889) *
##    3) radius_worst>=16.795 190  11 M (0.05789474 0.94210526) *
# install.packages("rpart.plot")
library(rpart.plot)
rpart.plot(arbol)

prp(arbol,extra = 7,prefix = "fraccion")

D. Generar Red Neuronal

set.seed(123)
rnmama <- neuralnet(diagnosis ~.,data = canmama_filtrado)
plot(rnmama, rep = "best")

E. Predicción de Resultados

prediccionmama <- neuralnet::compute(rnmama,canmama_filtrado)
prediccionmama$net.result
##         [,1]
## 19 0.4012425
## 20 0.4012425
## 21 0.4012425
## 22 0.4012425
## 23 0.4012425
probabilidad_mama <- prediccionmama$net.result
resultado_mama <- ifelse(probabilidad_mama> 0.5, 1, 0)
resultado_mama
##    [,1]
## 19    0
## 20    0
## 21    0
## 22    0
## 23    0
LS0tCnRpdGxlOiAiUmVkZXMgTmV1cm9uYWxlcyIKYXV0aG9yOiAiTWFyY2VsbyBUYW0gQXJpY2EgLSBBMDE3MjIxNDAiCmRhdGU6ICJgciBTeXMuRGF0ZSgpYCIKb3V0cHV0OiAKICBodG1sX2RvY3VtZW50OiAKICAgIHRvYzogVFJVRQogICAgdG9jX2Zsb2F0OiBUUlVFCiAgICBjb2RlX2Rvd25sb2FkOiBUUlVFCiAgICB0aGVtZTogY29zbW8KLS0tCiMgVGVvcsOtYQoKVW5hIFJlZCBOdWVyb25hbCBBcnRpZmljaWFsIChBTk4pIG1vZGVsYSBsYSByZWxhY2nDs24gZW50cmUgdW4gY29uanVudG8gZGUgZW50cmFkYXMgeSBzYWxpZGFzLCByZXNvbHZpZW5kbyBwcm9ibGVtYSBkZSBhcHJlbmRpemFqZS4KCkFsZ3Vub3MgZWplbXBsb3MgZGUgYXBsaWNhY2nDs24gZGUgQU5OIHNvbjoKCiAgKiBMYSByZWNvbWVuZGFjacOzbiBkZSBjb250ZW5pZG8gZGUgTmV0ZmxpeAogICogRWwgZmVlZCBkZSBJbnN0YWdyYW0KICAqIERldGVybWluYXIgZWwgbsO6bWVybyBlc2NyaXRvIGEgbWFubwogIAojIyA8c3BhbiBzdHlsZT0iY29sb3I6Ymx1ZTsiPkVqZXJjaWNpbyAxLiDCv1Bhc8OpIGxhIG1hdGVyaWE/PC9zcGFuPgoKIVtdKC9Vc2Vycy9tYXJjZWxvdGFtL0Rlc2t0b3AvY29uY2VudHJhY2lvbiBBSS9NMi9jYWxpZnNmdC5wbmcpCgoKIyMjIDxzcGFuIHN0eWxlPSJjb2xvcjpibHVlOyI+QS4gSW50YWxhciBwYXF1ZXRlcyB5IGxsYW1hciBsaWJyZXJpYXM8L3NwYW4+CmBgYHtyfQojaW5zdGFsbC5wYWNrYWdlcygibmV1cmFsbmV0IikKbGlicmFyeShuZXVyYWxuZXQpCmxpYnJhcnkoZHBseXIpCmxpYnJhcnkodGlkeXZlcnNlKQpgYGAKCiMjIyA8c3BhbiBzdHlsZT0iY29sb3I6Ymx1ZTsiPkIuIE9idGVuZXIgRGF0b3M8L3NwYW4+CmBgYHtyfQpleGFtZW4gPC0gYygyMCwxMCwzMCwyMCw4MCwzMCkKcHJveWVjdG8gPC0gYyg5MCwyMCw0MCw1MCw1MCw4MCkKZXN0YXR1cyA8LSBjKDEsMCwwLDAsMCwxKQpkZjEgPC0gZGF0YS5mcmFtZShleGFtZW4scHJveWVjdG8sZXN0YXR1cykKYGBgCgojIyMgPHNwYW4gc3R5bGU9ImNvbG9yOmJsdWU7Ij5DLiBHZW5lcmFyIFJlZCBOZXVyb25hbDwvc3Bhbj4KYGBge3J9CnNldC5zZWVkKDEyMykKcm4xIDwtIG5ldXJhbG5ldChlc3RhdHVzIH4uLGRhdGEgPSBkZjEpCnBsb3Qocm4xLCByZXAgPSAiYmVzdCIpCmBgYAoKIyMjIDxzcGFuIHN0eWxlPSJjb2xvcjpibHVlOyI+RC4gUHJlZGVjaXIgUmVzdWx0YWRvczwvc3Bhbj4KYGBge3J9CnBydWViYV9leGFtZW4gPC0gYygzMCw0MCw4NSkKcHJ1ZWJhX3Byb3llY3RvIDwtIGMoODUsNTAsNDApCnBydWViYTEgPC0gZGF0YS5mcmFtZShwcnVlYmFfZXhhbWVuLHBydWViYV9wcm95ZWN0bykKcHJlZGljY2lvbiA8LSBuZXVyYWxuZXQ6OmNvbXB1dGUocm4xLHBydWViYTEpCmBgYApgYGB7cn0KcHJlZGljY2lvbiRuZXQucmVzdWx0CnByb2JhYmlsaWRhZCA8LSBwcmVkaWNjaW9uJG5ldC5yZXN1bHQKcmVzdWx0YWRvIDwtIGlmZWxzZShwcm9iYWJpbGlkYWQ+MC41LDEsMCkKcmVzdWx0YWRvCmBgYAoKLS0tCgojIyA8c3BhbiBzdHlsZT0iY29sb3I6cGluazsiPkVqZXJjaWNpbyAyLiBEZXRlcm1pbmFyIENhbmNlciBkZSBNYW1hPC9zcGFuPgoKIVtdKC9Vc2Vycy9tYXJjZWxvdGFtL0Rlc2t0b3AvY29uY2VudHJhY2lvbiBBSS9NMi9jYW5tYW1hZnQuZ2lmKQoKIyMjIDxzcGFuIHN0eWxlPSJjb2xvcjpwaW5rOyI+QS4gT2J0ZW5lciBEYXRvczwvc3Bhbj4KYGBge3J9CmNhbm1hbWEgPC0gcmVhZC5jc3YoIi9Vc2Vycy9tYXJjZWxvdGFtL0Rlc2t0b3AvY29uY2VudHJhY2lvbiBBSS9NMi9jYW5jZXJfZGVfbWFtYS5jc3YiKQpjYW5tYW1hX29nIDwtIHJlYWQuY3N2KCIvVXNlcnMvbWFyY2Vsb3RhbS9EZXNrdG9wL2NvbmNlbnRyYWNpb24gQUkvTTIvY2FuY2VyX2RlX21hbWEuY3N2IikKY2FubWFtYSRkaWFnbm9zaXMgPC0gaWZlbHNlKGNhbm1hbWEkZGlhZ25vc2lzID09ICJNIiwgMSwgMCkKY2FubWFtYV9maWx0cmFkbyA8LSBjYW5tYW1hWzE5OjIzLF0KYGBgCgojIyMgPHNwYW4gc3R5bGU9ImNvbG9yOnBpbms7Ij5CLiBFbnRlbmRlciBsYSBiYXNlIGRlIGRhdG9zPC9zcGFuPgpgYGB7cn0Kc3VtbWFyeShjYW5tYW1hKQpzdHIoY2FubWFtYSkKYGBgCgojIyMgPHNwYW4gc3R5bGU9ImNvbG9yOnBpbms7Ij5DLiBHZW5lcmFyIEFyYm9sIGRlIERlY2lzacOzbjwvc3Bhbj4KYGBge3J9CiMgaW5zdGFsbC5wYWNrYWdlcygicnBhcnQiKQpsaWJyYXJ5KHJwYXJ0KQphcmJvbCA8LSBycGFydChmb3JtdWxhPWRpYWdub3NpcyB+IC4sIGRhdGEgPSBjYW5tYW1hX29nKQphcmJvbAoKIyBpbnN0YWxsLnBhY2thZ2VzKCJycGFydC5wbG90IikKbGlicmFyeShycGFydC5wbG90KQpycGFydC5wbG90KGFyYm9sKQpwcnAoYXJib2wsZXh0cmEgPSA3LHByZWZpeCA9ICJmcmFjY2lvbiIpCmBgYAoKIyMjIDxzcGFuIHN0eWxlPSJjb2xvcjpwaW5rOyI+RC4gR2VuZXJhciBSZWQgTmV1cm9uYWw8L3NwYW4+CmBgYHtyfQpzZXQuc2VlZCgxMjMpCnJubWFtYSA8LSBuZXVyYWxuZXQoZGlhZ25vc2lzIH4uLGRhdGEgPSBjYW5tYW1hX2ZpbHRyYWRvKQpwbG90KHJubWFtYSwgcmVwID0gImJlc3QiKQpgYGAKCiMjIyA8c3BhbiBzdHlsZT0iY29sb3I6cGluazsiPkUuIFByZWRpY2Npw7NuIGRlIFJlc3VsdGFkb3M8L3NwYW4+CmBgYHtyfQpwcmVkaWNjaW9ubWFtYSA8LSBuZXVyYWxuZXQ6OmNvbXB1dGUocm5tYW1hLGNhbm1hbWFfZmlsdHJhZG8pCnByZWRpY2Npb25tYW1hJG5ldC5yZXN1bHQKcHJvYmFiaWxpZGFkX21hbWEgPC0gcHJlZGljY2lvbm1hbWEkbmV0LnJlc3VsdApyZXN1bHRhZG9fbWFtYSA8LSBpZmVsc2UocHJvYmFiaWxpZGFkX21hbWE+IDAuNSwgMSwgMCkKcmVzdWx0YWRvX21hbWEKYGBg