Beer Reviews - Hito Final CC5206
Cristian Aguayo - Mirko Bozanic - Magdalena Muñoz
05 de diciembre de 2017
Introducción y motivación
El presente trabajo se basa en el análisis de una base de datos que contiene un set de 50.000 calificaciones de usuarios a cervezas con su respectivo comentario.
Lo anterior es de interés dado que se considera que estas calificaciones inciden en la elección de compra de otros consumidores. Personas que no tienen información previa sobre la calidad de una cerveza suelen buscar información en su medio, por ejemplo, con sus amigos, con los dependientes de la tienda donde se va a comprar o buscando en internet recomendaciones.
Por lo tanto, las opiniones que los consumidores postean en páginas especializadas son importante para el productor de cerveza dado que podrían influenciar en las ventas tanto de estos usuarios como en otros consumidores.
Se espera a partir del análisis de la base de datos poder extraer información útil para el productor cervecero, permitiendo detectar posibles correlaciones que permitan entender las causas de las puntuaciones, así como también entender cómo las puntuaciones pueden llegar a influir - en un eventual caso - en qué cerveza, según sus características; se llegará a comprar.
rm(list=ls()) #clear list of objects
graphics.off() #clear list of graphs
options(digits = 5) #number of digits to display
library(data.table)
library(lubridate)
library(ggplot2)
library(knitr)
library(anytime)
library(plotly)
library(igraph)
library(tm)
library(textmineR)
library(RSelenium)
library(wordcloud)
library(qdap)
library(stringr)
library(stringi)
library(NLP)
library(RWeka)
library(stringdist)
library(cluster)
library(NbClust)
library(hunspell)
library(wordnet)
library(ngram)
library(SnowballC)
library(text2vec)
library(RSentiment)
library(reshape2)
library(textmineR)
library(fpc)
data = fread('beer_2.csv',sep=';',dec='.')Análisis exploratorio previo
Información básica sobre el dataset
| beer.abv | beer.beerid | beer.brewerid | beer.name | beer.style | review.appearance | review.aroma | review.overall | review.palate | review.taste | review.text |
|---|---|---|---|---|---|---|---|---|---|---|
| 7.5 | 3517 | 394 | Stoudt’s India Pale Ale | American IPA | 4.5 | 3.5 | 4 | 4.5 | 4 | A lot of foam. But a lot. In the smell some … |
| Número de usuarios | Comentarios por usuario (prom) | Comentarios por usuarios(DS) | Número máximo de comentarios |
|---|---|---|---|
| 8376 | 5.9694 | 10.468 | 182 |
| Fecha inicio | Fecha fin |
|---|---|
| 1999-05-09 | 2012-01-11 |
En términos de mising values, solo existen datos no completos en el sexo, cumpleaños y edad de los usuarios.
Información básica por cerveza
Para poder analizar la información por cerveza se agregó la base de datos de la siguiente manera:
cervezas= data[,.(beer.name=unique(beer.name),beer.brewerid=unique(beer.brewerid),ncomentarios=.N,beer.style=unique(beer.style)),by=.(beer.beerid)]
sum.cervezas=data.table("Número de cervezas"=nrow(cervezas),"Comentarios por cerveza (prom)"=mean(cervezas$ncomentarios),"Comentarios por cerveza(DS)"=sd(cervezas$ncomentarios),"Número máximo de comentarios"=max(cervezas$ncomentarios))
kable(sum.cervezas, caption="Resumen Cervezas")| Número de cervezas | Comentarios por cerveza (prom) | Comentarios por cerveza(DS) | Número máximo de comentarios |
|---|---|---|---|
| 1923 | 26.001 | 125.87 | 2502 |
cervezas <- cervezas[order(cervezas$ncomentarios, decreasing = T),]
cervezas2 <- cervezas[1:10,]
plot_ly(x = factor(cervezas2$beer.name,levels = unique(cervezas2$beer.name)[order(cervezas2$ncomentarios, decreasing = TRUE)])[1:10],
y = cervezas$ncomentarios[1:10],
type = "bar",
marker = list(color ='rgb(169,169,169)')
) %>% layout(title = "Top 10 cervezas con más comentarios",xaxis = list(showticklabels = FALSE),yaxis=list(title="Comentarios"))## Warning: package 'bindrcpp' was built under R version 3.4.2Se puede observar que la desviación estándar en el número de comentarios por cervezas es muy alta comparada con su promedio, casi 5 veces. Además, se puede apreciar que dentro de las top 10 cervezas con más comentarios todas se encuentran dentro de las misma unidades de magnitud. Sin embargo, en un gráfico de todas las cervezas se ve que existe una gran cantidad de cervezas con baja cantidad de comentarios. Una situación similar se observa a continuación con los comentarios por cervecería y cervezas por cervecerías.
Información básica por cervecería
Para poder analizar la información por cervecería se agregó la base de datos de la siguiente manera:
| Número de cervecerías | Comentarios por cervecería (prom) | Comentarios por cerveceria(DS) | Número máximo de comentarios | Cervezas por cerveceria (prom) | Cervezas por cerveceria(DS) | Número máximo de cervezas |
|---|---|---|---|---|---|---|
| 219 | 228.31 | 1412 | 19955 | 8.7808 | 14.989 | 130 |
Información básica por tipo de cerveza
Para poder analizar la información por tipo de cerveza se agregó la base de datos de la siguiente manera:
| Número de tipos de cervezas | Comentarios por tipo de cerveza (prom) | Comentarios por tipo de cerveza (DS) | Número máximo de comentarios | Cervezas por tipo de cerveza (prom) | Cervezas por tipo de cerveza (DS) | Número máximo de cervezas |
|---|---|---|---|---|---|---|
| 95 | 526.32 | 967.77 | 5964 | 20.242 | 20.505 | 122 |
En este caso, a diferencia de los anteriores, la desviación estándar de los comentarios por tipo de cerveza y cervezas por tipo de cerveza es baja. En el primer caso es menos del doble, y en el segundo la desviación estándar y el promedio son casi iguales.
Información general sobre las calificaciones
A continuación, se muestran histogramas del promedio histórico de nota de las cervezas. Estas notas se encuentran principalmente acumuladas alrededor del intervalo 3.5-4.
db <- aggregate(cbind(review.appearance, review.aroma, review.overall,review.palate,review.taste)~ beer.beerid, data=data, mean, na.rm=TRUE)plot_ly(x = ~db$review.overall,type = "histogram",histnorm = "frequency", nbinsx=6, marker = list(color = 'rgb(158,202,225)')) %>% layout(title = "Histograma Nota Overall",xaxis = list(title = "Overall"),yaxis=list(title="Frecuencia"))plot_ly(x = ~db$review.appearance,type = "histogram",histnorm = "frequency", nbinsx=6, marker = list(color = 'rgb(128,0,128)')) %>% layout(title = "Histograma Nota Appearance",xaxis = list(title = "Appearance"),yaxis=list(title="Frecuencia"))plot_ly(x = ~db$review.aroma,type = "histogram",histnorm = "frequency", nbinsx=6, marker = list(color = 'rgb(255,215,0)')) %>% layout(title = "Histograma Nota Aroma",xaxis = list(title = "Aroma"),yaxis=list(title="Frecuencia"))plot_ly(x = ~db$review.taste,type = "histogram",histnorm = "frequency", nbinsx=6, marker = list(color = 'rgb(0,128,128)')) %>% layout(title = "Histograma Nota Taste",xaxis = list(title = "Taste"),yaxis=list(title="Frecuencia"))Temática o problemática central
El objetivo general de este trabajo es entender qué factores influyen en que una cerveza sea bien o mal evaluada.
Para esto se buscará generar conocimiento para los productores sobre la apreciación de los clientes sobre las cervezas. Se buscarán de espacios de mejora en la producción de las cervezas a partir de los comentarios de los consumidores. Un acercamiento inicial será definir métricas a partir de los relatos, como, por ejemplo, proporción de palabras y/o frases que indiquen mala calidad, y su respectivo equivalente para el caso de buena calidad. Así, se espera construir otras métricas (también en función de los relatos) que permitan explicar una buena o mala nota en alguna de las características evaluadas.
Desarrollo de experimentos
Experimento 1
Objetivo individual: Medir la influencian las dimensiones de evaluación en la nota general
Metodología: Regresión lineal simple
Previo a la realización de este experimento, se debió hacer un trabajo con la data para crear nuevas variables.
data=data[,edad:=user.ageinyears]
data=data[,tedad:="N.A."]
data=data[edad<100,tedad:="Adulto Mayor"]
data=data[edad<60,tedad:="Adulto"]
data=data[edad<40,tedad:="Adulto Joven"]
data=data[,review.largo:=nchar(review.text)]Análisis a nivel de comentario
Para poder encontrar las dimensiones que influencian más la nota general que le asigna un usuario a una cerveza, se utilizó una regresión simple, añadiendo, además, variables demográficas y de los comentarios que podrían ser interesantes de evaluar.
reg=lm(data$review.overall ~ review.appearance + review.aroma + review.palate + review.taste + user.gender + tedad + review.largo, data=data)
reg2=lm(data$review.overall ~ review.appearance + review.aroma + review.palate + review.taste + review.appearance*user.gender + user.gender + tedad + review.largo, data=data)
reg3=lm(data$review.overall ~ review.appearance + review.aroma + review.palate + review.taste + review.aroma*user.gender + user.gender + tedad + review.largo, data=data)
reg4=lm(data$review.overall ~ review.appearance + review.aroma + review.palate + review.taste + review.palate*user.gender + user.gender + tedad + review.largo, data=data)
reg5=lm(data$review.overall ~ review.appearance + review.aroma + review.palate + review.taste + review.taste*user.gender + user.gender + tedad + review.largo, data=data)
summary(reg)##
## Call:
## lm(formula = data$review.overall ~ review.appearance + review.aroma +
## review.palate + review.taste + user.gender + tedad + review.largo,
## data = data)
##
## Residuals:
## Min 1Q Median 3Q Max
## -2.934 -0.250 0.015 0.246 3.242
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 4.23e-01 1.62e-02 26.02 <2e-16 ***
## review.appearance 5.62e-02 3.98e-03 14.12 <2e-16 ***
## review.aroma 6.12e-02 4.05e-03 15.12 <2e-16 ***
## review.palate 2.48e-01 4.28e-03 57.92 <2e-16 ***
## review.taste 5.38e-01 4.36e-03 123.42 <2e-16 ***
## user.genderFemale -1.66e-02 2.38e-02 -0.70 0.486
## user.genderMale -8.58e-03 4.72e-03 -1.82 0.069 .
## tedadAdulto Joven -7.11e-03 9.41e-03 -0.76 0.450
## tedadAdulto Mayor 2.60e-03 3.15e-02 0.08 0.934
## tedadN.A. -1.50e-02 9.05e-03 -1.66 0.097 .
## review.largo -5.47e-05 4.87e-06 -11.25 <2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.414 on 49989 degrees of freedom
## Multiple R-squared: 0.653, Adjusted R-squared: 0.652
## F-statistic: 9.39e+03 on 10 and 49989 DF, p-value: <2e-16En la tabla anterior se muestran los resultados de “reg”. Se destaca el R cuadrado ajustado de un 65%, lo cual se considera alto para una muestra de datos reales.
Se puede apreciar que las dimensiones que tienen mayor impacto en la nota general son el sabor y paladar de la cerveza con un mayor coeficiente. También destaca que en edades, los adultos mayores son los que más castigan la nota general de las cervezas. Además, los resultados indican que mientras más largo un comentario, peor es la nota general otorgada por el usuario. Esto último es estadísticamente significativo, aunque su significancia numérica es baja.
En las otras regresiones (reg2, reg3,…) se probaron interacciones entre las dimensiones y el sexo del usuario, pero ninguna de estas interacciones salieron estadísticamente significativas.
Análisis a nivel de cerveza
En una segunda etapa de este experimento se agregó la base de datos por cerveza, obteniendo las notas promedio que obtenían en cada dimensión cada una de ellas. Además, se eliminó el 2% de cervezas con un mayor número de comentarios, dado que a partir de la exploración inicial se apreció que estas salían de la gran masa de cervezas, pudiendo distorsionar los resultados de la regresión.
cervezas= data[,.(beer.name=unique(beer.name),beer.brewerid=unique(beer.brewerid),ncomentarios=.N,beer.style=unique(beer.style),review.overall=mean(review.overall),review.appearance=mean(review.appearance), review.aroma=mean(review.aroma), review.palate=mean(review.palate),review.taste=mean(review.taste),review.largo=mean(review.largo)),by=.(beer.beerid)]
cervezas=cervezas[ncomentarios<=quantile(ncomentarios,.98)]
reg6=lm(review.overall ~ review.appearance + review.aroma + review.palate + review.taste, data=cervezas)
summary(reg6)##
## Call:
## lm(formula = review.overall ~ review.appearance + review.aroma +
## review.palate + review.taste, data = cervezas)
##
## Residuals:
## Min 1Q Median 3Q Max
## -1.7089 -0.1484 -0.0175 0.1346 1.8596
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 0.0673 0.0517 1.30 0.1932
## review.appearance 0.0610 0.0187 3.27 0.0011 **
## review.aroma 0.0355 0.0202 1.76 0.0792 .
## review.palate 0.2862 0.0209 13.72 <2e-16 ***
## review.taste 0.6120 0.0215 28.47 <2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.294 on 1879 degrees of freedom
## Multiple R-squared: 0.79, Adjusted R-squared: 0.79
## F-statistic: 1.77e+03 on 4 and 1879 DF, p-value: <2e-16En esta regresión se mejoró considerablemente el R cuadrado ajustado, indicando que la regresión explica casi el 80% de la varianza de los datos. Nuevamente, las dimensiones que tienen un mayor peso positivo en la nota general son el sabor y el paladar.
Experimento 2
Objetivo individual: Caracterizar evaluaciones según el contenido de los comentarios
Metodología: N-grams
Se analizaron los N-grams \(N \in \lbrace 1,2,3 \rbrace\) de los relatos asociados a las cervezas con baja calificación Overall (promedio menos una desviación estándar), y con alta calificación overall (promedio más una desviación estándar). El objetivo es poder caracterizar las evaluaciones recibidas a partir de lo que se expresa en el comentario asociado.
# Limpieza de texto #
text <- data$review.text
text <- gsub('[[:digit:]]+', '', text)
text <- str_replace_all(text, "[\r\n\t]" , " ")
text <- removePunctuation(text)
text <- tolower(gsub(" *\\b[[:alpha:]]{1}\\b *", " ", text))
text <- removeNumbers(text)
text <- Trim(clean(text))
# Creación arreglo stopwords y palabras redundantes #
exceptions <- grep(pattern = "not|n't", x = stopwords(), value = TRUE)
exceptions <- c(exceptions,"very","too","much","more")
my_stopwords <- setdiff(stopwords("en"), exceptions)
my_stopwords <- c(my_stopwords,"oz","ml","bottle","glass","pint","beer")
# Guardar texto limpio en otra columna #
data$review.cleantext <- text
# Creación datasets cervezas con bajo overall y alto overall #
# Elegir los ID de cervezas con bajo overall #
bajas <- db[which(db$review.overall <= mean(db$review.overall, na.rm = TRUE) - sd(db$review.overall, na.rm = TRUE)),1]
#Particionar el set de datos
db_bajas <- subset(data, data$beer.beerid %in% bajas)
db_bajas$review.cleantext <- Trim(clean(removeWords(db_bajas$review.cleantext,my_stopwords)))
bajas_texto <- paste0(db_bajas$review.cleantext, collapse = " ")
# Elegir los ID de cervezas con alto overall #
altas <- db[which(db$review.overall >= mean(db$review.overall, na.rm = TRUE) + sd(db$review.overall, na.rm = TRUE)),1]
#Particionar el set de datos
db_altas <- subset(data, data$beer.beerid %in% altas)
db_altas$review.cleantext <- Trim(clean(removeWords(db_altas$review.cleantext,my_stopwords)))
altas_texto <- paste0(db_altas$review.cleantext, collapse = " ")Cloudwords de cervezas con baja nota overall
Se crearon nubes de palabras para \(N = \lbrace 1,2,3 \rbrace\).
pal2 <- brewer.pal(8,"Dark2")
for(i in 1:3){
ngb <- ngram(bajas_texto , n =i)
wordcloud(words = get.phrasetable(ngb)$ngrams, freq=get.phrasetable(ngb)$freq ,max.words = 20, random.order=FALSE,colors=pal2,scale=c(5,.3))
}
Los unigrams en este caso no aportan mucha información, pues se pierde información sobre negaciones de palabras (not good, not much, etc). En el caso de los bigrams, las negaciones aparecen, pero siguen sin aportar mucha información porque quedan inconclusas. Finalmente, en elos trigrams, comienzan a aparecer algunos insights sobre la espuma de éstas cervezas, como que se desvanece rápido, que es muy gaseosa, muy espumosa, e incluso se podría deducir que desaparece luego al observar el trigram: “white head quickly (fades?)”.
Cloudwords de cervezas con alta calificación overall
for(i in 1:3){
nga <- ngram(altas_texto , n =i)
wordcloud(words = get.phrasetable(nga)$ngrams, freq=get.phrasetable(nga)$freq ,max.words = 20, random.order=FALSE,colors=pal2,scale=c(5,.3))
}
Esta vez, los unigrams que aparecen son un poco más sugerentes. Se observa una tendencia a mencionar “sabores” como chocolate, coffee, bourbon, e incluso se podría inferir que la palabra “dark” hace alusión a las cervezas negras. En los bigrams, como era de esperar, destacan los bigrams “very good” y “very nice”. Se resaltan además sabores asociados a chocolate, coffee y maple syrup. Finalmente, los trigrams aportan un poco de información a los bigrams de sabores identificados anteriormente.
Comparación cloudwords alto y bajo overall
Se buscó comparar los trigrams presentes en los comentarios de cervezas de alta y baja calificación overall.
all = c(altas_texto,bajas_texto)
corpus = Corpus(VectorSource(all))
tdm = TermDocumentMatrix(corpus)
tdm = as.matrix(tdm)
head(tdm)## Docs
## Terms 1 2
## aaaand 1 0
## aandresen 1 0
## aanother 1 0
## aaron 1 0
## aaronwhit 1 0
## aasher 2 0colnames(tdm) = c("AltoOverall", "BajoOverall")
comparison.cloud(tdm, random.order=FALSE,
colors = c("#00B2FF", "red", "#FF0099", "#6600CC"),
title.size=1.5, max.words=200)
De aquí se desprende que en lo comentarios correspondientes a cervezas con alto overall, predominan los conceptos relacionados a sabores (chocolate, bourbon, coffee, vanilla), mientras que en los comentarios de cervezas con bajo overall no predominan muchas palabras de interés.
Comparación trigrams buen/mal overall y buena/mala calificación taste
Según el modelo de regresión presentado anteriormente, la calificación en taste tiene influencia estadísticamente significativa sobre la calificación overall. Se replicó el análisis de comparison clouds y se agregó el de commonality clouds sobre los comentarios asociados baja calificación overall y baja calificación en taste, y los comentarios asociados a alta calificación overal y alta calificación en taste.
bajas <- db[which(db$review.taste <= mean(db$review.taste, na.rm = TRUE) - sd(db$review.taste, na.rm = TRUE)),1]
db_bajastaste <- subset(data, data$beer.beerid %in% bajas)
db_bajastaste$review.cleantext <- Trim(clean(removeWords(db_bajastaste$review.cleantext,my_stopwords)))
bajastaste_texto <- paste0(db_bajastaste$review.cleantext, collapse = " ")
altas <- db[which(db$review.taste >= mean(db$review.taste, na.rm = TRUE) + sd(db$review.taste, na.rm = TRUE)),1]
db_altastaste <- subset(data, data$beer.beerid %in% altas)
db_altastaste$review.cleantext <- Trim(clean(removeWords(db_altastaste$review.cleantext,my_stopwords)))
altastaste_texto <- paste0(db_altastaste$review.cleantext, collapse = " ")
ngb <- ngram(bajas_texto , n =3)
ngbtaste <- ngram(bajastaste_texto , n =3)
dfngb <- merge(get.phrasetable(ngb)[,1:2],get.phrasetable(ngbtaste)[,1:2], by = "ngrams")
dfngb[is.na(dfngb)] <- 0
nombresf <- dfngb[,1]
dfngb <- dfngb[,2:3]
rownames(dfngb) = nombresf
colnames(dfngb) = c("BajoOverall", "BajoTaste")
commonality.cloud(dfngb, random.order=FALSE,
colors = c("#00B2FF", "red", "#FF0099", "#6600CC"),
title.size=1.5, max.words=200)
Revisando los trigrams comunes, se mantiene la tendencia presentada antes sobre los comentarios asociados a la espuma de la cerveza. Es interesante mencionar la aparición del trigram “taste not bad”, que hace cuestionar sobre qué tan fundadas pueden ser las calificaciones en el item taste.
comparison.cloud(dfngb, random.order=FALSE,
colors = c("#00B2FF", "red", "#FF0099", "#6600CC"),
title.size=1.5, max.words=200)
Al comparar los trigrams distintos entre ambos conjuntos de relatos, no parece haber una tendencia marcada en ninguna de las dos partes.
nga <- ngram(altas_texto , n =3)
ngataste <- ngram(altastaste_texto , n =3)
dfnga <- merge(get.phrasetable(nga)[,1:2],get.phrasetable(ngataste)[,1:2], by = "ngrams")
dfnga[is.na(dfnga)] <- 0
nombresf <- dfnga[,1]
dfnga <- dfnga[,2:3]
rownames(dfnga) = nombresf
colnames(dfnga) = c("AltoOverall", "AltoTaste")
commonality.cloud(dfnga, random.order=FALSE,
colors = c("#00B2FF", "red"),
title.size=1.5, max.words=200)
En este caso también se mantiene la tendencia a hablar sobre sabores de chocolate, coffee, vanilla, tanto en los comentarios de cervezas con alto overall, como en los comentarios de cervezas con alta calificación en taste.
comparison.cloud(dfnga, random.order=FALSE,
colors = c("#00B2FF", "red", "#FF0099", "#6600CC"),
title.size=1.5, max.words=200)
Al comparar los trigrams de ambos conjuntos, es posible notar que sus palabras más frecuentes son comunes a ambos conjuntos.
Experimento 3
Objetivo individual: Observar posibles diferencias significativas entre reviews según nota obtenida. Clasificando por variables dummies de observación
Metodología: k-means
Se analizaron todos los reviews según su puntaje obtenido usando el método de clustering: K-Means. El objetivo de ello es observar posibles diferencias significativas entre encuestas regulares (comunes) de aquellas que no lo son. Observando posibles tendencias, o grupos; que nos ayuden a saber cuándo una cerveza es buena o mala. Y cuáles serían las características de un review distinto al resto.
#Creación de base de datos categórica a utilizar
BD = data[,c("review.appearance", "review.aroma", "review.palate", "review.taste")]
colnames(BD) = c("Apariencia", "Aroma", "Paladar", "Sabor")
#Creación de variables dummies
ap_bin = ifelse(BD$Apariencia>mean(BD$Apariencia),1,0)
ar_bin = ifelse(BD$Aroma>mean(BD$Aroma),1,0)
pal_bin = ifelse(BD$Paladar>mean(BD$Paladar),1,0)
sab_bin = ifelse(BD$Sabor>mean(BD$Sabor),1,0)
#Creación de bases de datos binarias a utilizar
BD_B = data.frame(ap_bin, ar_bin, pal_bin, sab_bin)
#Estructuración de base a utilizar
BD_TOT = data.frame(BD, BD_B)
colnames(BD_TOT) = c("Apariencia", "Aroma", "Paladar", "Sabor","AparienciaB", "AromaB", "PaladarB", "SaborB")
Se procede en ejecutar k-means para el caso de variables binarias.
Clustering Binario
Se utiliza k = 5. Referenciando la máxima nota posible dentro de la encuesta del consumidor,
#K-Means con k =5 (mejor de 100 intentos)
cluster = kmeans(BD_B, centers = 5, nstart = 100)
#Plot de K-Means resultante
plotcluster(BD_B, cluster$cluster)
Se observa en este caso que los grupos poseen tendencias similares. Salvo un caso particular el cual no guarda relación alguna con los otros clusters. De modo que tenemos uno apartado del resto, que puede ser usado como criterio para saber si dicho review es “regular” o “similar” a los demás, según su nota obtenida.
Criterio del Codo
En el método de K-Means se hace necesario el input “k” para saber cuántos clusters se formarán como resultado del método. El problema de lo anterior es que no se sabe a ciencia cierta cuál es el valor óptimo para dicho parámetro. Por tanto se propone el uso del Criterio del Codo. Consistente en la observación del Sum Squares Within (SSW) entre los clusters para distintos valores de k. Con ello se procede en seleccionar aquel valor en donde se nota un cambio brusco de tendencia, en la gráfica.
#Definición de Sum Squares Within
ssw = (nrow(BD_TOT)-1)*sum(apply(BD_TOT,2,var))
for (i in 2:15) ssw[i] = sum(kmeans(BD_TOT,centers=i)$withinss)
#Plot de K-Means para distintos valores de k
plot(1:15, ssw, type="o", col="blue", xlab="Número de Clusters", ylab="SSW", main = "Criterio del Codo para K Óptimo")
Es posible observar que el “codo” se encuentra entre los valores \(k \in \lbrace 2, 3, 4 \rbrace\). Por tanto se procede en testear las bases categóricas (junto con las binarias) para saber cuál tipo de variable sirve más a la hora de explicar la varianza. Los gráficos se presentan a continuación,
Gráfica para K = 2
cluster2c = kmeans(BD, centers = 2, nstart = 100)
clusplot(BD, cluster2c$cluster, color=TRUE, shade=TRUE, labels=2, lines=0, main = "Clustering K = 2 - Variables Enteras")
cluster2b = kmeans(BD_B, centers = 2, nstart = 100)
clusplot(BD_B, cluster2b$cluster, color=TRUE, shade=TRUE, labels=2, lines=0, main = "Clustering K = 2 - Variables Binarias")
Con las gráficas anteriores es claro observar que el caso binario es más visualmente amigable. En contraste de las variables enteras que poseen clusters con intersección, mezclando elementos entre ambos conjuntos.
Se observa que el clustering de variables categóricas explica de mejor forma la varianza. Esto en contraste de la clara diferenciación de clusters que existe para el caso de variables binarias.
Adicionalmente se pueden observar (y comparar) el tamaño de los clusters formados
cluster2c$size## [1] 35553 14447cluster2b$size## [1] 19678 30322
Se observa que en ambos casos, el tamaño de los clusters son similares.
Gráfica para K = 3
cluster3c = kmeans(BD, centers = 3, nstart = 100)
clusplot(BD, cluster3c$cluster, color=TRUE, shade=TRUE, labels=2, lines=0, main = "Clustering K = 3 - Variables Enteras")
cluster3b = kmeans(BD_B, centers = 3, nstart = 100)
clusplot(BD_B, cluster3b$cluster, color=TRUE, shade=TRUE, labels=2, lines=0, main = "Clustering K = 3 - Variables Binarias")
La tendencia anterior se repite: Claramente hay clusters diferenciados en el caso binario. Pero en el caso de variables continuas, las variables explican de mejor forma la varianza.
Replicando la observación de los tamaños,
cluster3c$size## [1] 22528 21055 6417cluster3b$size## [1] 27294 6086 16620
Se observa que en ambos casos, el tamaño de los clusters - si bien es diferente - posee cantidades similares.
Gráfica para K = 4
cluster4c = kmeans(BD, centers = 4, nstart = 100)
clusplot(BD, cluster4c$cluster, color=TRUE, shade=TRUE, labels=2, lines=0, main = "Clustering K = 4 - Variables Enteras")
cluster4b = kmeans(BD_B, centers = 4, nstart = 100)
clusplot(BD_B, cluster4b$cluster, color=TRUE, shade=TRUE, labels=2, lines=0, main = "Clustering K = 4 - Variables Binarias")
Respecto a los tamaños,
cluster4c$size## [1] 3206 11319 15353 20122cluster4b$size## [1] 27294 9860 6760 6086Se empiezan a observar diferencias en el tamaño de los clusters. Mas, la varianza para las variables enteras es mejor explicada que las binarias.
Se concluye que el tipo de variables solo afecta en la visualización de los clusters. Lo anterior no asegura mayor explicación en términos de varianza.
Cabe señalar que al tener varianzas explicadas similares (entre las variables enteras y variables binarias respectivamente) termina por ser decisión del observador cuál conjunto utilizar. ####Criterio de la Silueta
A continuación, se procede con el análisis de silueta en los clusterings anteriormente mencionados. El objetivo de ello está en saber (por método “Silhouette”) cuál es el k* óptimo que nos sirve para este proceso. Arrojando aquel que ofrezca clusters más diferenciados uno de otro (ie. que los elementos de un cluster, estén lo más juntos entre ellos. Y que los clusters estén lo más apartados uno del otro)
Cabe señalar que entre más grande sea el valor de referencia por cada cluster, mejor será la opción. Pues está mejor designada en su centroide, y alejada de otros.
Para lo anterior, se procede en el cálculo de las distancias pertenecientes a las bases de datos,
#Silhouette para confirmar k óptimo de análisis por base
#Cálculo de distancias en base de datos
dist_cat = dist(BD)^2
dist_bin = dist(BD_B)^2
Habiendo calculado las distancias anteriores (entre las 50.000 observaciones ~ reviews) se procede en la muestra de las siluetas ####Silhouette para k* de análisis
sil_cat = silhouette(cluster4c$cluster, dist_cat)
sil_bin = silhouette(cluster4b$cluster, dist_bin)
plot(sil_cat)
plot(sil_bin)
#OUTPUS:
#Análisis de base de datos categórica: k*=2
#Análsisi de base de datos binaria: k*=4
Con los resultados anteriores, se es capaz de visualizar 2 grupos diferenciados de reviews. Uno de reviews regulares, y otro de reviews no-regulares.
plotcluster(BD_B, cluster4b$cluster)
Según los resultados del criterio de la Silueta, se observa que las cantidades óptimas fueron de k = 2 para la base de datos categórica, y k = 4 para la base de datos con variables binarias. Por tanto, ahora se procede en analizar los clusters que contengan los centroides con las coordenadas más positivos posibles. Ergo, los más alejados y que manifiesten tener un comportamiento poco regular, en el común de reviews.
#Elección iterado de máximos valores por dimensión de los centroides
elector_bin = matrix(, nrow = 4, ncol = 1)
elector_cat = matrix(, nrow = 4, ncol = 1)
for(i in 1:4){
elector_bin[i,] = which.max(abs(cluster4b$centers[,i]))
elector_cat[i,] = which.max(abs(cluster2c$centers[,i]))
}
nb_max = max(as.numeric(as.character(as.data.frame(table(elector_bin))[order(as.data.frame(table(elector_bin))$Freq,decreasing = TRUE),]$elector_bin)))
nc_max = max(as.numeric(as.character(as.data.frame(table(elector_cat))[order(as.data.frame(table(elector_cat))$Freq,decreasing = TRUE),]$elector_cat)))
Elegidos los cluster con centroides más apartados, se procede en el análisis de distinción entre los reviews regulares y no-regulares.
#Extensión de base de datos con características nuevas
BD_TOT = data.frame(data[,c("beer.style")], BD_TOT, cluster4b$cluster, cluster2c$cluster)
colnames(BD_TOT) = c("Estilo","Apariencia", "Aroma", "Paladar", "Sabor","AparienciaB", "AromaB", "PaladarB", "SaborB", "ClusterB", "ClusterC")
#Creación de bases filtradas según caracterísiticas de clasificación: buena/mala
BD_FIL = subset(BD_TOT, ClusterB==nb_max & ClusterC==nc_max)
#Características Rescatables
BD_FIL=BD_FIL[,1:9]
Finalmente, un review no-regular posee las siguientes características
summary(BD_FIL)## Estilo Apariencia Aroma Paladar
## Length:27232 Min. :4.00 Min. :2.00 Min. :2.00
## Class :character 1st Qu.:4.00 1st Qu.:4.00 1st Qu.:4.00
## Mode :character Median :4.00 Median :4.00 Median :4.00
## Mean :4.25 Mean :4.24 Mean :4.21
## 3rd Qu.:4.50 3rd Qu.:4.50 3rd Qu.:4.50
## Max. :5.00 Max. :5.00 Max. :5.00
## Sabor AparienciaB AromaB PaladarB
## Min. :2.00 Min. :1 Min. :0.000 Min. :0.000
## 1st Qu.:4.00 1st Qu.:1 1st Qu.:1.000 1st Qu.:1.000
## Median :4.50 Median :1 Median :1.000 Median :1.000
## Mean :4.33 Mean :1 Mean :0.908 Mean :0.917
## 3rd Qu.:4.50 3rd Qu.:1 3rd Qu.:1.000 3rd Qu.:1.000
## Max. :5.00 Max. :1 Max. :1.000 Max. :1.000
## SaborB
## Min. :0.000
## 1st Qu.:1.000
## Median :1.000
## Mean :0.958
## 3rd Qu.:1.000
## Max. :1.000
De lo anterior es rescatable una cerveza con características de un review no-regular como, por ejemplo,
which.max(table(BD_FIL[,1]))## American Double / Imperial Stout
## 12Experimento 4
Objetivo individual: Encontrar asociaciones entre las dimensiones de evaluación
Metodología: Regla de Asociación
Para poder realizar este experimento, primero se debían transformar las variables de interés a categorías. Para esto, se decidió utilizar las 5 dimensiones de características más la evaluación general, y crear 3 niveles de notas: buena, regular, mala. Los umbrales para cada nivel se establecieron con el fin de tener grupos parecidos en tamaño en cada nivel. Debido a esto el umbral para pasar de mala a nota regular quedó muy alto, en un 3.5. Esto indica que en general no hay muchas personas que evalúan con notas realmente malas, concentrándose mayoritariamente entre 3 y 4.5.
data = fread('beer_2.csv',sep=';',dec='.')## Warning in require_bit64(): Some columns are type 'integer64' but
## package bit64 is not installed. Those columns will print as strange
## looking floating point data. There is no need to reload the data. Simply
## install.packages('bit64') to obtain the integer64 print method and print
## the data again.data=data[,appl:="regular appearance"]
data=data[review.appearance<=3.5,appl:="bad appearance"]
data=data[review.appearance>=4.5,appl:="good appearance"]
data=data[,tasl:="regular taste"]
data=data[review.taste<=3.5,tasl:="bad taste"]
data=data[review.taste>=4.5,tasl:="good taste"]
data=data[,arol:="regular aroma"]
data=data[review.aroma<=3.5,arol:="bad aroma"]
data=data[review.aroma>=4.5,arol:="good aroma"]
data=data[,pall:="regular palate"]
data=data[review.palate<=3.5,pall:="bad palate"]
data=data[review.palate>=4.5,pall:="good palate"]
data=data[,ovel:="regular overall"]
data=data[review.overall<=3.5,ovel:="bad overall"]
data=data[review.overall>=4.5,ovel:="good overall"]
data.aso=data[,19:23]
data.aso=data.aso[,':='(appl=as.factor(appl),tasl=as.factor(tasl),arol=as.factor(arol),pall=as.factor(pall),ovel=as.factor(ovel))]
library(arules)## Warning: package 'arules' was built under R version 3.4.3##
## Attaching package: 'arules'## The following object is masked from 'package:tm':
##
## inspect## The following objects are masked from 'package:base':
##
## abbreviate, writelibrary(arulesViz)## Warning: package 'arulesViz' was built under R version 3.4.3## Loading required package: gridA partir de la nueva base construida, se crearon reglas de asociación con la metodología aprendida en los laboratorios.
Con el fin de encontrar asociaciones fuera de lo común, esto es, que un par de dimensiones regulares llevasen a una nota general buena, por ejemplo, se iteró cambiando support y confidence, analizando la lista de itemset más frecuentes y los gráficos obtenidos. A continuación, se muestran ejemplos de los gráficos revisados.
Support=0.001; Confidence=0.5
rules <- apriori(data.aso, parameter=list(support=0.001, confidence=0.5))## Apriori
##
## Parameter specification:
## confidence minval smax arem aval originalSupport maxtime support minlen
## 0.5 0.1 1 none FALSE TRUE 5 0.001 1
## maxlen target ext
## 10 rules FALSE
##
## Algorithmic control:
## filter tree heap memopt load sort verbose
## 0.1 TRUE TRUE FALSE TRUE 2 TRUE
##
## Absolute minimum support count: 50
##
## set item appearances ...[0 item(s)] done [0.00s].
## set transactions ...[15 item(s), 50000 transaction(s)] done [0.09s].
## sorting and recoding items ... [15 item(s)] done [0.00s].
## creating transaction tree ... done [0.01s].
## checking subsets of size 1 2 3 4 5 done [0.00s].
## writing ... [755 rule(s)] done [0.00s].
## creating S4 object ... done [0.00s].plot(rules)
Support=0.001; Confidence=0.3
rules <- apriori(data.aso, parameter=list(support=0.001, confidence=0.3))## Apriori
##
## Parameter specification:
## confidence minval smax arem aval originalSupport maxtime support minlen
## 0.3 0.1 1 none FALSE TRUE 5 0.001 1
## maxlen target ext
## 10 rules FALSE
##
## Algorithmic control:
## filter tree heap memopt load sort verbose
## 0.1 TRUE TRUE FALSE TRUE 2 TRUE
##
## Absolute minimum support count: 50
##
## set item appearances ...[0 item(s)] done [0.00s].
## set transactions ...[15 item(s), 50000 transaction(s)] done [0.01s].
## sorting and recoding items ... [15 item(s)] done [0.00s].
## creating transaction tree ... done [0.01s].
## checking subsets of size 1 2 3 4 5 done [0.00s].
## writing ... [1913 rule(s)] done [0.00s].
## creating S4 object ... done [0.00s].plot(rules)
Finalmente se decidió optar por la regla con support=0.001 y confidence=0.3. Un extracto de los resultados de las reglas ordenadas según support y lift respectivamente, se muestran a continuación:
rules.sorted <- sort(rules, by="support")
inspect(head(rules.sorted, 20))## lhs rhs support confidence
## [1] {} => {appl=regular appearance} 0.43068 0.43068
## [2] {} => {pall=regular palate} 0.39148 0.39148
## [3] {} => {ovel=regular overall} 0.36958 0.36958
## [4] {} => {arol=bad aroma} 0.35864 0.35864
## [5] {} => {pall=bad palate} 0.35374 0.35374
## [6] {} => {arol=regular aroma} 0.35000 0.35000
## [7] {} => {tasl=good taste} 0.34428 0.34428
## [8] {} => {tasl=regular taste} 0.33150 0.33150
## [9] {} => {ovel=bad overall} 0.32776 0.32776
## [10] {} => {tasl=bad taste} 0.32422 0.32422
## [11] {} => {appl=bad appearance} 0.31892 0.31892
## [12] {} => {ovel=good overall} 0.30266 0.30266
## [13] {tasl=bad taste} => {ovel=bad overall} 0.24354 0.75116
## [14] {ovel=bad overall} => {tasl=bad taste} 0.24354 0.74304
## [15] {tasl=bad taste} => {arol=bad aroma} 0.24174 0.74560
## [16] {arol=bad aroma} => {tasl=bad taste} 0.24174 0.67405
## [17] {tasl=bad taste} => {pall=bad palate} 0.24150 0.74486
## [18] {pall=bad palate} => {tasl=bad taste} 0.24150 0.68270
## [19] {ovel=bad overall} => {pall=bad palate} 0.23514 0.71742
## [20] {pall=bad palate} => {ovel=bad overall} 0.23514 0.66473
## lift count
## [1] 1.0000 21534
## [2] 1.0000 19574
## [3] 1.0000 18479
## [4] 1.0000 17932
## [5] 1.0000 17687
## [6] 1.0000 17500
## [7] 1.0000 17214
## [8] 1.0000 16575
## [9] 1.0000 16388
## [10] 1.0000 16211
## [11] 1.0000 15946
## [12] 1.0000 15133
## [13] 2.2918 12177
## [14] 2.2918 12177
## [15] 2.0790 12087
## [16] 2.0790 12087
## [17] 2.1057 12075
## [18] 2.1057 12075
## [19] 2.0281 11757
## [20] 2.0281 11757rules.sorted <- sort(rules, by="lift")
inspect(head(rules.sorted, 6))## lhs rhs support confidence lift count
## [1] {appl=good appearance,
## tasl=good taste,
## arol=good aroma,
## ovel=good overall} => {pall=good palate} 0.06974 0.82611 3.2424 3487
## [2] {appl=good appearance,
## arol=good aroma,
## ovel=good overall} => {pall=good palate} 0.07384 0.79313 3.1130 3692
## [3] {appl=good appearance,
## tasl=good taste,
## arol=good aroma} => {pall=good palate} 0.08120 0.77260 3.0324 4060
## [4] {appl=good appearance,
## tasl=good taste,
## ovel=good overall} => {pall=good palate} 0.08688 0.76817 3.0150 4344
## [5] {appl=bad appearance,
## arol=bad aroma,
## pall=bad palate,
## ovel=bad overall} => {tasl=bad taste} 0.11818 0.93143 2.8728 5909
## [6] {appl=good appearance,
## tasl=good taste,
## arol=good aroma,
## pall=good palate} => {ovel=good overall} 0.06974 0.85887 2.8377 3487De las reglas ordenadas por support podemos ver que el factor común es “taste”, esto es, si hay mal sabor, involucra mala nota general, mal aroma, mal paladar, etc. Lo mismo, pero de manera contraría pasa si hay buen sabor. Esto implica que el sabor es un elemento importante en la evaluación de los usuarios, mucho más determinante que las otras dimensiones.
En las reglar ordenadas según lift se ven solo grupos de evaluaciones del mismo tipo. Se ven solo buenas notas en todas las dimensiones juntas o solo malas notas en todas las dimensiones juntas. No se encontraron combinaciones fuera de lo normal, que era lo que se esperaba de este experimento y se concluye que en general los usuarios evalúan de manera similar todas las dimensiones de tal manera que sus notas suelen caer en el mismo nivel.
Conclusiones
Dentro de las conclusiones más importantes de este trabajo destaca:
El sabor es la dimensión más importante al momento de ponerle nota a una cerveza, destacando tanto en los experimentos 1, 2 y 4.
Existen características específicas que afectan la nota final que no se obtienen de manera directa de las dimensiones (“sabor a café”, “mala espuma” y “rápido desvanecimiento”). Para poder rescatarlas es necesario realizar un análisis de palabras de los comentarios realizados a las cervezas.
Existen 2 grandes grupos de comentarios: comentarios regulares y comentarios buenos. Lo comentarios malos son raros en la base de datos en términos de frecuencia.
Si se continuase con el trabajo realizado se seguirían las siguientes líneas de investigación que no se alcanzaron a abordar en esta ocasión:
Continuar con el trabajo del experimento de regresiones
Trabajar los modelos incluyendo medida de palabras “buenas” y “malas” en los comentarios
Utilizar los clusters de pertenencias en las regresiones y cuantificar importancia