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

grupos <- 3

3. Realizar la clasificación

segmentos <- kmeans(df,grupos)

4. Revisar la asignación de grupos

asignacion <- cbind(df, cluster=segmentos$cluster)

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)


# Agrupando el número de visitas por cliente
visitas <- group_by(ventas, CustomerID)
visitas <- summarize(visitas, num.visitas=n())


# Agrupando visitas y agg
merge <- merge(visitas, agg, by= "CustomerID")
row.names(merge) <- (merge$CustomerID)
merge$CustomerID <- NULL

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)


# Juntar ambas tablas
objetos <- merge(visitas3, ticket_promedio, by= "CustomerID")
row.names(objetos) <- (objetos$CustomerID)
objetos$CustomerID <- NULL


# 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)

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


LS_V<- 5+1.5*IQR_V


objetos<- objetos[objetos$Visitas<=11,]

# Columna ticket promedio
colnames(objetos) <- c("Visitas", "TicketPromedio")
IQR_TP <- IQR(objetos$TicketPromedio)


LI_TP<- 178.30 -1.5*IQR_TP


LS_TP <- 426.63 + 1.5*IQR_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)


# Revisar la asignación de grupos
asignacion3 <- cbind(df, cluster=segmentos3$cluster)


# Grafica
#fviz_cluster(segmentos3, data=df, palette=c("red", "blue", "green", "orange"), ellipse.type="euclid", 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+VGVvcsOtYTwvc3Bhbj4KCiMjIDEuIENyZWFyIGJhc2UgZGUgZGF0b3MKYGBge3J9CmRmIDwtICBkYXRhLmZyYW1lKHg9YygyLDIsOCw1LDcsNiwxLDQpLCB5PWMoMTAsNSw0LDgsNSw0LDIsOSkpCmBgYAoKIyMgMi4gRGV0ZXJtaW5hciBlbCBuw7ptZXJvIGRlIGdydXBvcwpgYGB7cn0KZ3J1cG9zIDwtIDMKYGBgCgojIyAzLiBSZWFsaXphciBsYSBjbGFzaWZpY2FjacOzbgpgYGB7cn0Kc2VnbWVudG9zIDwtIGttZWFucyhkZixncnVwb3MpCgpgYGAKCiMjIDQuIFJldmlzYXIgbGEgYXNpZ25hY2nDs24gZGUgZ3J1cG9zCmBgYHtyfQphc2lnbmFjaW9uIDwtIGNiaW5kKGRmLCBjbHVzdGVyPXNlZ21lbnRvcyRjbHVzdGVyKQoKYGBgCgojIyA1LiBHcmFmaWNhciByZXN1bHRhZG9zCmBgYHtyIG1lc3NhZ2U9RkFMU0V9CmxpYnJhcnkoZ2dwbG90MikKbGlicmFyeShmYWN0b2V4dHJhKQoKZnZpel9jbHVzdGVyKHNlZ21lbnRvcywgZGF0YT1kZiwgCiAgICAgICAgICAgICBwYWxldHRlPWMoInJlZCIsICJibHVlIiwgImdyZWVuIiksIAogICAgICAgICAgICAgZWxsaXBzZS50eXBlPSJldWNsaWQiLCAKICAgICAgICAgICAgIHN0YXIucGxvdD0gVCwgCiAgICAgICAgICAgICByZXBlbD0gVCwgCiAgICAgICAgICAgICBnZ3RoZW1lID0gdGhlbWUoKQogICAgICAgICAgICAgKQpgYGAKCiMjIDYuIE9wdGltaXphciBncnVwb3MKYGBge3IgbWVzc2FnZT1GQUxTRX0KbGlicmFyeShjbHVzdGVyKQpsaWJyYXJ5KGRhdGEudGFibGUpCgpzZXQuc2VlZCgxMjMpCgpvcHRpbWl6YWNpb24gPC0gY2x1c0dhcChkZiwgRlVOPWttZWFucywgbnN0YXJ0PTEsIEsubWF4PTcpCnBsb3Qob3B0aW1pemFjaW9uLCAKICAgICB4bGFiPSAiTsO6bWVybyBkZSBjbHVzdGVycyBrIikKCiMgRWwgcHVudG8gbcOhcyBhbHRvIGRlIGxhIGdyw6FmaWNhIHNlcsOhIGVsIG7Dum1lcm8gZGUgZ3J1cG9zIGRlIGNsdXN0ZXJzIG9wdGltbyAKYGBgCgojIEFjdGl2aWRhZCA0LjEKIyMgQ2FyZ2FuZG8gbGlicmVyaWFzIHkgZGF0YWZyYW1lCmBgYHtyfQpsaWJyYXJ5KHJlYWRyKQpsaWJyYXJ5KGRwbHlyKQp2ZW50YXMgPC0gcmVhZC5jc3YoInZlbnRhcy5jc3YiKQp2ZW50YXMgPC0gbmEub21pdCh2ZW50YXMpCmBgYAoKIyMgU2VnbWVudGFjacOzbiBhIHRpY2tldCBwcm9tZWRpbwpgYGB7cn0KIyBDcmVhbmRvIGVsIHRpY2tldCBwcm9tZWRpbyAoVG90YWwpIHBvciBjbGllbnRlIChDdXN0b21lcklEKQphZ2cgPC0gYWdncmVnYXRlKFRvdGFsIH4gQ3VzdG9tZXJJRCArIEJpbGxObywgZGF0YT0gdmVudGFzLCBGVU49IHN1bSkKYWdnIDwtIGFnZ3JlZ2F0ZShUb3RhbCB+IEN1c3RvbWVySUQgLCBkYXRhPSBhZ2csIEZVTj0gbWVhbikKCgojIEFncnVwYW5kbyBlbCBuw7ptZXJvIGRlIHZpc2l0YXMgcG9yIGNsaWVudGUKdmlzaXRhcyA8LSBncm91cF9ieSh2ZW50YXMsIEN1c3RvbWVySUQpCnZpc2l0YXMgPC0gc3VtbWFyaXplKHZpc2l0YXMsIG51bS52aXNpdGFzPW4oKSkKCgojIEFncnVwYW5kbyB2aXNpdGFzIHkgYWdnCm1lcmdlIDwtIG1lcmdlKHZpc2l0YXMsIGFnZywgYnk9ICJDdXN0b21lcklEIikKcm93Lm5hbWVzKG1lcmdlKSA8LSAobWVyZ2UkQ3VzdG9tZXJJRCkKbWVyZ2UkQ3VzdG9tZXJJRCA8LSBOVUxMCgoKYGBgCgojIyBBc2lnbmFjacOzbiBkZSBuw7ptZXJvIGRlIGdydXBvcyB5IGNsYXNpZmljYWNpw7NuCmBgYHtyfQojIEFzaWduYW5kbyBudW1lcm8gZGUgZ3J1cG9zIGRlIGNsdXN0ZXJzCmdydXBvczI8LSA0CgojIENsc2FpZmljYWNpw7NuCnNlZ21lbnRvczIgPC0ga21lYW5zKG1lcmdlLCBncnVwb3MyKQojc2VnbWVudG9zMgpgYGAKCiMjIFJldmlzYXIgbGEgYXNpZ25hY2nDs24gZGUgZ3J1cG9zCmBgYHtyfQphc2lnbmFjaW9uMiA8LSBjYmluZChtZXJnZSwgY2x1c3Rlcj1zZWdtZW50b3MyJGNsdXN0ZXIpCiNhc2lnbmFjaW9uMgpgYGAKCiMjIEdyYWZpY2FyIHJlc3VsdGFkb3MKYGBge3IgbWVzc2FnZT1GQUxTRX0KI2Z2aXpfY2x1c3RlcihzZWdtZW50b3MyLCBkYXRhPW1lcmdlLCAKIyAgICAgICAgICAgICBwYWxldHRlPWMoInJlZCIsICJibHVlIiwgImdyZWVuIiwgIm9yYW5nZSIpLCAKIyAgICAgICAgICAgICAgZWxsaXBzZS50eXBlPSJldWNsaWQiLCAKIyAgICAgICAgICAgICAgc3Rhci5wbG90PSBULCAKIyAgICAgICAgICAgICAgcmVwZWw9IFQsIAojICAgICAgICAgICAgICBnZ3RoZW1lID0gdGhlbWUoKQojICAgICAgICAgICAgICApCmBgYAoKIyMgIE9wdGltaXphciBncnVwb3MKYGBge3IgbWVzc2FnZT1GQUxTRX0Kc2V0LnNlZWQoMTIzKQoKb3B0aW1pemFjaW9uMiA8LSBjbHVzR2FwKG1lcmdlLCBGVU49a21lYW5zLCBuc3RhcnQ9MSwgSy5tYXg9NykKcGxvdChvcHRpbWl6YWNpb24yLCAKICAgICB4bGFiPSAiTsO6bWVybyBkZSBjbHVzdGVycyBrIikKCiMgRWwgcHVudG8gbcOhcyBhbHRvIGRlIGxhIGdyw6FmaWNhIHNlcsOhIGVsIG7Dum1lcm8gZGUgZ3J1cG9zIGRlIGNsdXN0ZXJzIG9wdGltbyAKYGBgCgojIFNvbHVjacOzbiBkZSBwcm9mZSA0LjEKYGBge3J9CnZlbnRhczIgPC0gdmVudGFzCnN1bW1hcnkodmVudGFzMikKI2NvdW50KHZlbnRhczIsIEJpbGxObywgU29ydD0gVFJVRSkKI2NvdW50KHZlbnRhczIsIENvdW50cnksIFNvcnQ9IFRSVUUpCiNjb3VudCh2ZW50YXMyLCBJdGVtbmFtZSwgU29ydD0gVFJVRSkKI2NvdW50KHZlbnRhczIsIERhdGUsIFNvcnQ9IFRSVUUpCiNjb3VudCh2ZW50YXMyLCBIb3VyLCBTb3J0PSBUUlVFKQpgYGAKCk9ic2VydmFjaW9uZXM6IAoxLiBUZW5lbW9zIGNhbnRpZGFkZXMsIHByZWNpb3MgeSB0b3RhbGVzIG5lZ2F0aXZvcwoyLiBGZWNoYSB5IGhvcmEgbm8gdGllbmVuIGZvcm1hdG9zCjMuIFRlbmVtb3MgTkEncyBlbiBDdXN0b21lcklECgojIyBMaW1waWV6YSBkZSBkYXRvcwpgYGB7cn0KIyBOw7ptZXJvIGRlIE5BJ3MgZW4gdmVudGFzCnN1bShpcy5uYSh2ZW50YXMyKSkKCiMgQ3VhbnRvcyBOQSdzIHBvciB2YXJpYWJsZQpzYXBwbHkodmVudGFzMiwgZnVuY3Rpb24oeCkgc3VtKGlzLm5hKHgpKSkKCiMgRWxpbWluYXIgTkEncyBkZSBDdXN0b21lcklECnZlbnRhczIgPC0gbmEub21pdCh2ZW50YXMyKQoKIyBFbGltaW5hciB0b3RhbGVzIG5lZ2F0aXZvcwp2ZW50YXMyIDwtIHZlbnRhczJbdmVudGFzMiRUb3RhbD4wLF0KCiMgSWRlbnRpZmljYXIgT3V0bGllcnMKYm94cGxvdCh2ZW50YXMyJFRvdGFsLCBob3Jpem9udGFsPVRSVUUpCmBgYAogT2JzZXJ2YWNpb25lczogCiA0LiBIYXkgb3V0bGllcnMgZW4gIlRvdGFsIgogCiMjIENhbnRpZGFkIGRlIHZpc2l0YXMgcG9yIGNsaWVudGUsIHRpY2tldCBwcm9tZWRpbyB5IHVuaW9uIGRlIGFtYmFzIHRhYmxhcwpgYGB7cn0KIyBDYW50aWRhZCBkZSB2aXNpdGFzCnZpc2l0YXMzIDwtIGdyb3VwX2J5KHZlbnRhczIsIEN1c3RvbWVySUQpICU+JSBzdW1tYXJpemUoVmlzaXRhcyA9IG5fZGlzdGluY3QoQmlsbE5vKSkKCiMgT2J0ZW5lciB0b3RhbCBwb3IgdGlja2V0CnRpY2tldF9wcm9tZWRpbyA8LSBhZ2dyZWdhdGUoVG90YWwgfiBDdXN0b21lcklEICsgQmlsbE5vLCBkYXRhPSB2ZW50YXMyLCBGVU49IHN1bSkKdGlja2V0X3Byb21lZGlvIDwtIGFnZ3JlZ2F0ZShUb3RhbCB+IEN1c3RvbWVySUQgLCBkYXRhPSB0aWNrZXRfcHJvbWVkaW8sIEZVTj0gbWVhbikKCgojIEp1bnRhciBhbWJhcyB0YWJsYXMKb2JqZXRvcyA8LSBtZXJnZSh2aXNpdGFzMywgdGlja2V0X3Byb21lZGlvLCBieT0gIkN1c3RvbWVySUQiKQpyb3cubmFtZXMob2JqZXRvcykgPC0gKG9iamV0b3MkQ3VzdG9tZXJJRCkKb2JqZXRvcyRDdXN0b21lcklEIDwtIE5VTEwKCgojIEVsaW1pbmFyIGRhdG9zIGZ1ZXJhIGRlIGxvIG5vcm1hbAojIExpbWl0ZXMgZGUgbG9zIGRhdG9zIGZ1ZXJhIGRlIGxvIG5vcm1hbAojIExpbWl0ZSBpbmZlcmlvcj0gUTEgLSAxLjUqSVFSIChpbnRlcnF1YXJ0aWwpCiMgTGltaXRlIHN1cGVyaW9yPSBRMyArIDEuNSpJUVIgKGludGVycXVhcnRpbCkKCiNDb2x1bW5hIHZpc2l0YXMKSVFSX1YgPC0gSVFSKG9iamV0b3MkVmlzaXRhcykKCnN1bW1hcnkob2JqZXRvcykKTElfViA8LSAxLTEuNSpJUVJfVgoKCkxTX1Y8LSA1KzEuNSpJUVJfVgoKCm9iamV0b3M8LSBvYmpldG9zW29iamV0b3MkVmlzaXRhczw9MTEsXQoKIyBDb2x1bW5hIHRpY2tldCBwcm9tZWRpbwpjb2xuYW1lcyhvYmpldG9zKSA8LSBjKCJWaXNpdGFzIiwgIlRpY2tldFByb21lZGlvIikKSVFSX1RQIDwtIElRUihvYmpldG9zJFRpY2tldFByb21lZGlvKQoKCkxJX1RQPC0gMTc4LjMwIC0xLjUqSVFSX1RQCgoKTFNfVFAgPC0gNDI2LjYzICsgMS41KklRUl9UUAoKCm9iamV0b3MgPC0gb2JqZXRvc1tvYmpldG9zJFRpY2tldFByb21lZGlvPD0gNzkxLjY5LF0Kc3VtbWFyeShvYmpldG9zKQpgYGAKIAojIyBBc2lnbmFjacOzbiBkZSBncnVwb3MKYGBge3J9CiMgQXNpZ25hbmRvIG51bWVybyBkZSBncnVwb3MgZGUgY2x1c3RlcnMKZ3J1cG9zMzwtIDQKZGYgPC0gb2JqZXRvcyAKCiMgQ2xzYWlmaWNhY2nDs24Kc2VnbWVudG9zMyA8LSBrbWVhbnMoZGYsIGdydXBvczMpCgoKIyBSZXZpc2FyIGxhIGFzaWduYWNpw7NuIGRlIGdydXBvcwphc2lnbmFjaW9uMyA8LSBjYmluZChkZiwgY2x1c3Rlcj1zZWdtZW50b3MzJGNsdXN0ZXIpCgoKIyBHcmFmaWNhCiNmdml6X2NsdXN0ZXIoc2VnbWVudG9zMywgZGF0YT1kZiwgcGFsZXR0ZT1jKCJyZWQiLCAiYmx1ZSIsICJncmVlbiIsICJvcmFuZ2UiKSwgZWxsaXBzZS50eXBlPSJldWNsaWQiLCByZXBlbD0gVCwgZ2d0aGVtZSA9IHRoZW1lKCkpCgojIE9wdGltaXphciBncnVwb3MKc2V0LnNlZWQoMTIzKQoKb3B0aW1pemFjaW9uIDwtIGNsdXNHYXAoZGYsIEZVTj1rbWVhbnMsIG5zdGFydD0xLCBLLm1heD03KQpwbG90KG9wdGltaXphY2lvbiwgCiAgICAgeGxhYj0gIk7Dum1lcm8gZGUgY2x1c3RlcnMgayIpCgpgYGAKCg==