1. Cargando datos crudos en el entorno de RStudio

library(readr)
flot500 <- read_csv("~/GENER/SOMs/Dra Anabel/1 Raw Data/Representacion_Flotante_500.csv")
flot500 <- bin[,c(-1,-3,-14:-20)]
flot500 <- as.data.frame(bin)

La ‘dataframe’ que se obtuvo esta compuesta por valores numericos:

str(flot500)
'data.frame':   500 obs. of  11 variables:
 $ Aptitud: num  0.394 0.386 0.364 0.382 0.35 ...
 $ UX1    : num  9.024 0.766 5.418 4.499 0.678 ...
 $ UX2    : num  4.98 8.4 5.48 2.02 1.75 ...
 $ UX3    : num  8.64 5.66 8.81 8.3 6.66 ...
 $ UX4    : num  1.85 4.8 7.13 4.92 4.67 ...
 $ UX5    : num  4.95 6.95 1.05 6.63 1.84 ...
 $ UY1    : num  1.68 3.7 5.31 7.93 1.89 ...
 $ UY2    : num  1.89 8.72 2.66 4.02 3.58 ...
 $ UY3    : num  6.36 3.3 9.14 8.98 1.32 ...
 $ UY4    : num  3.51 8.25 4 3.49 4.64 ...
 $ UY5    : num  8.172 0.348 5.015 6.615 8.091 ...

2 Exploracin Inicial de los Datos

Estadistica descriptiva de los datos:

summary(flot500)
    Aptitud            UX1              UX2              UX3              UX4              UX5        
 Min.   :0.2820   Min.   :0.0822   Min.   :0.1533   Min.   :0.0042   Min.   :0.1101   Min.   :0.1495  
 1st Qu.:0.3500   1st Qu.:2.5692   1st Qu.:3.0093   1st Qu.:3.0239   1st Qu.:2.9253   1st Qu.:3.2197  
 Median :0.3640   Median :5.2568   Median :5.6768   Median :5.5091   Median :5.2350   Median :5.6193  
 Mean   :0.3647   Mean   :5.0724   Mean   :5.4305   Mean   :5.2850   Mean   :5.1499   Mean   :5.4737  
 3rd Qu.:0.3800   3rd Qu.:7.7322   3rd Qu.:7.8102   3rd Qu.:7.6499   3rd Qu.:7.4742   3rd Qu.:7.9033  
 Max.   :0.4380   Max.   :9.8986   Max.   :9.9236   Max.   :9.7131   Max.   :9.6506   Max.   :9.9887  
      UY1              UY2              UY3              UY4              UY5        
 Min.   :0.1708   Min.   :0.3563   Min.   :0.0001   Min.   :0.0281   Min.   :0.2262  
 1st Qu.:3.2290   1st Qu.:2.9097   1st Qu.:2.9924   1st Qu.:3.1246   1st Qu.:3.3243  
 Median :5.1716   Median :4.5949   Median :4.7825   Median :5.0133   Median :5.2421  
 Mean   :5.2519   Mean   :4.8649   Mean   :5.0182   Mean   :5.0376   Mean   :5.2753  
 3rd Qu.:7.6833   3rd Qu.:7.2608   3rd Qu.:7.2951   3rd Qu.:7.3563   3rd Qu.:7.5692  
 Max.   :9.8777   Max.   :9.6523   Max.   :9.5358   Max.   :9.6957   Max.   :9.7919  

3 Mapa Autoorganizable

Cargando paquete necesario

require(kohonen)

Cambiando la estrutura de ‘dataframe’ a ‘matriz’

bin.matrix.flot <- as.matrix(flot500)

Creando el grid para el SOM

som_grid_flot <- somgrid(xdim =10 , ydim = 10, topo = "rectangular")

Entrenando al SOM

Evaluacion del Proceso de Entrenamiento

plot(som_model_flot, type = "changes")

Conteo de Nodos

source('coolBlueHotRed.R')
plot(som_model_flot, type = "counts", palette.name=coolBlueHotRed)

SOM por caracteristica Aptitud obtenida por el algoritmo genetico.

source("coolBlueHotRed.R")
models.flot <- as.data.frame(som_model_flot$codes)
plot(som_model_flot,
     type = "property",
     property = models.flot[,1],
     main=names(models.flot)[1],
     palette.name=coolBlueHotRed)

Distancia en vecindarios

plot(som_model_flot, type = "dist.neighbours", palette.name = grey.colors)

Distribucion de Valores

plot(som_model_flot, type = "codes", palette.name = coolBlueHotRed)

Clustering

mydata.flot <- som_model_flot$codes 
wss <- (nrow(mydata.flot)-1)*sum(apply(data.frame(mydata.flot),2,var)) 
for (i in 2:20) {
  wss[i] <- sum(kmeans(data.frame(mydata.flot), centers=i)$withinss)
}
plot(1:20, wss, type="b", xlab="Number of Clusters",
     ylab="Within groups sum of squares", main="Within cluster sum of squares (WCSS)")

La grafica anterior nos ayuda a decidir la cantidad ideal de clusters para agrupar los datos.

#15 clusters -- distribucion de cantidad de valores por cluster.
table(cutree(hclust(dist(data.frame(som_model_flot$codes))), 10))

 1  2  3  4  5  6  7  8  9 10 
20  9  7 10  6 16  9  9  7  7 
pretty_palette <- c("#1f77b4", '#ff7f0e', '#2ca02c', '#d62728', '#9467bd', '#8c564b', '#e377c2', '#89f442', '#f44183', '#4143f4', '#41e8f4', '#f4f141', '#849947', '#773737', '#1a7046')
som_cluster_flot <- cutree(hclust(dist(data.frame(som_model_flot$codes))), 10)
plot(som_model_flot, type="mapping", bgcol = pretty_palette[som_cluster_flot], main = "Clusters", keepMargins = TRUE) 
add.cluster.boundaries(som_model_flot, som_cluster_flot, lwd = 5)

Valores obtenidos por neurona

codes.flot <- as.data.frame(som_model_flot$codes)
codesOrdered.flot <- codes[order(codes$Aptitud, decreasing = TRUE),]
plot(codes.flot)

LS0tDQp0aXRsZTogIlNPTSBEcmEgQW5hYmVsIEZsb3RhbnRlcyINCm91dHB1dDogaHRtbF9ub3RlYm9vaw0KLS0tDQoNCg0KIzEuIENhcmdhbmRvIGRhdG9zIGNydWRvcyBlbiBlbCBlbnRvcm5vIGRlIFJTdHVkaW8NCg0KYGBge3IsIGVjaG89VFJVRSwgbWVzc2FnZT1GQUxTRSwgd2FybmluZz1GQUxTRX0NCg0KbGlicmFyeShyZWFkcikNCmZsb3Q1MDAgPC0gcmVhZF9jc3YoIn4vR0VORVIvU09Ncy9EcmEgQW5hYmVsLzEgUmF3IERhdGEvUmVwcmVzZW50YWNpb25fRmxvdGFudGVfNTAwLmNzdiIpDQpmbG90NTAwIDwtIGJpblssYygtMSwtMywtMTQ6LTIwKV0NCmZsb3Q1MDAgPC0gYXMuZGF0YS5mcmFtZShiaW4pDQoNCmBgYA0KDQpMYSAnZGF0YWZyYW1lJyBxdWUgc2Ugb2J0dXZvIGVzdGEgY29tcHVlc3RhIHBvciB2YWxvcmVzIG51bWVyaWNvczoNCg0KYGBge3J9DQpzdHIoZmxvdDUwMCkNCmBgYA0KDQoNCg0KIzIgRXhwbG9yYWNpbiBJbmljaWFsIGRlIGxvcyBEYXRvcw0KDQpFc3RhZGlzdGljYSBkZXNjcmlwdGl2YSBkZSBsb3MgZGF0b3M6DQpgYGB7cn0NCnN1bW1hcnkoZmxvdDUwMCkNCmBgYA0KDQoNCiMzIE1hcGEgQXV0b29yZ2FuaXphYmxlDQoNCiMjQ2FyZ2FuZG8gcGFxdWV0ZSBuZWNlc2FyaW8NCg0KYGBge3IsIG1lc3NhZ2U9RkFMU0UsIHdhcm5pbmc9RkFMU0V9DQpyZXF1aXJlKGtvaG9uZW4pDQpgYGANCg0KIyNDYW1iaWFuZG8gbGEgZXN0cnV0dXJhIGRlICdkYXRhZnJhbWUnIGEgJ21hdHJpeicgDQpgYGB7cn0NCmJpbi5tYXRyaXguZmxvdCA8LSBhcy5tYXRyaXgoZmxvdDUwMCkNCmBgYA0KDQojI0NyZWFuZG8gZWwgZ3JpZCBwYXJhIGVsIFNPTQ0KYGBge3J9DQpzb21fZ3JpZF9mbG90IDwtIHNvbWdyaWQoeGRpbSA9MTAgLCB5ZGltID0gMTAsIHRvcG8gPSAicmVjdGFuZ3VsYXIiKQ0KYGBgDQoNCg0KIyNFbnRyZW5hbmRvIGFsIFNPTQ0KYGBge3IsIG1lc3NhZ2U9RkFMU0UsIHdhcm5pbmc9RkFMU0UsIGluY2x1ZGU9RkFMU0V9DQpzb21fbW9kZWxfZmxvdCA8LSBzb20oYmluLm1hdHJpeC5mbG90LA0KICAgICAgICAgICAgICAgICBncmlkID0gc29tX2dyaWRfZmxvdCwNCiAgICAgICAgICAgICAgICAgcmxlbiA9IDIwMDAwLA0KICAgICAgICAgICAgICAgICBhbHBoYSA9IGMoMC4wNSwwLjAxKSwNCiAgICAgICAgICAgICAgICAga2VlcC5kYXRhID0gVFJVRSkNCmBgYA0KDQojI0V2YWx1YWNpb24gZGVsIFByb2Nlc28gZGUgRW50cmVuYW1pZW50bw0KYGBge3J9DQpwbG90KHNvbV9tb2RlbF9mbG90LCB0eXBlID0gImNoYW5nZXMiKQ0KYGBgDQoNCiMjQ29udGVvIGRlIE5vZG9zDQpgYGB7cn0NCnNvdXJjZSgnY29vbEJsdWVIb3RSZWQuUicpDQpwbG90KHNvbV9tb2RlbF9mbG90LCB0eXBlID0gImNvdW50cyIsIHBhbGV0dGUubmFtZT1jb29sQmx1ZUhvdFJlZCkNCmBgYA0KDQoNCg0KDQojI1NPTSBwb3IgY2FyYWN0ZXJpc3RpY2EgKkFwdGl0dWQqIG9idGVuaWRhIHBvciBlbCBhbGdvcml0bW8gZ2VuZXRpY28uDQoNCmBgYHtyLCBmaWcuaGVpZ2h0PTEwfQ0Kc291cmNlKCJjb29sQmx1ZUhvdFJlZC5SIikNCg0KbW9kZWxzLmZsb3QgPC0gYXMuZGF0YS5mcmFtZShzb21fbW9kZWxfZmxvdCRjb2RlcykNCg0KcGxvdChzb21fbW9kZWxfZmxvdCwNCiAgICAgdHlwZSA9ICJwcm9wZXJ0eSIsDQogICAgIHByb3BlcnR5ID0gbW9kZWxzLmZsb3RbLDFdLA0KICAgICBtYWluPW5hbWVzKG1vZGVscy5mbG90KVsxXSwNCiAgICAgcGFsZXR0ZS5uYW1lPWNvb2xCbHVlSG90UmVkKQ0KDQpgYGANCg0KDQojI0Rpc3RhbmNpYSBlbiB2ZWNpbmRhcmlvcw0KYGBge3IsIGZpZy5hbGlnbj0nY2VudGVyJ30NCnBsb3Qoc29tX21vZGVsX2Zsb3QsIHR5cGUgPSAiZGlzdC5uZWlnaGJvdXJzIiwgcGFsZXR0ZS5uYW1lID0gZ3JleS5jb2xvcnMpDQpgYGANCg0KIyNEaXN0cmlidWNpb24gZGUgVmFsb3Jlcw0KYGBge3IsIGZpZy5oZWlnaHQ9IDEwfQ0KcGxvdChzb21fbW9kZWxfZmxvdCwgdHlwZSA9ICJjb2RlcyIsIHBhbGV0dGUubmFtZSA9IGNvb2xCbHVlSG90UmVkKQ0KYGBgDQoNCiMjQ2x1c3RlcmluZw0KYGBge3J9DQpteWRhdGEuZmxvdCA8LSBzb21fbW9kZWxfZmxvdCRjb2RlcyANCndzcyA8LSAobnJvdyhteWRhdGEuZmxvdCktMSkqc3VtKGFwcGx5KGRhdGEuZnJhbWUobXlkYXRhLmZsb3QpLDIsdmFyKSkgDQpmb3IgKGkgaW4gMjoyMCkgew0KICB3c3NbaV0gPC0gc3VtKGttZWFucyhkYXRhLmZyYW1lKG15ZGF0YS5mbG90KSwgY2VudGVycz1pKSR3aXRoaW5zcykNCn0NCnBsb3QoMToyMCwgd3NzLCB0eXBlPSJiIiwgeGxhYj0iTnVtYmVyIG9mIENsdXN0ZXJzIiwNCiAgICAgeWxhYj0iV2l0aGluIGdyb3VwcyBzdW0gb2Ygc3F1YXJlcyIsIG1haW49IldpdGhpbiBjbHVzdGVyIHN1bSBvZiBzcXVhcmVzIChXQ1NTKSIpDQoNCg0KDQpgYGANCg0KTGEgZ3JhZmljYSBhbnRlcmlvciBub3MgYXl1ZGEgYSBkZWNpZGlyIGxhIGNhbnRpZGFkIGlkZWFsIGRlICpjbHVzdGVycyogcGFyYSBhZ3J1cGFyIGxvcyBkYXRvcy4NCg0KYGBge3J9DQojMTUgY2x1c3RlcnMgLS0gZGlzdHJpYnVjaW9uIGRlIGNhbnRpZGFkIGRlIHZhbG9yZXMgcG9yIGNsdXN0ZXIuDQp0YWJsZShjdXRyZWUoaGNsdXN0KGRpc3QoZGF0YS5mcmFtZShzb21fbW9kZWxfZmxvdCRjb2RlcykpKSwgMTApKQ0KYGBgDQoNCmBgYHtyLCBmaWcuaGVpZ2h0PSAxMH0NCnByZXR0eV9wYWxldHRlIDwtIGMoIiMxZjc3YjQiLCAnI2ZmN2YwZScsICcjMmNhMDJjJywgJyNkNjI3MjgnLCAnIzk0NjdiZCcsICcjOGM1NjRiJywgJyNlMzc3YzInLCAnIzg5ZjQ0MicsICcjZjQ0MTgzJywgJyM0MTQzZjQnLCAnIzQxZThmNCcsICcjZjRmMTQxJywgJyM4NDk5NDcnLCAnIzc3MzczNycsICcjMWE3MDQ2JykNCg0Kc29tX2NsdXN0ZXJfZmxvdCA8LSBjdXRyZWUoaGNsdXN0KGRpc3QoZGF0YS5mcmFtZShzb21fbW9kZWxfZmxvdCRjb2RlcykpKSwgMTApDQpwbG90KHNvbV9tb2RlbF9mbG90LCB0eXBlPSJtYXBwaW5nIiwgYmdjb2wgPSBwcmV0dHlfcGFsZXR0ZVtzb21fY2x1c3Rlcl9mbG90XSwgbWFpbiA9ICJDbHVzdGVycyIsIGtlZXBNYXJnaW5zID0gVFJVRSkgDQphZGQuY2x1c3Rlci5ib3VuZGFyaWVzKHNvbV9tb2RlbF9mbG90LCBzb21fY2x1c3Rlcl9mbG90LCBsd2QgPSA1KQ0KYGBgDQoNCiMjVmFsb3JlcyBvYnRlbmlkb3MgcG9yIG5ldXJvbmENCmBgYHtyfQ0KY29kZXMuZmxvdCA8LSBhcy5kYXRhLmZyYW1lKHNvbV9tb2RlbF9mbG90JGNvZGVzKQ0KY29kZXNPcmRlcmVkLmZsb3QgPC0gY29kZXNbb3JkZXIoY29kZXMkQXB0aXR1ZCwgZGVjcmVhc2luZyA9IFRSVUUpLF0NCnBsb3QoY29kZXMuZmxvdCkNCmBgYA0KDQo=