
Teoría
1. Crear base de datos
df <- data.frame(x=c(2,2,8,5,7,6,1,4), y=c(10,5,4,8,5,4,2,9))
2. Determinar el número de grupos
3. Realizar la clasificación
segmentos <- kmeans(df,grupos)
#segmentos
4. Revisar la asignación de grupos
asignacion <- cbind(df, cluster=segmentos$cluster)
#asignacion
5. Graficar resultados
library(ggplot2)
library(factoextra)
fviz_cluster(segmentos, data=df,
palette=c("red", "blue", "green"),
ellipse.type="euclid",
star.plot= T,
repel= T,
ggtheme = theme()
)

6. Optimizar grupos
library(cluster)
library(data.table)
set.seed(123)
optimizacion <- clusGap(df, FUN=kmeans, nstart=1, K.max=7)
plot(optimizacion,
xlab= "Número de clusters k")

# El punto más alto de la gráfica será el número de grupos de clusters optimo
Actividad 4.1
Cargando librerias y dataframe
library(readr)
library(dplyr)
##
## Attaching package: 'dplyr'
## The following objects are masked from 'package:data.table':
##
## between, first, last
## The following objects are masked from 'package:stats':
##
## filter, lag
## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, union
ventas <- read.csv("ventas.csv")
ventas <- na.omit(ventas)
Segmentación a ticket promedio
# Creando el ticket promedio (Total) por cliente (CustomerID)
agg <- aggregate(Total ~ CustomerID + BillNo, data= ventas, FUN= sum)
agg <- aggregate(Total ~ CustomerID , data= agg, FUN= mean)
#agg
# Agrupando el número de visitas por cliente
visitas <- group_by(ventas, CustomerID)
visitas <- summarize(visitas, num.visitas=n())
#visitas
# Agrupando visitas y agg
merge <- merge(visitas, agg, by= "CustomerID")
row.names(merge) <- (merge$CustomerID)
merge$CustomerID <- NULL
#merge
Asignación de número de grupos y clasificación
# Asignando numero de grupos de clusters
grupos2<- 4
# Clsaificación
segmentos2 <- kmeans(merge, grupos2)
#segmentos2
Revisar la asignación de grupos
asignacion2 <- cbind(merge, cluster=segmentos2$cluster)
#asignacion2
Graficar resultados
fviz_cluster(segmentos2, data=merge,
palette=c("red", "blue", "green", "orange"),
ellipse.type="euclid",
star.plot= T,
repel= T,
ggtheme = theme()
)

Optimizar grupos
set.seed(123)
optimizacion2 <- clusGap(merge, FUN=kmeans, nstart=1, K.max=7)
plot(optimizacion2,
xlab= "Número de clusters k")

# El punto más alto de la gráfica será el número de grupos de clusters optimo
Solución de profe 4.1
ventas2 <- ventas
summary(ventas2)
## BillNo Itemname Quantity Date
## Length:388023 Length:388023 Min. : 1.00 Length:388023
## Class :character Class :character 1st Qu.: 2.00 Class :character
## Mode :character Mode :character Median : 5.00 Mode :character
## Mean : 12.89
## 3rd Qu.: 12.00
## Max. :80995.00
## Hour Price CustomerID Country
## Length:388023 Min. : 0.000 Min. :12346 Length:388023
## Class :character 1st Qu.: 1.250 1st Qu.:13950 Class :character
## Mode :character Median : 1.950 Median :15265 Mode :character
## Mean : 3.079 Mean :15317
## 3rd Qu.: 3.750 3rd Qu.:16837
## Max. :8142.750 Max. :18287
## Total
## Min. : 0.00
## 1st Qu.: 4.35
## Median : 11.40
## Mean : 22.07
## 3rd Qu.: 19.50
## Max. :168469.60
#count(ventas2, BillNo, Sort= TRUE)
#count(ventas2, Country, Sort= TRUE)
#count(ventas2, Itemname, Sort= TRUE)
#count(ventas2, Date, Sort= TRUE)
#count(ventas2, Hour, Sort= TRUE)
Observaciones: 1. Tenemos cantidades, precios y totales negativos 2.
Fecha y hora no tienen formatos 3. Tenemos NA’s en CustomerID
Limpieza de datos
# Número de NA's en ventas
sum(is.na(ventas2))
## [1] 0
# Cuantos NA's por variable
sapply(ventas2, function(x) sum(is.na(x)))
## BillNo Itemname Quantity Date Hour Price CustomerID
## 0 0 0 0 0 0 0
## Country Total
## 0 0
# Eliminar NA's de CustomerID
ventas2 <- na.omit(ventas2)
# Eliminar totales negativos
ventas2 <- ventas2[ventas2$Total>0,]
# Identificar Outliers
boxplot(ventas2$Total, horizontal=TRUE)
Observaciones: 4. Hay outliers en “Total”
Cantidad de visitas por cliente, ticket promedio y union de ambas
tablas
# Cantidad de visitas
visitas3 <- group_by(ventas2, CustomerID) %>% summarize(Visitas = n_distinct(BillNo))
# Obtener total por ticket
ticket_promedio <- aggregate(Total ~ CustomerID + BillNo, data= ventas2, FUN= sum)
ticket_promedio <- aggregate(Total ~ CustomerID , data= ticket_promedio, FUN= mean)
#ticket_promedio
# Juntar ambas tablas
objetos <- merge(visitas3, ticket_promedio, by= "CustomerID")
row.names(objetos) <- (objetos$CustomerID)
objetos$CustomerID <- NULL
#objetos
# Eliminar datos fuera de lo normal
# Limites de los datos fuera de lo normal
# Limite inferior= Q1 - 1.5*IQR (interquartil)
# Limite superior= Q3 + 1.5*IQR (interquartil)
#Columna visitas
IQR_V <- IQR(objetos$Visitas)
#IQR_V
summary(objetos)
## Visitas Total
## Min. : 1.000 Min. : 3.45
## 1st Qu.: 1.000 1st Qu.: 178.30
## Median : 2.000 Median : 292.00
## Mean : 4.227 Mean : 415.62
## 3rd Qu.: 5.000 3rd Qu.: 426.63
## Max. :209.000 Max. :84236.25
LI_V <- 1-1.5*IQR_V
#LI_V
LS_V<- 5+1.5*IQR_V
#LS_V
objetos<- objetos[objetos$Visitas<=11,]
# Columna ticket promedio
colnames(objetos) <- c("Visitas", "TicketPromedio")
IQR_TP <- IQR(objetos$TicketPromedio)
#IQR_TP
LI_TP<- 178.30 -1.5*IQR_TP
#LI_TP
LS_TP <- 426.63 + 1.5*IQR_TP
#LS_TP
objetos <- objetos[objetos$TicketPromedio<= 791.69,]
summary(objetos)
## Visitas TicketPromedio
## Min. : 1.00 Min. : 3.45
## 1st Qu.: 1.00 1st Qu.:168.62
## Median : 2.00 Median :267.00
## Mean : 2.97 Mean :293.32
## 3rd Qu.: 4.00 3rd Qu.:383.98
## Max. :11.00 Max. :789.56
Asignación de grupos
# Asignando numero de grupos de clusters
grupos3<- 4
df <- objetos
# Clsaificación
segmentos3 <- kmeans(df, grupos3)
#segmentos3
# Revisar la asignación de grupos
asignacion3 <- cbind(df, cluster=segmentos3$cluster)
#asignacion3
# Grafica
fviz_cluster(segmentos3, data=df,
palette=c("red", "blue", "green", "orange"),
ellipse.type="euclid",
star.plot= T,
repel= T,
ggtheme = theme()
)

# Optimizar grupos
set.seed(123)
optimizacion <- clusGap(df, FUN=kmeans, nstart=1, K.max=7)
## Warning: Quick-TRANSfer stage steps exceeded maximum (= 188200)
plot(optimizacion,
xlab= "Número de clusters k")

LS0tCnRpdGxlOiAiQWN0aXZpZGFkIDQuMSIKYXV0aG9yOiAiRmVybmFuZG8gTW9yYWxlcyBEaWFydGUgLSBBMDE3NDA1NjciCmRhdGU6ICIyMDIzLTA5LTE4IgpvdXRwdXQ6IAogIGh0bWxfZG9jdW1lbnQ6CiAgICB0b2M6IFRSVUUKICAgIHRvY19mbG9hdDogVFJVRQogICAgY29kZV9kb3dubG9hZDogVFJVRQogICAgdGhlbWU6ICJ5ZXRpIgogICAgaGlnaGxpZ2h0OiAidGFuZ28iCi0tLQoKYGBge3Igc2V0dXAsIGluY2x1ZGU9RkFMU0V9CmtuaXRyOjpvcHRzX2NodW5rJHNldChlY2hvID0gVFJVRSkKYGBgCgohW10oL1VzZXJzL3NwZWVkeW1kMjMvRGVza3RvcC9BbmFsaXNpcyBkZSBkYXRvcyAtIGNvbmNlbnRyYWNpb8yBbi9Nb2QgNC9DY2xsLmdpZikKCiMgPHNwYW4gc3R5bGU9ImNvbG9yOiBibHVlOyI+VGVvcsOtYTwvc3Bhbj4KCiMjIDEuIENyZWFyIGJhc2UgZGUgZGF0b3MKYGBge3J9CmRmIDwtICBkYXRhLmZyYW1lKHg9YygyLDIsOCw1LDcsNiwxLDQpLCB5PWMoMTAsNSw0LDgsNSw0LDIsOSkpCmBgYAoKIyMgMi4gRGV0ZXJtaW5hciBlbCBuw7ptZXJvIGRlIGdydXBvcwpgYGB7cn0KZ3J1cG9zIDwtIDMKYGBgCgojIyAzLiBSZWFsaXphciBsYSBjbGFzaWZpY2FjacOzbgpgYGB7cn0Kc2VnbWVudG9zIDwtIGttZWFucyhkZixncnVwb3MpCiNzZWdtZW50b3MKYGBgCgojIyA0LiBSZXZpc2FyIGxhIGFzaWduYWNpw7NuIGRlIGdydXBvcwpgYGB7cn0KYXNpZ25hY2lvbiA8LSBjYmluZChkZiwgY2x1c3Rlcj1zZWdtZW50b3MkY2x1c3RlcikKI2FzaWduYWNpb24KYGBgCgojIyA1LiBHcmFmaWNhciByZXN1bHRhZG9zCmBgYHtyIG1lc3NhZ2U9RkFMU0V9CmxpYnJhcnkoZ2dwbG90MikKbGlicmFyeShmYWN0b2V4dHJhKQoKZnZpel9jbHVzdGVyKHNlZ21lbnRvcywgZGF0YT1kZiwgCiAgICAgICAgICAgICBwYWxldHRlPWMoInJlZCIsICJibHVlIiwgImdyZWVuIiksIAogICAgICAgICAgICAgZWxsaXBzZS50eXBlPSJldWNsaWQiLCAKICAgICAgICAgICAgIHN0YXIucGxvdD0gVCwgCiAgICAgICAgICAgICByZXBlbD0gVCwgCiAgICAgICAgICAgICBnZ3RoZW1lID0gdGhlbWUoKQogICAgICAgICAgICAgKQpgYGAKCiMjIDYuIE9wdGltaXphciBncnVwb3MKYGBge3IgbWVzc2FnZT1GQUxTRX0KbGlicmFyeShjbHVzdGVyKQpsaWJyYXJ5KGRhdGEudGFibGUpCgpzZXQuc2VlZCgxMjMpCgpvcHRpbWl6YWNpb24gPC0gY2x1c0dhcChkZiwgRlVOPWttZWFucywgbnN0YXJ0PTEsIEsubWF4PTcpCnBsb3Qob3B0aW1pemFjaW9uLCAKICAgICB4bGFiPSAiTsO6bWVybyBkZSBjbHVzdGVycyBrIikKCiMgRWwgcHVudG8gbcOhcyBhbHRvIGRlIGxhIGdyw6FmaWNhIHNlcsOhIGVsIG7Dum1lcm8gZGUgZ3J1cG9zIGRlIGNsdXN0ZXJzIG9wdGltbyAKYGBgCgojIEFjdGl2aWRhZCA0LjEKIyMgQ2FyZ2FuZG8gbGlicmVyaWFzIHkgZGF0YWZyYW1lCmBgYHtyfQpsaWJyYXJ5KHJlYWRyKQpsaWJyYXJ5KGRwbHlyKQp2ZW50YXMgPC0gcmVhZC5jc3YoInZlbnRhcy5jc3YiKQp2ZW50YXMgPC0gbmEub21pdCh2ZW50YXMpCmBgYAoKIyMgU2VnbWVudGFjacOzbiBhIHRpY2tldCBwcm9tZWRpbwpgYGB7cn0KIyBDcmVhbmRvIGVsIHRpY2tldCBwcm9tZWRpbyAoVG90YWwpIHBvciBjbGllbnRlIChDdXN0b21lcklEKQphZ2cgPC0gYWdncmVnYXRlKFRvdGFsIH4gQ3VzdG9tZXJJRCArIEJpbGxObywgZGF0YT0gdmVudGFzLCBGVU49IHN1bSkKYWdnIDwtIGFnZ3JlZ2F0ZShUb3RhbCB+IEN1c3RvbWVySUQgLCBkYXRhPSBhZ2csIEZVTj0gbWVhbikKI2FnZwoKIyBBZ3J1cGFuZG8gZWwgbsO6bWVybyBkZSB2aXNpdGFzIHBvciBjbGllbnRlCnZpc2l0YXMgPC0gZ3JvdXBfYnkodmVudGFzLCBDdXN0b21lcklEKQp2aXNpdGFzIDwtIHN1bW1hcml6ZSh2aXNpdGFzLCBudW0udmlzaXRhcz1uKCkpCiN2aXNpdGFzCgojIEFncnVwYW5kbyB2aXNpdGFzIHkgYWdnCm1lcmdlIDwtIG1lcmdlKHZpc2l0YXMsIGFnZywgYnk9ICJDdXN0b21lcklEIikKcm93Lm5hbWVzKG1lcmdlKSA8LSAobWVyZ2UkQ3VzdG9tZXJJRCkKbWVyZ2UkQ3VzdG9tZXJJRCA8LSBOVUxMCiNtZXJnZSAKCmBgYAoKIyMgQXNpZ25hY2nDs24gZGUgbsO6bWVybyBkZSBncnVwb3MgeSBjbGFzaWZpY2FjacOzbgpgYGB7cn0KIyBBc2lnbmFuZG8gbnVtZXJvIGRlIGdydXBvcyBkZSBjbHVzdGVycwpncnVwb3MyPC0gNAoKIyBDbHNhaWZpY2FjacOzbgpzZWdtZW50b3MyIDwtIGttZWFucyhtZXJnZSwgZ3J1cG9zMikKI3NlZ21lbnRvczIKYGBgCgojIyBSZXZpc2FyIGxhIGFzaWduYWNpw7NuIGRlIGdydXBvcwpgYGB7cn0KYXNpZ25hY2lvbjIgPC0gY2JpbmQobWVyZ2UsIGNsdXN0ZXI9c2VnbWVudG9zMiRjbHVzdGVyKQojYXNpZ25hY2lvbjIKYGBgCgojIyBHcmFmaWNhciByZXN1bHRhZG9zCmBgYHtyIG1lc3NhZ2U9RkFMU0V9CmZ2aXpfY2x1c3RlcihzZWdtZW50b3MyLCBkYXRhPW1lcmdlLCAKICAgICAgICAgICAgIHBhbGV0dGU9YygicmVkIiwgImJsdWUiLCAiZ3JlZW4iLCAib3JhbmdlIiksIAogICAgICAgICAgICAgZWxsaXBzZS50eXBlPSJldWNsaWQiLCAKICAgICAgICAgICAgIHN0YXIucGxvdD0gVCwgCiAgICAgICAgICAgICByZXBlbD0gVCwgCiAgICAgICAgICAgICBnZ3RoZW1lID0gdGhlbWUoKQogICAgICAgICAgICAgKQpgYGAKCiMjICBPcHRpbWl6YXIgZ3J1cG9zCmBgYHtyIG1lc3NhZ2U9RkFMU0V9CnNldC5zZWVkKDEyMykKCm9wdGltaXphY2lvbjIgPC0gY2x1c0dhcChtZXJnZSwgRlVOPWttZWFucywgbnN0YXJ0PTEsIEsubWF4PTcpCnBsb3Qob3B0aW1pemFjaW9uMiwgCiAgICAgeGxhYj0gIk7Dum1lcm8gZGUgY2x1c3RlcnMgayIpCgojIEVsIHB1bnRvIG3DoXMgYWx0byBkZSBsYSBncsOhZmljYSBzZXLDoSBlbCBuw7ptZXJvIGRlIGdydXBvcyBkZSBjbHVzdGVycyBvcHRpbW8gCmBgYAoKIyBTb2x1Y2nDs24gZGUgcHJvZmUgNC4xCmBgYHtyfQp2ZW50YXMyIDwtIHZlbnRhcwpzdW1tYXJ5KHZlbnRhczIpCiNjb3VudCh2ZW50YXMyLCBCaWxsTm8sIFNvcnQ9IFRSVUUpCiNjb3VudCh2ZW50YXMyLCBDb3VudHJ5LCBTb3J0PSBUUlVFKQojY291bnQodmVudGFzMiwgSXRlbW5hbWUsIFNvcnQ9IFRSVUUpCiNjb3VudCh2ZW50YXMyLCBEYXRlLCBTb3J0PSBUUlVFKQojY291bnQodmVudGFzMiwgSG91ciwgU29ydD0gVFJVRSkKYGBgCgpPYnNlcnZhY2lvbmVzOiAKMS4gVGVuZW1vcyBjYW50aWRhZGVzLCBwcmVjaW9zIHkgdG90YWxlcyBuZWdhdGl2b3MKMi4gRmVjaGEgeSBob3JhIG5vIHRpZW5lbiBmb3JtYXRvcwozLiBUZW5lbW9zIE5BJ3MgZW4gQ3VzdG9tZXJJRAoKIyMgTGltcGllemEgZGUgZGF0b3MKYGBge3J9CiMgTsO6bWVybyBkZSBOQSdzIGVuIHZlbnRhcwpzdW0oaXMubmEodmVudGFzMikpCgojIEN1YW50b3MgTkEncyBwb3IgdmFyaWFibGUKc2FwcGx5KHZlbnRhczIsIGZ1bmN0aW9uKHgpIHN1bShpcy5uYSh4KSkpCgojIEVsaW1pbmFyIE5BJ3MgZGUgQ3VzdG9tZXJJRAp2ZW50YXMyIDwtIG5hLm9taXQodmVudGFzMikKCiMgRWxpbWluYXIgdG90YWxlcyBuZWdhdGl2b3MKdmVudGFzMiA8LSB2ZW50YXMyW3ZlbnRhczIkVG90YWw+MCxdCgojIElkZW50aWZpY2FyIE91dGxpZXJzCmJveHBsb3QodmVudGFzMiRUb3RhbCwgaG9yaXpvbnRhbD1UUlVFKQpgYGAKIE9ic2VydmFjaW9uZXM6IAogNC4gSGF5IG91dGxpZXJzIGVuICJUb3RhbCIKIAojIyBDYW50aWRhZCBkZSB2aXNpdGFzIHBvciBjbGllbnRlLCB0aWNrZXQgcHJvbWVkaW8geSB1bmlvbiBkZSBhbWJhcyB0YWJsYXMKYGBge3J9CiMgQ2FudGlkYWQgZGUgdmlzaXRhcwp2aXNpdGFzMyA8LSBncm91cF9ieSh2ZW50YXMyLCBDdXN0b21lcklEKSAlPiUgc3VtbWFyaXplKFZpc2l0YXMgPSBuX2Rpc3RpbmN0KEJpbGxObykpCgojIE9idGVuZXIgdG90YWwgcG9yIHRpY2tldAp0aWNrZXRfcHJvbWVkaW8gPC0gYWdncmVnYXRlKFRvdGFsIH4gQ3VzdG9tZXJJRCArIEJpbGxObywgZGF0YT0gdmVudGFzMiwgRlVOPSBzdW0pCnRpY2tldF9wcm9tZWRpbyA8LSBhZ2dyZWdhdGUoVG90YWwgfiBDdXN0b21lcklEICwgZGF0YT0gdGlja2V0X3Byb21lZGlvLCBGVU49IG1lYW4pCiN0aWNrZXRfcHJvbWVkaW8KCiMgSnVudGFyIGFtYmFzIHRhYmxhcwpvYmpldG9zIDwtIG1lcmdlKHZpc2l0YXMzLCB0aWNrZXRfcHJvbWVkaW8sIGJ5PSAiQ3VzdG9tZXJJRCIpCnJvdy5uYW1lcyhvYmpldG9zKSA8LSAob2JqZXRvcyRDdXN0b21lcklEKQpvYmpldG9zJEN1c3RvbWVySUQgPC0gTlVMTAojb2JqZXRvcwoKIyBFbGltaW5hciBkYXRvcyBmdWVyYSBkZSBsbyBub3JtYWwKIyBMaW1pdGVzIGRlIGxvcyBkYXRvcyBmdWVyYSBkZSBsbyBub3JtYWwKIyBMaW1pdGUgaW5mZXJpb3I9IFExIC0gMS41KklRUiAoaW50ZXJxdWFydGlsKQojIExpbWl0ZSBzdXBlcmlvcj0gUTMgKyAxLjUqSVFSIChpbnRlcnF1YXJ0aWwpCgojQ29sdW1uYSB2aXNpdGFzCklRUl9WIDwtIElRUihvYmpldG9zJFZpc2l0YXMpCiNJUVJfVgpzdW1tYXJ5KG9iamV0b3MpCkxJX1YgPC0gMS0xLjUqSVFSX1YKI0xJX1YKCkxTX1Y8LSA1KzEuNSpJUVJfVgojTFNfVgoKb2JqZXRvczwtIG9iamV0b3Nbb2JqZXRvcyRWaXNpdGFzPD0xMSxdCgojIENvbHVtbmEgdGlja2V0IHByb21lZGlvCmNvbG5hbWVzKG9iamV0b3MpIDwtIGMoIlZpc2l0YXMiLCAiVGlja2V0UHJvbWVkaW8iKQpJUVJfVFAgPC0gSVFSKG9iamV0b3MkVGlja2V0UHJvbWVkaW8pCiNJUVJfVFAKCkxJX1RQPC0gMTc4LjMwIC0xLjUqSVFSX1RQCiNMSV9UUAoKTFNfVFAgPC0gNDI2LjYzICsgMS41KklRUl9UUAojTFNfVFAKCm9iamV0b3MgPC0gb2JqZXRvc1tvYmpldG9zJFRpY2tldFByb21lZGlvPD0gNzkxLjY5LF0Kc3VtbWFyeShvYmpldG9zKQpgYGAKIAojIyBBc2lnbmFjacOzbiBkZSBncnVwb3MKYGBge3J9CiMgQXNpZ25hbmRvIG51bWVybyBkZSBncnVwb3MgZGUgY2x1c3RlcnMKZ3J1cG9zMzwtIDQKZGYgPC0gb2JqZXRvcyAKCiMgQ2xzYWlmaWNhY2nDs24Kc2VnbWVudG9zMyA8LSBrbWVhbnMoZGYsIGdydXBvczMpCiNzZWdtZW50b3MzCgojIFJldmlzYXIgbGEgYXNpZ25hY2nDs24gZGUgZ3J1cG9zCmFzaWduYWNpb24zIDwtIGNiaW5kKGRmLCBjbHVzdGVyPXNlZ21lbnRvczMkY2x1c3RlcikKI2FzaWduYWNpb24zCgojIEdyYWZpY2EKZnZpel9jbHVzdGVyKHNlZ21lbnRvczMsIGRhdGE9ZGYsIAogICAgICAgICAgICAgcGFsZXR0ZT1jKCJyZWQiLCAiYmx1ZSIsICJncmVlbiIsICJvcmFuZ2UiKSwgCiAgICAgICAgICAgICBlbGxpcHNlLnR5cGU9ImV1Y2xpZCIsIAogICAgICAgICAgICAgc3Rhci5wbG90PSBULCAKICAgICAgICAgICAgIHJlcGVsPSBULCAKICAgICAgICAgICAgIGdndGhlbWUgPSB0aGVtZSgpCiAgICAgICAgICAgICApCgpgYGAKCmBgYHtyfQojIE9wdGltaXphciBncnVwb3MKc2V0LnNlZWQoMTIzKQoKb3B0aW1pemFjaW9uIDwtIGNsdXNHYXAoZGYsIEZVTj1rbWVhbnMsIG5zdGFydD0xLCBLLm1heD03KQpwbG90KG9wdGltaXphY2lvbiwgCiAgICAgeGxhYj0gIk7Dum1lcm8gZGUgY2x1c3RlcnMgayIpCgpgYGAKCg==