Clasificación del género de usuarios de Twitter
MJ
Febrero de 2018
Introducción
El objetivo del proyecto es la creación de un modelo de aprendizaje automático que determine el sexo de un usuario de Twitter (mujer, hombre o marca) a través de un tweet elegido de forma aleatoria y de datos generales de su perfil de Twitter.
Este informe describe los pasos realizados para la carga, limpieza y exploración de los datos de entrada que se utilizarán para entrenar y evaluar los modelos.
Descripción de los datos
Los datos utilizados son:
- Conjunto de datos principal que contiene el género de un número limitado de usuarios de Twitter. Los datos se describen y están disponibles en Kaggle.
- Base de datos de ciudades del mundo que incluye su zona horaria, así como la lista de zonas horarias y abreviaturas más comunes para poder interpretar, en la medida de lo posible, la zona horaria del usuario incluida en los datos.
###############################################################################
# Input folders
###############################################################################
f <- "data/gender-classifier-DFE-791531.csv"
c <- "data/databaseCities/allCountries.txt"
tzones <- "data/timezonesAbbreviations.txt"
tznames <- "data/timezonesNamesList.txt"
###############################################################################
# Getting data
###############################################################################
# Reading lines and converting to a dataframe
enUStwitter <- read.csv(f, sep = ",", dec = ".", header = TRUE,
skipNul = TRUE, comment.char = "", row.names = NULL,
check.names = FALSE, stringsAsFactors = FALSE)
# City-Timezone database
citiestz <- read.csv(c, sep="\t", stringsAsFactors = FALSE,header=FALSE)
citytz <- data.frame(citiestz$V3, citiestz$V18, stringsAsFactors = FALSE)
colnames(citytz) <- c("asciiname","timezone")
citytz <- citytz[!grepl("\t",citytz$asciiname),]
# Create timezone abbreviations database:
tzabb <- read.csv(tzones, sep = "\t", stringsAsFactors = FALSE,
fileEncoding= "UTF8")
tzabb <- tzabb[!duplicated(tzabb$Abbr.),]
tznames <- read.csv(tznames, sep = "\t", stringsAsFactors = FALSE,
fileEncoding= "UTF8")
tznames <- data.frame(tznames$TZ,gsub(":00","",paste0("UTC",tznames$UTC.offset),
fixed = TRUE), stringsAsFactors = FALSE)
colnames(tznames) <- c("TZ","UTC.offset")
tzddbb <- merge(tzabb,tznames)
tzddbb <- tzddbb[!duplicated(tzddbb$Abbr),]A continuación se muestra distintos aspectos del archivo que contiene el conjunto de datos principal:
# Summary of the file
fSize <- file.info(f)$size / (1024^2) #MB
twitter <- lapply(enUStwitter$text,nchar)
maxLength <- twitter[which.max(twitter)] #Greater than 140/280 due to emojis
minLength <- twitter[which.min(twitter)]
nbrLines <- length(twitter)
nbrWords <- sum(sapply(strsplit(enUStwitter$text,"\\s+"), length))
source <- c("Twitter")
att <- c("Fuente", "Tamaño (MB)", "Nr. palabras", "Nr. líneas",
"Mín. tamaño del texto", "Máx. tamaño del texto")
fileDescription <- data.frame(source,fSize,nbrWords,nbrLines,
unlist(minLength),unlist(maxLength))
colnames(fileDescription) <- att
fileDescription## Fuente Tamaño (MB) Nr. palabras Nr. líneas Mín. tamaño del texto
## 1 Twitter 7.797946 310838 20050 6
## Máx. tamaño del texto
## 1 425A modo resumen, el contenido del conjunto de datos inicial es:
###############################################################################
# Data overview
###############################################################################
# Summary
summary(enUStwitter)## _unit_id _golden _unit_state _trusted_judgments
## Min. :815719226 Mode :logical Length:20050 Min. : 3.000
## 1st Qu.:815724318 FALSE:20000 Class :character 1st Qu.: 3.000
## Median :815729384 TRUE :50 Mode :character Median : 3.000
## Mean :815729449 NA's :0 Mean : 3.616
## 3rd Qu.:815734514 3rd Qu.: 3.000
## Max. :815757985 Max. :274.000
##
## _last_judgment_at gender gender:confidence
## Length:20050 Length:20050 Min. :0.0000
## Class :character Class :character 1st Qu.:0.6778
## Mode :character Mode :character Median :1.0000
## Mean :0.8828
## 3rd Qu.:1.0000
## Max. :1.0000
## NA's :26
## profile_yn profile_yn:confidence created
## Length:20050 Min. :0.6272 Length:20050
## Class :character 1st Qu.:1.0000 Class :character
## Mode :character Median :1.0000 Mode :character
## Mean :0.9932
## 3rd Qu.:1.0000
## Max. :1.0000
##
## description fav_number gender_gold link_color
## Length:20050 Min. : 0 Length:20050 Length:20050
## Class :character 1st Qu.: 11 Class :character Class :character
## Mode :character Median : 456 Mode :character Mode :character
## Mean : 4382
## 3rd Qu.: 3316
## Max. :341621
##
## name profile_yn_gold profileimage
## Length:20050 Length:20050 Length:20050
## Class :character Class :character Class :character
## Mode :character Mode :character Mode :character
##
##
##
##
## retweet_count sidebar_color text
## Min. : 0.0000 Length:20050 Length:20050
## 1st Qu.: 0.0000 Class :character Class :character
## Median : 0.0000 Mode :character Mode :character
## Mean : 0.0794
## 3rd Qu.: 0.0000
## Max. :330.0000
##
## tweet_coord tweet_count tweet_created
## Length:20050 Min. : 1 Length:20050
## Class :character 1st Qu.: 2398 Class :character
## Mode :character Median : 11442 Mode :character
## Mean : 38925
## 3rd Qu.: 40028
## Max. :2680199
##
## tweet_id tweet_location user_timezone
## Min. :6.587e+17 Length:20050 Length:20050
## 1st Qu.:6.587e+17 Class :character Class :character
## Median :6.587e+17 Mode :character Mode :character
## Mean :6.587e+17
## 3rd Qu.:6.587e+17
## Max. :6.587e+17
## Como ejemplo, se muestran las 6 primeras filas:
# Head
head(enUStwitter)## _unit_id _golden _unit_state _trusted_judgments _last_judgment_at
## 1 815719226 FALSE finalized 3 10/26/15 23:24
## 2 815719227 FALSE finalized 3 10/26/15 23:30
## 3 815719228 FALSE finalized 3 10/26/15 23:33
## 4 815719229 FALSE finalized 3 10/26/15 23:10
## 5 815719230 FALSE finalized 3 10/27/15 1:15
## 6 815719231 FALSE finalized 3 10/27/15 1:47
## gender gender:confidence profile_yn profile_yn:confidence created
## 1 male 1.0000 yes 1 12/5/13 1:48
## 2 male 1.0000 yes 1 10/1/12 13:51
## 3 male 0.6625 yes 1 11/28/14 11:30
## 4 male 1.0000 yes 1 6/11/09 22:39
## 5 female 1.0000 yes 1 4/16/14 13:23
## 6 female 1.0000 yes 1 3/11/10 18:14
## description
## 1 i sing my own rhythm.
## 2 I'm the author of novels filled with family drama and romance.
## 3 louis whining and squealing and all
## 4 Mobile guy. 49ers, Shazam, Google, Kleiner Perkins, Yahoo!, Sprint PCS, AirTouch, Air Force. Stanford GSB, UVa. Dad, Husband, Brother. Golfer.
## 5 Ricky Wilson The Best FRONTMAN/Kaiser Chiefs The Best BAND Xxxx Thank you Kaiser Chiefs for an incredible year of gigs and memories to cherish always :) Xxxxxxx
## 6 you don't know me.
## fav_number gender_gold link_color name profile_yn_gold
## 1 0 08C2C2 sheezy0
## 2 68 0084B4 DavdBurnett
## 3 7696 ABB8C2 lwtprettylaugh
## 4 202 0084B4 douggarland
## 5 37318 3B94D9 WilfordGemma
## 6 3901 F5ABB5 monroevicious
## profileimage
## 1 https://pbs.twimg.com/profile_images/414342229096808449/fYvzqXN7_normal.png
## 2 https://pbs.twimg.com/profile_images/539604221532700673/WW16tBbU_normal.jpeg
## 3 https://pbs.twimg.com/profile_images/657330418249658368/SBLCXdF7_normal.png
## 4 https://pbs.twimg.com/profile_images/259703936/IMG_8444_normal.JPG
## 5 https://pbs.twimg.com/profile_images/564094871032446976/AOfpk-mr_normal.jpeg
## 6 https://pbs.twimg.com/profile_images/656336865033850880/ougQS3q7_normal.jpg
## retweet_count sidebar_color
## 1 0 FFFFFF
## 2 0 C0DEED
## 3 1 C0DEED
## 4 0 C0DEED
## 5 0 0
## 6 0 0
## text
## 1 Robbie E Responds To Critics After Win Against Eddie Edwards In The #WorldTitleSeries https://t.co/NSybBmVjKZ
## 2 ÛÏIt felt like they were my friends and I was living the story with themÛ https://t.co/arngE0YHNO #retired #IAN1 https://t.co/CIzCANPQFz
## 3 i absolutely adore when louis starts the songs it hits me hard but it feels good
## 4 Hi @JordanSpieth - Looking at the url - do you use @IFTTT?! Don't typically see an advanced user on the @PGATOUR! https://t.co/H68ou5PE9L
## 5 Watching Neighbours on Sky+ catching up with the Neighbs!! Xxx _Ù÷Ä_Ù÷Ä_Ù÷Ä_ÙÔÎ_ÙÈ_ÙÔ_ÙÈ Xxx
## 6 Ive seen people on the train with lamps, chairs, tvs etc https://t.co/w6zf4pVM4I
## tweet_coord tweet_count tweet_created tweet_id tweet_location
## 1 110964 10/26/15 12:40 6.5873e+17 main; @Kan1shk3
## 2 7471 10/26/15 12:40 6.5873e+17
## 3 5617 10/26/15 12:40 6.5873e+17 clcncl
## 4 1693 10/26/15 12:40 6.5873e+17 Palo Alto, CA
## 5 31462 10/26/15 12:40 6.5873e+17
## 6 20036 10/26/15 12:40 6.5873e+17 New York Gritty
## user_timezone
## 1 Chennai
## 2 Eastern Time (US & Canada)
## 3 Belgrade
## 4 Pacific Time (US & Canada)
## 5
## 6 Central Time (US & Canada)Se observa que hay textos de tweets que superan el máximo número de caracteres permitidos en Twitter. En concreto, el texto de tweet más corto del conjunto de datos es:
# Example shortest line:
enUStwitter$text[which.min(twitter)]## [1] "#NAME?"Y el más largo es debido a la decodificación de emojis:
# Example largest line:
enUStwitter$text[which.max(twitter)]## [1] "When You A Trap Wife and Everybody wants you _Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷__Ù÷_"Limpieza de los datos
El conjunto de datos principal va a comenzar el proceso de limpieza y transformación para dar lugar al conjunto de datos que se utilizará para nuestro análisis. A grosso modo, el proceso consistirá en:
- Utilización de la zona horaria del usuario para referir todas las fechas aportadas en el conjunto de datos a la misma zona horaria (GMT), para así poder operar, minimizando el error cometido, y calcular nuevos features como el número de tweets enviados por día desde la fecha que se creó el perfil de Twitter hasta el momento en el que se capturaron los datos (aproximado).
- Limpiar tanto el texto del tweet como la descripción del perfil del usuario. El proceso de limpieza consta de los siguientes pasos:
- Decodificar correctamente posibles caracteres HTML.
- Escribir correctamente abreviaturas.
- Extraer caracteres no ASCII que suelen corresponder a emojis.
- Eliminar del texto las cadenas de caracteres creadas por ser un retweet. Si un tweet es un retweet, el texto del tweet no sería característico del usuario, sólo el hecho de “retweetear” en principio. Por tanto, aunque en este informe no se ha hecho, al utilizarse el texto del tweet como feature, estos datos deberían eliminarse.
- Extraer referencias a enlaces web.
- Extraer referencias a emails.
- Extraer tags, bien típicos de Twitter u otros.
- Extraer hashtags.
- Eliminar números del texto.
- Evitar contracciones del inglés sustituyéndolas por su versión completa, en la medida de lo posible.
- El texto que contiene sólo palabras tras este proceso de limpieza (también elimina signos de puntuación por ejemplo) se encontraría en otro feature en el data set, y sería convertido a minúsculas.
- Crear un feature que indique si se disponen o no de las coordenadas del tweet.
- Crear otros features como el número de emails en el texto del tweet o en la descripción del perfil que puedan ayudar a caracterizar el comportamiento del usuario de Twitter según su género.
El único elemento que no se considera en este momento es la imagen de perfil o los emojis del texto.
Se muestra a modo ilustrativo el ejemplo para el usuario con id 815719375. En el caso de dicho usuario, el texto del tweet antes de ser procesado era:
# Example of tweet after cleaning process:
enUStwitter$text[enUStwitter$`_unit_id`=="815719375"]## [1] "ÛÏ@thacelebritea Seen on the Scene: Spotted #RavenSymone out and about earlier this week [r.p @theybfdaily ] https://t.co/sjNH93a0L3Û ÷¼ü÷¼ü÷¼ü"Tras el proceso de limpieza, el texto es como sigue:
# Example of tweet after cleaning process:
tidytwitter$text[tidytwitter$`_unit_id`=="815719375"]## [1] "@ Seen on the Scene: Spotted out and about earlier this week [r.p @ ]"Y si se eliminan todo lo que no sean palabras, quedaría:
# Example of tweet after cleaning process:
tidytwitter$textWords[tidytwitter$`_unit_id`=="815719375"]## [1] "seen on the scene spotted out and about earlier this week r p"El nuevo conjunto de datos tras este proceso de transformación para este usuario concreto es:
# Example of data frame now:
tidytwitter[tidytwitter$`_unit_id`=="815719375",]## _unit_id _golden _unit_state _trusted_judgments _last_judgment_at
## 150 815719375 FALSE finalized 3 10/27/15 1:43
## gender gender:confidence profile_yn profile_yn:confidence created
## 150 female 1 yes 1 3/1/15 22:10
## description
## 150 24/CreoleMixed/BornInNewOrleans,RaisedInTexas/Love God,Family,Friends,Education,$,Sleep,Text,Food,Movies,Music,Clothes, Makeup,Nature,Animals & Colors.
## fav_number gender_gold link_color name profile_yn_gold
## 150 3 D02B55 msrainerain
## profileimage
## 150 https://pbs.twimg.com/profile_images/649838232021004289/qG3uu_gw_normal.jpg
## retweet_count sidebar_color
## 150 0 829D5E
## text
## 150 @ Seen on the Scene: Spotted out and about earlier this week [r.p @ ]
## tweet_coord tweet_count tweet_created tweet_id tweet_location
## 150 45295 10/26/15 12:40 6.5873e+17 Houston,Tx
## user_timezone profile_creation tweet_creation
## 150 2015-03-01 21:10:00 2015-10-26 11:40:00
## part_day_creation last_judgement_date profileDays tweetsPerDay
## 150 Late_morning 2015-10-27 01:43:00 239.0181 189.5045
## retweetsPerDay yearProfile monthProfile
## 150 0 2015 3
## nonASCIIText
## 150 ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?
## nonASCIIDesc RetweetOrigin URLsText URLsDesc EmailsText
## 150 NA NA https://t.co/sjNH93a0L3 NA NA
## EmailsDesc TwitterTagsText TwitterTagsDesc OtherTagsText
## 150 NA @thacelebritea, @theybfdaily NA @, @
## OtherTagsDesc HashTagsText HashTagsDesc
## 150 NA #RavenSymone NA
## textWords
## 150 seen on the scene spotted out and about earlier this week r p
## descriptionWords
## 150 creolemixed borninneworleans raisedintexas love god family friends education sleep text food movies music clothes makeup nature animals colors
## hasCoordinates nbrnonASCIIText nbrnonASCIIDesc nbrRetweetOrigin
## 150 FALSE 24 0 0
## nbrURLsText nbrURLsDesc nbrEmailsText nbrEmailsDesc nbrTwitterTagsText
## 150 1 0 0 0 2
## nbrTwitterTagsDesc nbrOtherTagsText nbrOtherTagsDesc nbrTotalTagsText
## 150 0 2 0 4
## nbrTotalTagsDesc nbrHashTagsText nbrHashTagsDesc
## 150 0 1 0Finalmente, extraemos la parte del conjunto de datos para el benchmarking final. Seguiremos la clasificación realizada por el equipo que creó este conjunto de datos, aunque, tras el proceso de limpieza, para el testeo sólo se cuentan con 48 muestras de las casi 20000 muestras válidas, muestra insuficiente, pero que nos va a ayudar a la comparación de resultados.
###############################################################################
# Extracting gold standard data.
###############################################################################
# Removing samples without sex information or "unknown" gender:
# unique(tidytwitter$gender)
tidytwitter <- tidytwitter[tidytwitter$gender!="",]
tidytwitter <- tidytwitter[tidytwitter$gender!="unknown",]
# Extracting gold standard data for final benchmarking:
tidytwitterGold <- tidytwitter[tidytwitter$`_golden`,]
# sum(grepl("male",tidytwitterGold$gender))
# sum(grepl("female",tidytwitterGold$gender))
# sum(grepl("brand",tidytwitterGold$gender))
tidytwitterData <- tidytwitter[!tidytwitter$`_golden`,]
# sum(grepl("male",tidytwitterData$gender))
# sum(grepl("female",tidytwitterData$gender))
# sum(grepl("brand",tidytwitterData$gender))
# Data is inconsistent in the gender for golden data
# Gender_gold is considered according to the documentation
# unique(tidytwitterGold[,c("gender_gold","gender")])
tidytwitterGold$gender <- gsub("female.*","female",tidytwitterGold$gender_gold)
tidytwitterGold$gender <- gsub("male.*","male",tidytwitterGold$gender_gold)
tidytwitterGold <- tidytwitterGold[tidytwitterGold$gender!="unknown",]
# unique(tidytwitterGold[,c("gender_gold","gender")])
# Removing irrelevant columns such as Gender_gold,_last_jugment_at...:
columns <- c("tweet_created","_golden","_unit_state","gender_gold"
,"_last_judgment_at","_trusted_judgments","created",
"profile_yn_gold", "profileimage", "tweet_id")
tidytwitterGold <- tidytwitterGold[,!(names(tidytwitterGold) %in% columns)]
tidytwitterData <- tidytwitterData[,!(names(tidytwitterData) %in% columns)]Las dimensiones del conjunto de datos para entrenamiento del algoritmo son:
dim(tidytwitterData)## [1] 18786 56Mientras que las dimensiones del conjunto de datos para la evaluación final son:
dim(tidytwitterGold)## [1] 48 56Exploración de los datos
En esta etapa se realizará la exploración de los datos que comenzará observando las palabras que utilizan los usuarios del mismo género en el texto del tweet y en la descripción de su perfil, además de apoyarnos en un algoritmo de aprendizaje no supervisado para explorar dichos campos.
Finalmente se realizarán gráficas interactivas para la visualización del comportamiento de los campos del conjunto de datos con respecto a nuestra variable objetivo.
Análisis del texto del tweet
Para realizar un análisis más significativo del texto, se eliminarán las stopwords, se considerarán las raíces de las palabras (stemming) y sólo aquellas con una longitud mayor a un carácter.
###############################################################################
###############################################################################
# Exploratory analysis
###############################################################################
###############################################################################
# Quanteda is not available for this R version
# Going ahead with tm package
library(tm)
library(wordcloud)
###############################################################################
# Text analysis
###############################################################################
# By now, gender:confidence and profile_yn:confidence are not used.
# Plot confidence for Data data set:
vsMales <- VectorSource(
tidytwitterData$textWords[tidytwitterData$gender=="male"])
vsFemales <- VectorSource(
tidytwitterData$textWords[tidytwitterData$gender=="female"])
vsBrand <- VectorSource(
tidytwitterData$textWords[tidytwitterData$gender=="brand"])
vsAll <- VectorSource(tidytwitterData$textWords)
docsMales <- Corpus(vsMales)
docsFemales <- Corpus(vsFemales)
docsBrands <- Corpus(vsBrand)
docsAll <- Corpus(vsAll)
# Eliminating stopwords:
docsMales <- tm_map(docsMales, removeWords, stopwords("english"))
docsFemales <- tm_map(docsFemales, removeWords, stopwords("english"))
docsBrands <- tm_map(docsBrands, removeWords, stopwords("english"))
docsAll <- tm_map(docsAll, removeWords, stopwords("english"))
# Eliminating radicals:
docsMales <- tm_map(docsMales, stemDocument, language = "english")
docsFemales <- tm_map(docsFemales, stemDocument, language = "english")
docsBrands <- tm_map(docsBrands, stemDocument, language = "english")
docsAll <- tm_map(docsAll, stemDocument, language = "english")
# # Step discarded... awkard results plus
# # https://www.r-bloggers.com/
# # help-stemming-and-stem-completion-with-package-tm-in-r/
# # Creating a dictionary to be used for stemcompletion:
# docsAll <- tm_map(docsAll, removeWords, stopwords("english"))
# # Completing radicals as words
# docsMales <- tm_map(docsMales,
# stemCompletion,
# dictionary=docsAll,
# type = "shortest")
# docsFemales <- tm_map(docsFemales,
# stemCompletion,
# dictionary=docsAll,
# type = "shortest")
# docsBrands <- tm_map(docsBrands,
# stemCompletion,
# dictionary=docsAll,
# type = "shortest")
# Building Term frequency matrix
# Based on below matrix, many data mining tasks can be done, for example,
# clustering, classification and association analysis:
malesTDM <- TermDocumentMatrix(docsMales,
control=list(
bounds = list(
minWordLength= 1, global = c(1,Inf))))
femalesTDM <- TermDocumentMatrix(docsFemales,
control=list(
bounds = list(
minWordLength= 1, global = c(1,Inf))))
brandsTDM <- TermDocumentMatrix(docsBrands,
control=list(
bounds = list(
minWordLength= 1, global = c(1,Inf))))
allTDM <- TermDocumentMatrix(docsAll,
control=list(
bounds = list(
minWordLength= 1, global = c(2,Inf))))
# findAssocs(____TDM, "term", correlation_limit) is good to find how terms
# are related. For instance:
# > findAssocs(brandsTDM, "weather", 0.3)
# $weather
# updat channel get
# 0.98 0.98 0.88
#
# > ?findAssocs
# > findAssocs(malesTDM, "weather", 0.3)
# $weather
# numeric(0)
#
# > findAssocs(femalesTDM, "weather", 0.3)
# $weather
# channel
# 0.45
# > findAssocs(brandsTDM, c("weather","updat","channel"), 0.3)
# $weather
# get
# 0.88
#
# $updat
# get
# 0.86
#
# $channel
# get
# 0.86
# > findAssocs(brandsTDM, c("weather","updat","channel","love"), 0.3)
# $weather
# get
# 0.88
#
# $updat
# get
# 0.86
#
# $channel
# get
# 0.86
#
# $love
# fool
# 0.39
# findAssocs(allTDM,"male", 0.01)
# findAssocs(allTDM, "female",0.001)
# findAssocs(allTDM, "brand",0.01)
# findFreqTerms(___TDM, lowfreq=10) is good to find the most frequent terms
# but I do not like this method because it does not order it depending
# on how often the term appears. I rather prefer the following:
males <- as.matrix(malesTDM)
vmales <- sort(rowSums(males), decreasing = TRUE)
dmales <- data.frame(Word = names(vmales), Frequency = vmales)
dmales$Word <- factor(dmales$Word, levels =
dmales$Word[order(dmales$Frequency)])
females <- as.matrix(femalesTDM)
vfemales <- sort(rowSums(females), decreasing = TRUE)
dfemales <- data.frame(Word = names(vfemales), Frequency = vfemales)
dfemales$Word <- factor(dfemales$Word, levels =
dfemales$Word[order(dfemales$Frequency)])
brands <- as.matrix(brandsTDM)
vbrands <- sort(rowSums(brands), decreasing = TRUE)
dbrands <- data.frame(Word = names(vbrands), Frequency = vbrands)
dbrands$Word <- factor(dbrands$Word, levels =
dbrands$Word[order(dbrands$Frequency)])A partir de la frecuencia con la que los usuarios de Twitter de los distintos géneros utilizan cada uno de los términos, se determinará la probabilidad de pertenecer a un cierto género dada la frase escrita en el tweet o la descripción de su perfil.
# Merging all together to compute required probabilities:
m <- as.data.table(dmales)
f <- as.data.table(dfemales)
b <- as.data.table(dbrands)
termProb <- merge(m,f,all=TRUE,by = "Word",suffixes = c(".m",".f"))
termProb <- merge(termProb,b, all=TRUE, by = "Word")
colnames(termProb)[4] <- "Frequency.b"
for (i in names(termProb)){
set(termProb, which(is.na(termProb[[i]])),i,0)
}
# Deleting terms that are said more than 3 times:
termProb$TotalFrequency <- (termProb$Frequency.b
+ termProb$Frequency.m + termProb$Frequency.f)
termProb <- termProb[termProb$TotalFrequency > 3,]
# Setting to 1 for the zero-frequency problem
for (i in names(termProb)){
set(termProb, which(termProb[[i]]==0),i,1)
}
termProb$TotalFrequency <- (termProb$Frequency.b
+ termProb$Frequency.m + termProb$Frequency.f)
# Computing frequencies:
termProb$WordProb <- termProb$TotalFrequency / sum(termProb$TotalFrequency)
termProb$probMale <- termProb$Frequency.m / sum(termProb$Frequency.m)
termProb$probFemale <- termProb$Frequency.f / sum(termProb$Frequency.f)
termProb$probBrand <- termProb$Frequency.b / sum(termProb$Frequency.b)
pFemale <- sum(termProb$Frequency.f)/sum(termProb$TotalFrequency)
pMale <- sum(termProb$Frequency.m)/sum(termProb$TotalFrequency)
pBrand <- sum(termProb$Frequency.b)/sum(termProb$TotalFrequency)
head(termProb)## Word Frequency.m Frequency.f Frequency.b TotalFrequency WordProb
## 1: typic 1 3 1 5 4.011811e-05
## 2: kindl 1 1 3 5 4.011811e-05
## 3: fortun 1 4 2 7 5.616535e-05
## 4: grate 1 6 1 8 6.418897e-05
## 5: bizarr 1 4 2 7 5.616535e-05
## 6: infidel 1 1 2 4 3.209449e-05
## probMale probFemale probBrand
## 1: 2.367256e-05 6.831223e-05 2.599225e-05
## 2: 2.367256e-05 2.277074e-05 7.797676e-05
## 3: 2.367256e-05 9.108298e-05 5.198451e-05
## 4: 2.367256e-05 1.366245e-04 2.599225e-05
## 5: 2.367256e-05 9.108298e-05 5.198451e-05
## 6: 2.367256e-05 2.277074e-05 5.198451e-05Como ejemplo, la probabilidad de ser mujer dado que se ha escrito los términos 1 y 5 de dicha tabla es:
# As an example, the probability of being woman given that the terms
# of the text used are 1 & 5 is:
(pFemale * termProb$probFemale[1] * termProb$probFemale[5]/
(termProb$WordProb[1]*termProb$WordProb[5]))## [1] 0.973016Esta solución supone, aunque sabemos que no es cierto, que el uso de cada uno de los términos en el texto o la descripción del perfil es un suceso independiente. Es decir, palabras como “amor” y “pareja” apareciendo en la misma frase son sucesoss aleatorios independientes, por lo que la probabilidad de escribirlos ambos es el producto de las probabilidades de que cada uno de ellos haya sido escrito.
En el caso de los hombres, los términos más frecuentes aparecen reflejados en el siguiente wordcloud y gráfica:
###############################################################################
# Males
###############################################################################
# Wordcloud
pal <- brewer.pal(9, "BuGn")
pal <- pal[-(1:4)]
wordcloud(dmales$Word, dmales$Frequency, min.freq=100, colors = pal)
# 20 most common unigrams
g <- ggplot(dmales[1:20,], aes(x = Word, y = Frequency))
g <- g + geom_bar(stat = "identity") + coord_flip()
g <- g + ggtitle("Las 20 palabras más frecuentes usadas por hombres")
g
# Number of words to get 50% - 90% of the instances for males
# Of a total of 8743 words, 50% of the instances in text would be achieved
# with 425 words while 90% with 4007 words
cum <- cumsum(dmales$Frequency)
cut50 <- 0.5 * sum(dmales$Frequency)
words50 <- length(cum) - sum(cum > cut50) + 1
cut90 <- 0.9 * sum(dmales$Frequency)
words90 <- length(cum) - sum(cum > cut90) + 1Teniendo en cuenta que el conjunto de textos de los tweets tienen un total de 8743 palabras, el 50% de los términos usados en el texto se alcanzarían con 425 palabras, mientras que el 90% se alcanza con 4007.
Repetimos el análisis para el caso de las mujeres, observando los términos más frecuentes:
###############################################################################
# Females
###############################################################################
# Wordcloud
wordcloud(dfemales$Word, dfemales$Frequency, min.freq=100, colors = pal)
# 20 most common unigrams
g <- ggplot(dfemales[1:20,], aes(x = Word, y = Frequency))
g <- g + geom_bar(stat = "identity") + coord_flip()
g <- g + ggtitle("Las 20 palabras más frecuentes usadas por mujeres")
g
# Number of words to get 50% - 90% of the instances for males
# Of a total of 8743 words, 50% of the instances in text would be achieved
# with 425 words while 90% with 4007 words
cum <- cumsum(dfemales$Frequency)
cut50 <- 0.5 * sum(dfemales$Frequency)
words50 <- length(cum) - sum(cum > cut50) + 1
cut90 <- 0.9 * sum(dfemales$Frequency)
words90 <- length(cum) - sum(cum > cut90) + 1En este caso, el conjunto de textos de los tweets tienen un total de 8289 palabras, el 50% de los términos usados en el texto se alcanzarían con 320 palabras, mientras que el 90% se alcanza con 3631.
Por último, los tweets de marcas o empresas utilizan los siguientes términos:
###############################################################################
# Brands
###############################################################################
# Wordcloud
wordcloud(dbrands$Word, dbrands$Frequency, min.freq=100, colors = pal)
# 20 most common unigrams
g <- ggplot(dbrands[1:20,], aes(x = Word, y = Frequency))
g <- g + geom_bar(stat = "identity") + coord_flip()
g <- g + ggtitle("Las 20 palabras más frecuentes usadas por marcas")
g
# Number of words to get 50% - 90% of the instances for males
# Of a total of 8743 words, 50% of the instances in text would be achieved
# with 425 words while 90% with 4007 words
cum <- cumsum(dbrands$Frequency)
cut50 <- 0.5 * sum(dbrands$Frequency)
words50 <- length(cum) - sum(cum > cut50) + 1
cut90 <- 0.9 * sum(dbrands$Frequency)
words90 <- length(cum) - sum(cum > cut90) + 1El conjunto de textos de los tweets tienen un total de 8366 palabras, el 50% de los términos usados en el texto se alcanzarían con 382 palabras, mientras que el 90% se alcanza con 4040.
Análisis de la descripción del perfil
El mismo análisis realizado para el texto del tweet se puede repetir para la descripción del perfil de Twitter de los usuarios, creando la tabla de probabilidades que nos permitirá calcular la probabilidad de ser hombre, mujer o marca dados los términos usados en la descripción del perfil de Twitter.
###############################################################################
# Description analysis
###############################################################################
vsMales <- VectorSource(
tidytwitterData$descriptionWords[tidytwitterData$gender=="male"])
vsFemales <- VectorSource(
tidytwitterData$descriptionWords[tidytwitterData$gender=="female"])
vsBrand <- VectorSource(
tidytwitterData$descriptionWords[tidytwitterData$gender=="brand"])
vsAll <- VectorSource(tidytwitterData$descriptionWords)
docsMales <- Corpus(vsMales)
docsFemales <- Corpus(vsFemales)
docsBrands <- Corpus(vsBrand)
docsAll <- Corpus(vsAll)
# Eliminating stopwords:
docsMales <- tm_map(docsMales, removeWords, stopwords("english"))
docsFemales <- tm_map(docsFemales, removeWords, stopwords("english"))
docsBrands <- tm_map(docsBrands, removeWords, stopwords("english"))
docsAll <- tm_map(docsAll, removeWords, stopwords("english"))
# Eliminating radicals:
docsMales <- tm_map(docsMales, stemDocument, language = "english")
docsFemales <- tm_map(docsFemales, stemDocument, language = "english")
docsBrands <- tm_map(docsBrands, stemDocument, language = "english")
docsAll <- tm_map(docsAll, stemDocument, language = "english")
# Building Term frequency matrix
# Based on below matrix, many data mining tasks can be done, for example,
# clustering, classification and association analysis:
malesTDM <- TermDocumentMatrix(docsMales,
control=list(
bounds = list(
minWordLength= 1, global = c(1,Inf))))
femalesTDM <- TermDocumentMatrix(docsFemales,
control=list(
bounds = list(
minWordLength= 1, global = c(1,Inf))))
brandsTDM <- TermDocumentMatrix(docsBrands,
control=list(
bounds = list(
minWordLength= 1, global = c(1,Inf))))
allTDMDesc <- TermDocumentMatrix(docsAll,
control=list(
bounds = list(
minWordLength= 1, global = c(2,Inf))))
# Exploring data:
males <- as.matrix(malesTDM)
vmales <- sort(rowSums(males), decreasing = TRUE)
dmales <- data.frame(Word = names(vmales), Frequency = vmales)
dmales$Word <- factor(dmales$Word, levels =
dmales$Word[order(dmales$Frequency)])
females <- as.matrix(femalesTDM)
vfemales <- sort(rowSums(females), decreasing = TRUE)
dfemales <- data.frame(Word = names(vfemales), Frequency = vfemales)
dfemales$Word <- factor(dfemales$Word, levels =
dfemales$Word[order(dfemales$Frequency)])
brands <- as.matrix(brandsTDM)
vbrands <- sort(rowSums(brands), decreasing = TRUE)
dbrands <- data.frame(Word = names(vbrands), Frequency = vbrands)
dbrands$Word <- factor(dbrands$Word, levels =
dbrands$Word[order(dbrands$Frequency)])
# Merging all together to compute required probabilities:
m <- as.data.table(dmales)
f <- as.data.table(dfemales)
b <- as.data.table(dbrands)
termDProb <- merge(m,f,all=TRUE,by = "Word",suffixes = c(".m",".f"))
termDProb <- merge(termDProb,b, all=TRUE, by = "Word")
colnames(termDProb)[4] <- "Frequency.b"
for (i in names(termDProb)){
set(termDProb, which(is.na(termDProb[[i]])),i,0)
}
# Deleting terms that are said more than 3 times:
termDProb$TotalFrequency <- (termDProb$Frequency.b
+ termDProb$Frequency.m + termDProb$Frequency.f)
termDProb <- termDProb[termDProb$TotalFrequency > 3,]
# Setting to 1 for the zero-frequency problem
for (i in names(termDProb)){
set(termDProb, which(termDProb[[i]]==0),i,1)
}
termDProb$TotalFrequency <- (termDProb$Frequency.b
+ termDProb$Frequency.m + termDProb$Frequency.f)
# Computing frequencies:
termDProb$WordProb <- termDProb$TotalFrequency / sum(termDProb$TotalFrequency)
termDProb$probMale <- termDProb$Frequency.m / sum(termDProb$Frequency.m)
termDProb$probFemale <- termDProb$Frequency.f / sum(termDProb$Frequency.f)
termDProb$probBrand <- termDProb$Frequency.b / sum(termDProb$Frequency.b)
pDFemale <- sum(termDProb$Frequency.f)/sum(termDProb$TotalFrequency)
pDMale <- sum(termDProb$Frequency.m)/sum(termDProb$TotalFrequency)
pDBrand <- sum(termDProb$Frequency.b)/sum(termDProb$TotalFrequency)
head(termDProb)## Word Frequency.m Frequency.f Frequency.b TotalFrequency WordProb
## 1: yahoo 1 1 3 5 4.861874e-05
## 2: nude 1 2 6 9 8.751373e-05
## 3: cornwal 1 2 1 4 3.889499e-05
## 4: spici 1 2 1 4 3.889499e-05
## 5: anyhow 1 1 3 5 4.861874e-05
## 6: mar 1 4 1 6 5.834249e-05
## probMale probFemale probBrand
## 1: 2.778627e-05 3.087087e-05 8.705998e-05
## 2: 2.778627e-05 6.174173e-05 1.741200e-04
## 3: 2.778627e-05 6.174173e-05 2.901999e-05
## 4: 2.778627e-05 6.174173e-05 2.901999e-05
## 5: 2.778627e-05 3.087087e-05 8.705998e-05
## 6: 2.778627e-05 1.234835e-04 2.901999e-05El cálculo se realizaría de la misma manera. A modo ejemplo, se proporciona la probabilidad de ser mujer visto que la descripción del perfil de Twitter ha usado los términos 1 y 5 de la tabla de probabilidades:
# As an example, the probability of being woman given that the terms
# of the description used are 1 & 5 is:
(pDFemale * termDProb$probFemale[1] * termDProb$probFemale[5]/
(termDProb$WordProb[1]*termDProb$WordProb[5]))## [1] 0.1269916En el caso de los hombres, las palabras más usadas para la descripción de su perfil son:
###############################################################################
# Males
###############################################################################
# Wordcloud
pal <- brewer.pal(9, "BuGn")
pal <- pal[-(1:4)]
wordcloud(dmales$Word, dmales$Frequency, min.freq=100, colors = pal)
# 20 most common unigrams
g <- ggplot(dmales[1:20,], aes(x = Word, y = Frequency))
g <- g + geom_bar(stat = "identity") + coord_flip()
g <- g + ggtitle("Las 20 palabras más frecuentes usadas por hombres")
g
# Number of words to get 50% - 90% of the instances for males
# Of a total of 8743 words, 50% of the instances in text would be achieved
# with 425 words while 90% with 4007 words
cum <- cumsum(dmales$Frequency)
cut50 <- 0.5 * sum(dmales$Frequency)
words50 <- length(cum) - sum(cum > cut50) + 1
cut90 <- 0.9 * sum(dmales$Frequency)
words90 <- length(cum) - sum(cum > cut90) + 1El conjunto de textos de las descripciones de perfil de los hombres tienen un total de 10211 palabras, el 50% de los términos usados en el texto se alcanzarían con 533 palabras, mientras que el 90% se alcanza con 5917.
El mismo ejercicio se realiza para las mujeres:
###############################################################################
# Females
###############################################################################
# Wordcloud
wordcloud(dfemales$Word, dfemales$Frequency, min.freq=100, colors = pal)
# 20 most common unigrams
g <- ggplot(dfemales[1:20,], aes(x = Word, y = Frequency))
g <- g + geom_bar(stat = "identity") + coord_flip()
g <- g + ggtitle("Las 20 palabras más frecuentes usadas por mujeres")
g
# Number of words to get 50% - 90% of the instances for males
# Of a total of 8743 words, 50% of the instances in text would be achieved
# with 425 words while 90% with 4007 words
cum <- cumsum(dfemales$Frequency)
cut50 <- 0.5 * sum(dfemales$Frequency)
words50 <- length(cum) - sum(cum > cut50) + 1
cut90 <- 0.9 * sum(dfemales$Frequency)
words90 <- length(cum) - sum(cum > cut90) + 1El conjunto de textos de las descripciones de perfil de las mujeres tienen un total de 9665 palabras, el 50% de los términos usados en el texto se alcanzarían con 521 palabras, mientras que el 90% se alcanza con 5789.
Para finalizar, en el caso de las marcas:
###############################################################################
# Brands
###############################################################################
# Wordcloud
wordcloud(dbrands$Word, dbrands$Frequency, min.freq=100, colors = pal)
# 20 most common unigrams
g <- ggplot(dbrands[1:20,], aes(x = Word, y = Frequency))
g <- g + geom_bar(stat = "identity") + coord_flip()
g <- g + ggtitle("Las 20 palabras más frecuentes usadas por marcas")
g
# Number of words to get 50% - 90% of the instances for males
# Of a total of 8743 words, 50% of the instances in text would be achieved
# with 425 words while 90% with 4007 words
cum <- cumsum(dbrands$Frequency)
cut50 <- 0.5 * sum(dbrands$Frequency)
words50 <- length(cum) - sum(cum > cut50) + 1
cut90 <- 0.9 * sum(dbrands$Frequency)
words90 <- length(cum) - sum(cum > cut90) + 1El conjunto de textos de las descripciones de perfil de las marcas tienen un total de 7727 palabras, el 50% de los términos usados en el texto se alcanzarían con 378 palabras, mientras que el 90% se alcanza con 3863.
Método de aprendizaje no supervisado
Los términos utilizados tanto en el texto de los tweets como en la descripción pueden analizarse a través de modelos de aprendizaje no supervisados. En nuestro caso, pese a que lo usual en este tipo de análisis es discernir el número de “topics” que se encuentran en el texto, utilizaremos kmeans para intentar crear tres clústers, uno por género.
En este caso, estamos asumiendo que habrá “topics” que sean característicos de los géneros y que se puedan agrupar entre sí.
###############################################################################
# Clustering: K-means
###############################################################################
# There are three groups so we will set k means clusters to 3:
set.seed(1121983)
kmeansTDM <- kmeans(allTDM,3)
set.seed(1121983)
kmeansTDMdesc <- kmeans(allTDMDesc,3)# If we check the elements of the clusters created:
# Cluster 1 is for brands:
c1 <- names(kmeansTDM$cluster[kmeansTDM$cluster == 1])
# Cluster two seems common words between genders:
c2 <- names(kmeansTDM$cluster[kmeansTDM$cluster == 2])
# Cluster three have lot of terms:
c3 <- names(kmeansTDM$cluster[kmeansTDM$cluster == 3])Tras analizar los términos utilizados en los textos de los tweets, se observa que el primer clúster contiene palabras más frecuentes con los perfiles de Twitter de “marcas”:
# Wordcloud
pal <- brewer.pal(9, "BuGn")
pal <- pal[-(1:4)]
wordcloud(c1, rep.int(1, length(c1)), min.freq=1, colors = pal)
El tercer clúster está formado por palabras populares entre todos los géneros:
wordcloud(c3, rep.int(1, length(c3)), min.freq=1, colors = pal)
Mientras que el segundo clúster contiene el resto de palabras.
# If we check the elements of the clusters created:
# Cluster 1 is for brands:
c1des <- names(kmeansTDMdesc$cluster[kmeansTDMdesc$cluster == 1])
# Cluster two seems common words between genders:
c2des <- names(kmeansTDMdesc$cluster[kmeansTDMdesc$cluster == 2])
# Cluster three have lot of terms:
c3des <- names(kmeansTDMdesc$cluster[kmeansTDMdesc$cluster == 3])En el caso de la descripción del perfil de Twitter, el primer clúster contiene una única palabra, frecuente en todos los géneros aunque mayormente usada por mujeres:
wordcloud(c3des, rep.int(1, length(c3des)), min.freq=1, colors = pal)
Transformación de los campos de texto
Gracias al algoritmo de aprendizaje no supervisado y a esta fase de análisis exploratorio de los datos, hemos observado como hay términos que caracterizan algunas de las categorías objetivo.
A continuación, se calculan las probabilidades de ser hombre, mujer o marca según el texto del tweet y la descripción del perfil, lo cuál nos dará seis características adicionales que se añadirán al conjunto de datos. De esta forma, campos de caracteres se han transformado en valores numéricos usando los mismos principios que las redes Bayesianas, aunque al considerar que los términos son independientes entre sí, la red Bayesiana sería del tipo Naive Bayes.
Sin embargo, una característica que nos puede resultar más útil que la probabilidad, es el ratio entre probabilidades. Por ejemplo, la probabilidad de que el texto haya sido escrito por una mujer dividida entre la suma de probabilidades de que haya sido escrito por un hombre o por una marca. Procederemos al cálculo de dicho ratio.
Configuración de los colores
El color del enlace al perfil de Twitter así como de la barra lateral pueden ser características claves para determinar el género del usuario.
En el conjunto de datos se muestra en valores hexadecimales. Por comodidad lo transformaremos a valores numéricos, descartando las muestras que no contienen valores hexadecimales válidos.
La dimensión final del conjunto de datos gold es (48, 68) mientras que la dimensión del conjunto de datos mayoritario es (18745, 68).
Visualización gráfica
Como fase final de la exploración de los datos, se realizarán varias gráficas interactivas - las más representativas - dónde se podrá observar los valores de algunos de los features del conjunto de datos para cada uno de los géneros bajo estudio.
La primera gráfica muestra el histograma de los años y meses de creación del mismo para cada uno de los géneros bajo estudio, para observar si hay algún patrón temporal relevante (como podría ser creación de perfiles de Twitter por marcas en Navidad o por hombres/mujeres en verano):
g1 <- ggplot(tidytwitterData, aes(yearProfile, color=gender))
g1 <- g1 + geom_histogram(stat = "count") + facet_grid(gender~.)
g1 <- g1 + ggtitle("Creación del perfil") + theme(legend.position="none")
g1 <- g1 + xlab("Año de creación del perfil de Twitter")
g2 <- ggplot(tidytwitterData, aes(monthProfile, color=gender))
g2 <- g2 + geom_histogram(stat = "count") + facet_grid(gender~.)
g2 <- g2 + ggtitle("Creación del perfil") + theme(legend.position="none")
g2 <- g2 + xlab("Mes de creación del perfil de Twitter")
g <- subplot(g1, g2, titleX = TRUE, titleY = TRUE, margin=0.05)
ggplotly(g)El color del enlace al perfil y de la barra lateral también pueden ser variables importantes a considerar para discernir el género del usuario de Twitter:
g <- ggplot(tidytwitterData, aes(as.factor(link_color), color=gender))
g <- g + geom_histogram(stat = "count") + facet_grid(gender~.)
g <- g + ggtitle("Uso del color") + theme(legend.position="none")
g <- g + xlab("Color del enlace de perfil (hexadecimal)")
ggplotly(g)g <- ggplot(tidytwitterData, aes(as.factor(sidebar_color), color=gender))
g <- g + geom_histogram(stat = "count") + facet_grid(gender~.)
g <- g + ggtitle("Uso del color") + theme(legend.position="none")
g <- g + xlab("Color de la barra lateral del perfil (hexadecimal)")
ggplotly(g)Es asombroso el número de tweets al día que se pueden llegar a publicar en algunos perfiles de Twitter. Comprobando algunos de los casos, se observa que, pese a la descripción proporcionada en el conjunto de datos, hay más de un tweet en el conjunto de datos procedente de la misma cuenta de Twitter.
g <- ggplot(tidytwitterData, aes(tweetsPerDay, retweetsPerDay, color=gender))
g <- g + geom_count() + ggtitle("Uso diario de Twitter")
g <- g + xlab("Número de tweets al día") + ylab("Número de retweets al día")
g <- g + facet_grid(gender~.) + theme(legend.position="none")
ggplotly(g)El número de caracteres no ASCII podría corresponder, entre otros, a emojis e iconos.
g <- ggplot(tidytwitterData, aes(nbrnonASCIIDesc, nbrnonASCIIText,
color=gender)) + geom_count()
g <- g + ggtitle("Caracteres no ASCII")
g <- g + xlab("Caracteres no ASCII en la descripción")
g <- g + ylab("Caracteres no ASCII en el tweet")
g <- g + facet_grid(gender~.) + theme(legend.position="none")
ggplotly(g)Resulta especialmente relevante el ratio de probabilidades creado para discernir si un texto, bien el del tweet o el de la descripción del perfil, ha sido escrito por un hombre, una mujer o una marca, aunque es importante tener en cuenta que, para que resulten relevantes también en el conjunto de datos de benchmarking final, el conjunto de datos de entrenamiento debe ser suficientemente representativo de las tendencias y conjuntos de palabras que los usuarios Twitter suelen usar globalmente:
g1 <- ggplot(data = tidytwitterData, aes(gender
,textFemaleRatio
,fill=gender))
g1 <- g1 + geom_boxplot() + xlab("Género") + theme(legend.position="none")
g1 <- g1 + ylab("Ratio que indica si el texto es de una mujer")
g1 <- g1 + ggtitle("Ratios creados para la categoría mujer")
g2 <- ggplot(data = tidytwitterData, aes(gender
,descFemaleRatio
,fill=gender))
g2 <- g2 + geom_boxplot() + xlab("Género") + theme(legend.position="none")
g2 <- g2 + ylab("Ratio que indica si la descripción es de una mujer")
g2 <- g2 + ggtitle("Ratios creados para la categoría mujer")
g <- subplot(g1, g2, titleX = TRUE, titleY = TRUE, margin=0.05)
ggplotly(g)g1 <- ggplot(data = tidytwitterData, aes(gender
,textMaleRatio
,fill=gender))
g1 <- g1 + geom_boxplot() + xlab("Género") + theme(legend.position="none")
g1 <- g1 + ylab("Ratio que indica si el texto es de un hombre")
g1 <- g1 + ggtitle("Ratios creados para la categoría hombre")
g2 <- ggplot(data = tidytwitterData, aes(gender
,descMaleRatio
,fill=gender))
g2 <- g2 + geom_boxplot() + xlab("Género") + theme(legend.position="none")
g2 <- g2 + ylab("Ratio que indica si la descripción es de un hombre")
g2 <- g2 + ggtitle("Ratios creados para la categoría hombre")
g <- subplot(g1, g2, titleX = TRUE, titleY = TRUE, margin=0.05)
ggplotly(g)g1 <- ggplot(data = tidytwitterData, aes(gender
,textBrandRatio
,fill=gender))
g1 <- g1 + geom_boxplot() + xlab("Género") + theme(legend.position="none")
g1 <- g1 + ylab("Ratio que indica si el texto es de una marca")
g1 <- g1 + ggtitle("Ratios creados para la categoría marca")
g2 <- ggplot(data = tidytwitterData, aes(gender
,descBrandRatio
,fill=gender))
g2 <- g2 + geom_boxplot() + xlab("Género") + theme(legend.position="none")
g2 <- g2 + ylab("Ratio que indica si la descripción es de una marca")
g2 <- g2 + ggtitle("Ratios creados para la categoría marca")
g <- subplot(g1, g2, titleX = TRUE, titleY = TRUE, margin=0.05)
ggplotly(g)Por último, se muestran los valores de otros features por género:
g <- ggplot(tidytwitterData, aes(fav_number, nbrRetweetOrigin, color=gender))
g <- g + geom_count() + ggtitle("Valores de los features por género")
g <- g + xlab("Número de tweets favoritos") + ylab("Número de retweets del tweet")
g <- g + facet_grid(gender~.) + theme(legend.position="none")
ggplotly(g)g <- ggplot(tidytwitterData, aes(x=nbrURLsDesc, y=nbrURLsText,
color=gender)) + geom_count()
g <- g + ggtitle("Valores de los features por género")
g <- g + xlab("URLs en la descripción")
g <- g + ylab("URLs en el tweet")
g <- g + facet_grid(gender~.) + theme(legend.position="none")
ggplotly(g)g <- ggplot(tidytwitterData, aes(x=nbrEmailsDesc, y=nbrEmailsText,
color=gender)) + geom_count()
g <- g + ggtitle("Valores de los features por género")
g <- g + xlab("Número de emails en la descripción")
g <- g + ylab("Número de emails en el tweet")
g <- g + facet_grid(gender~.) + theme(legend.position="none")
ggplotly(g)g <- ggplot(tidytwitterData, aes(x=nbrTotalTagsDesc, y=nbrTotalTagsText,
color=gender)) + geom_count()
g <- g + ggtitle("Valores de los features por género")
g <- g + xlab("Número total de tags en la descripción")
g <- g + ylab("Número total de tags en el tweet")
g <- g + facet_grid(gender~.) + theme(legend.position="none")
ggplotly(g)g <- ggplot(tidytwitterData, aes(x=nbrHashTagsDesc, y=nbrHashTagsText,
color=gender)) + geom_count()
g <- g + ggtitle("Valores de los features por género")
g <- g + xlab("Número de hashtags en la descripción")
g <- g + ylab("Número de hashtags en el tweet")
ggplotly(g)Modelado
Una vez realizada la exploración de los datos, y tras conocer el conjunto de datos en profundidad - preseleccionando aquellas variables que queremos usar -, nos disponemos a elegir, construir y optimizar un modelo de aprendizaje automático supervisado que serán comparados y evaluados posteriormente.
División del conjunto de datos
El primer paso será dividir el conjunto de datos en training (80%) y test (20%), teniendo en cuenta que ya reservamos el conjunto de datos de 48 muestras, catalogados como “gold standard” para la evaluación final. Con esta nueva división, pretendemos utilizar sólo el conjunto “training” para entrenar los modelos, y realizaremos la evaluación tanto con el conjunto “test” como con el conjunto “gold” en la siguiente sección.
# Create test and training data sets
set.seed(1121983)
index <- createDataPartition(tidytwitterData$gender, p=0.8, list=F)
training <- tidytwitterData[index,]
test <- tidytwitterData[-index,]
gold <- tidytwitterGoldSe observa que las proporciones de muestras de cada género en el conjunto de datos de entrenamiento y de testeo se mantienen:
# Proportions are mantained:
prop.table(table(training$gender))##
## brand female male
## 0.3159965 0.3558045 0.3281990prop.table(table(test$gender))##
## brand female male
## 0.3159018 0.3559232 0.3281750Mientras que el conjunto de datos gold standard mantiene las siguientes proporciones:
prop.table(table(gold$gender))##
## brand female male
## 0.2708333 0.3125000 0.4166667Selección de predictores
En primer lugar, se eliminan aquellas variables que se han creado para dar paso a otras o que ya sabemos que no queremos utilizar.
# Removing unnecessary columns:
columns <- c("nonASCIIText","nonASCIIDesc","URLsText","URLsDesc"
,"EmailsText","EmailsDesc","TwitterTagsText",
"TwitterTagsDesc", "OtherTagsText", "OtherTagsDesc"
,"HashTagsText","HashTagsDesc","textWords",
"descriptionWords", "text", "description", "genderNum", "name",
"profile_yn","tweet_coord","RetweetOrigin","gender:confidence",
"profile_yn:confidence","tweet_location","user_timezone"
,"profile_filenames","download_profile","last_judgement_date"
,"profile_creation","tweet_creation","_unit_id"
,"part_day_creation","textFromFemale","textFromMale",
"textFromBrand", "descFromFemale", "descFromMale",
"descFromBrand")
gold <- gold[,!(names(gold) %in% columns)]
training <- training[,!(names(training) %in% columns)]
test <- test[,!(names(test) %in% columns)]
# Has coordinates from bolean to numeric:
gold$hasCoordinates <- as.numeric(gold$hasCoordinates)
training$hasCoordinates <- as.numeric(training$hasCoordinates)
test$hasCoordinates <- as.numeric(test$hasCoordinates)En segundo lugar, gracias a la correlación de las variables predictoras, se observa que el número de Twitter u otros “tags” usados correla con el número total de tags, variable creada a partir de ellos dos. Por este motivo, en el modelado se eliminará esta variable.
matCor <- cor(tidytwitterData[,c("fav_number","tweetsPerDay"
,"retweetsPerDay"
,"nbrnonASCIIText"
,"nbrnonASCIIDesc","nbrRetweetOrigin"
,"nbrURLsText","nbrURLsDesc","nbrEmailsText"
,"nbrEmailsDesc","nbrTwitterTagsText"
,"nbrTwitterTagsDesc","nbrOtherTagsText"
,"nbrOtherTagsDesc","nbrTotalTagsText"
,"nbrTotalTagsDesc","nbrHashTagsText"
,"nbrHashTagsDesc","textFemaleRatio"
, "textMaleRatio", "textBrandRatio"
, "descFemaleRatio", "descMaleRatio"
, "descBrandRatio")])
corrplot(matCor, type = "upper", tl.col = "black", method = "circle")
# Avoiding features where correlation is higher than threshold
corrthr = 0.8
featToDelete <- findCorrelation(matCor,cutoff=corrthr,names=TRUE)
gold <- gold[,!(names(gold) %in% featToDelete)]
training <- training[,!(names(training) %in% featToDelete)]
test <- test[,!(names(test) %in% featToDelete)]Finalmente se eliminan variables con poca o nula variabilidad:
#Near zero var:
zeroVarTraining <- nearZeroVar(training[,!(names(training) %in% c("gender"))]
, saveMetrics=F )
colnames(training)[zeroVarTraining]## [1] "link_color" "tweetsPerDay" "monthProfile"
## [4] "nbrnonASCIIText" "nbrnonASCIIDesc" "nbrURLsDesc"
## [7] "nbrEmailsText" "nbrTwitterTagsText"# Removing zero variance columns
training <- training[,-zeroVarTraining]
test <- test[,-zeroVarTraining]
gold <- gold[,-zeroVarTraining]Como último paso, utilizaremos un algoritmo recursivo de selección de features para ver qué otras variables podrían ser eliminadas:
# Splitting features and outcome
outcome <- "gender"
newPredictVar <- training[, !(names(training) %in% outcome)]
outcomeVar <- as.factor(training[,outcome])
# Configuring RFE
numFeat <- dim(newPredictVar)[2]
meth <- "cv" #cross-validation
kfold <- 10
control <- rfeControl(functions=rfFuncs, method=meth, number=kfold)
set.seed(1121983)
featSelect <- rfe(newPredictVar, outcomeVar,
sizes=seq(1,numFeat,3),rfeControl=control)Podemos visualizar los resultados:
plot(featSelect, type=c("g", "o"))
# Summarize the results
featSelect##
## Recursive feature selection
##
## Outer resampling method: Cross-Validated (10 fold)
##
## Resampling performance over subset size:
##
## Variables Accuracy Kappa AccuracySD KappaSD Selected
## 1 0.5076 0.2646 0.008651 0.01302
## 4 0.6947 0.5400 0.023165 0.03448
## 7 0.7177 0.5746 0.009138 0.01358
## 10 0.7339 0.5997 0.011898 0.01793
## 13 0.7433 0.6139 0.011901 0.01791
## 16 0.7485 0.6217 0.012876 0.01937
## 19 0.7510 0.6255 0.013687 0.02065
## 22 0.7523 0.6274 0.013690 0.02061 *
## 25 0.7505 0.6246 0.014208 0.02136
## 28 0.7523 0.6274 0.011929 0.01795
##
## The top 5 variables (out of 22):
## descMaleRatio, descFromMale, textFromMale, descFromFemale, descFemaleRatioAcorde a este algoritmo, la lista de features que se deben usar es:
# list the chosen features
featToKeep <- predictors(featSelect)
featToKeep## [1] "descMaleRatio" "descFromMale" "textFromMale"
## [4] "descFromFemale" "descFemaleRatio" "textMaleRatio"
## [7] "descBrandRatio" "descFromBrand" "textFemaleRatio"
## [10] "textBrandRatio" "textFromFemale" "textFromBrand"
## [13] "fav_number" "profileDays" "tweet_count"
## [16] "yearProfile" "nbrURLsText" "nbrHashTagsText"
## [19] "nbrOtherTagsText" "nbrHashTagsDesc" "sidebar_color"
## [22] "nbrOtherTagsDesc"Algoritmo de aprendizaje supervisado
El algoritmo de aprendizaje automático supervisado que se va a usar en este proyecto será random forest, uno de los algoritmos de clasificación más populares.
Este modelo, en el paquete caret, tiene dos parámetros que pueden ser optimizados:
- mtry: el número de variables muestreadas aleatoriamente como candidatas a cada división.
- ntree: el número de árboles a entrenar.
Los modelos que se construirán serán:
- Modelo por defecto en el que tanto mtry y ntree tendrán los valores recomendados o que vienen por defecto.
# Default RF: recommended values
control <- trainControl(method="repeatedcv", number= 10, repeats=3)
mtry <- sqrt(ncol(training)-1)
set.seed(1121983)
tunegrid <- expand.grid(.mtry = mtry)
rf.def.model <- train(gender~., data=training,
method="rf",
metric = "Accuracy",
tuneGrid = tunegrid,
trControl=control)
rf.def.model## Random Forest
##
## 14997 samples
## 28 predictor
## 3 classes: 'brand', 'female', 'male'
##
## No pre-processing
## Resampling: Cross-Validated (10 fold, repeated 3 times)
## Summary of sample sizes: 13498, 13497, 13498, 13496, 13497, 13498, ...
## Resampling results:
##
## Accuracy Kappa
## 0.7513498 0.625914
##
## Tuning parameter 'mtry' was held constant at a value of 5.291503- Modelo con búsqueda aleatoria del valor mtry adecuado.
# Random Search
control <- trainControl(method="repeatedcv",
number=10,
repeats=3,
search="random")
set.seed(1121983)
rf.rand.model <- train(gender~., data=training,
method="rf",
metric="Accuracy",
tuneLength=15,
trControl=control)
print(rf.rand.model)## Random Forest
##
## 14997 samples
## 28 predictor
## 3 classes: 'brand', 'female', 'male'
##
## No pre-processing
## Resampling: Cross-Validated (10 fold, repeated 3 times)
## Summary of sample sizes: 13498, 13497, 13498, 13496, 13497, 13498, ...
## Resampling results across tuning parameters:
##
## mtry Accuracy Kappa
## 1 0.7493271 0.6220510
## 6 0.7517278 0.6264880
## 7 0.7500163 0.6239345
## 10 0.7505276 0.6247075
## 12 0.7487267 0.6220307
## 13 0.7495720 0.6232790
## 15 0.7483941 0.6215231
## 18 0.7487932 0.6221338
## 21 0.7465488 0.6187574
## 26 0.7468596 0.6192514
##
## Accuracy was used to select the optimal model using the largest value.
## The final value used for the model was mtry = 6.plot(rf.rand.model)
- Modelo dónde se buscará el parámetro mtry adecuado en dentro de un conjunto de valores dados en un grid.
control <- trainControl(method="repeatedcv",
number=10,
repeats=3,
search="grid")
set.seed(1121983)
tunegrid <- expand.grid(.mtry=c(1:15))
rf.gridsearch <- train(gender~., data=training,
method="rf",
metric="Accuracy",
tuneGrid=tunegrid,
trControl=control)
print(rf.gridsearch)## Random Forest
##
## 14997 samples
## 28 predictor
## 3 classes: 'brand', 'female', 'male'
##
## No pre-processing
## Resampling: Cross-Validated (10 fold, repeated 3 times)
## Summary of sample sizes: 13498, 13497, 13498, 13496, 13497, 13498, ...
## Resampling results across tuning parameters:
##
## mtry Accuracy Kappa
## 1 0.7495716 0.6224164
## 2 0.7536843 0.6293096
## 3 0.7536175 0.6293228
## 4 0.7520389 0.6269490
## 5 0.7510613 0.6254993
## 6 0.7514165 0.6260297
## 7 0.7511944 0.6257217
## 8 0.7502833 0.6243316
## 9 0.7498609 0.6237055
## 10 0.7500384 0.6239752
## 11 0.7491939 0.6227135
## 12 0.7490824 0.6225460
## 13 0.7479269 0.6208042
## 14 0.7487271 0.6220253
## 15 0.7480378 0.6209840
##
## Accuracy was used to select the optimal model using the largest value.
## The final value used for the model was mtry = 2.plot(rf.gridsearch)
- Modelo dónde de forma manual se probará con distintos valores de ntree para distintos valores de mtry dados en un grid.
# Manual Search
control <- trainControl(method="repeatedcv",
number=10,
repeats=3,
search="grid")
tunegrid <- expand.grid(.mtry=c(sqrt(ncol(training)-1)))
modellist <- list()
for (ntree in c(50, 100, 500, 1000, 1500, 2000, 2500)) {
set.seed(1121983)
fit <- train(gender~., data=training,
method="rf",
metric="Accuracy",
tuneGrid=tunegrid,
trControl=control,
ntree=ntree)
key <- toString(ntree)
modellist[[key]] <- fit
}# Manual Search
for (ntree in c(50, 100, 500, 1000, 1500, 2000, 2500)) {
key <- toString(ntree)
print(paste0("Model: Random Forest ntree ", key))
print(modellist[[key]])
}## [1] "Model: Random Forest ntree 50"
## Random Forest
##
## 14997 samples
## 28 predictor
## 3 classes: 'brand', 'female', 'male'
##
## No pre-processing
## Resampling: Cross-Validated (10 fold, repeated 3 times)
## Summary of sample sizes: 13498, 13497, 13498, 13496, 13497, 13498, ...
## Resampling results:
##
## Accuracy Kappa
## 0.7467936 0.619131
##
## Tuning parameter 'mtry' was held constant at a value of 5.291503
## [1] "Model: Random Forest ntree 100"
## Random Forest
##
## 14997 samples
## 28 predictor
## 3 classes: 'brand', 'female', 'male'
##
## No pre-processing
## Resampling: Cross-Validated (10 fold, repeated 3 times)
## Summary of sample sizes: 13498, 13497, 13498, 13496, 13497, 13498, ...
## Resampling results:
##
## Accuracy Kappa
## 0.7489495 0.6223322
##
## Tuning parameter 'mtry' was held constant at a value of 5.291503
## [1] "Model: Random Forest ntree 500"
## Random Forest
##
## 14997 samples
## 28 predictor
## 3 classes: 'brand', 'female', 'male'
##
## No pre-processing
## Resampling: Cross-Validated (10 fold, repeated 3 times)
## Summary of sample sizes: 13498, 13497, 13498, 13496, 13497, 13498, ...
## Resampling results:
##
## Accuracy Kappa
## 0.7513498 0.625914
##
## Tuning parameter 'mtry' was held constant at a value of 5.291503
## [1] "Model: Random Forest ntree 1000"
## Random Forest
##
## 14997 samples
## 28 predictor
## 3 classes: 'brand', 'female', 'male'
##
## No pre-processing
## Resampling: Cross-Validated (10 fold, repeated 3 times)
## Summary of sample sizes: 13498, 13497, 13498, 13496, 13497, 13498, ...
## Resampling results:
##
## Accuracy Kappa
## 0.7513723 0.6259528
##
## Tuning parameter 'mtry' was held constant at a value of 5.291503
## [1] "Model: Random Forest ntree 1500"
## Random Forest
##
## 14997 samples
## 28 predictor
## 3 classes: 'brand', 'female', 'male'
##
## No pre-processing
## Resampling: Cross-Validated (10 fold, repeated 3 times)
## Summary of sample sizes: 13498, 13497, 13498, 13496, 13497, 13498, ...
## Resampling results:
##
## Accuracy Kappa
## 0.7511054 0.6255484
##
## Tuning parameter 'mtry' was held constant at a value of 5.291503
## [1] "Model: Random Forest ntree 2000"
## Random Forest
##
## 14997 samples
## 28 predictor
## 3 classes: 'brand', 'female', 'male'
##
## No pre-processing
## Resampling: Cross-Validated (10 fold, repeated 3 times)
## Summary of sample sizes: 13498, 13497, 13498, 13496, 13497, 13498, ...
## Resampling results:
##
## Accuracy Kappa
## 0.7515277 0.6261858
##
## Tuning parameter 'mtry' was held constant at a value of 5.291503
## [1] "Model: Random Forest ntree 2500"
## Random Forest
##
## 14997 samples
## 28 predictor
## 3 classes: 'brand', 'female', 'male'
##
## No pre-processing
## Resampling: Cross-Validated (10 fold, repeated 3 times)
## Summary of sample sizes: 13498, 13497, 13498, 13496, 13497, 13498, ...
## Resampling results:
##
## Accuracy Kappa
## 0.751639 0.6263433
##
## Tuning parameter 'mtry' was held constant at a value of 5.291503# Adding the other models:
modellist[["default"]] <- rf.def.model
modellist[["randomSearch"]] <- rf.rand.model
modellist[["gridSearch"]] <- rf.gridsearchLos modelos entrenados serán evaluados y comparados en la siguiente sección.
Evaluación y comparación de modelos
Se finaliza el proyecto con la evaluación y comparación de los modelos supervisados entrenados en la sección anterior.
# compare results
results <- resamples(modellist)
summary(results)##
## Call:
## summary.resamples(object = results)
##
## Models: 50, 100, 500, 1000, 1500, 2000, 2500, default, randomSearch, gridSearch
## Number of resamples: 30
##
## Accuracy
## Min. 1st Qu. Median Mean 3rd Qu. Max. NA's
## 50 0.7171 0.7380 0.7480 0.7468 0.7550 0.7872 0
## 100 0.7185 0.7418 0.7506 0.7489 0.7573 0.7852 0
## 500 0.7231 0.7417 0.7516 0.7513 0.7578 0.7832 0
## 1000 0.7252 0.7402 0.7523 0.7514 0.7600 0.7839 0
## 1500 0.7265 0.7407 0.7526 0.7511 0.7587 0.7839 0
## 2000 0.7265 0.7411 0.7523 0.7515 0.7603 0.7839 0
## 2500 0.7298 0.7409 0.7522 0.7516 0.7593 0.7832 0
## default 0.7231 0.7417 0.7516 0.7513 0.7578 0.7832 0
## randomSearch 0.7285 0.7419 0.7520 0.7517 0.7611 0.7799 0
## gridSearch 0.7318 0.7458 0.7536 0.7537 0.7610 0.7852 0
##
## Kappa
## Min. 1st Qu. Median Mean 3rd Qu. Max. NA's
## 50 0.5744 0.6059 0.6208 0.6191 0.6312 0.6801 0
## 100 0.5764 0.6116 0.6246 0.6223 0.6348 0.6768 0
## 500 0.5834 0.6115 0.6262 0.6259 0.6355 0.6738 0
## 1000 0.5864 0.6090 0.6271 0.6260 0.6388 0.6749 0
## 1500 0.5883 0.6100 0.6276 0.6255 0.6370 0.6749 0
## 2000 0.5883 0.6105 0.6274 0.6262 0.6392 0.6748 0
## 2500 0.5934 0.6102 0.6269 0.6263 0.6377 0.6739 0
## default 0.5834 0.6115 0.6262 0.6259 0.6355 0.6738 0
## randomSearch 0.5913 0.6116 0.6268 0.6265 0.6405 0.6688 0
## gridSearch 0.5964 0.6176 0.6289 0.6293 0.6401 0.6767 0bwplot(results)
Como se puede observar, los resultados son muy similares, siendo el valor óptimo el del modelo llamado “gridSearch” en el que se utilizó un grid del parámetro mtry para la optimización del modelo.
Procedemos a obtener las mismas métricas tanto para el conjunto de datos test como para el gold standard, siendo el mismo modelo el que consigue los mejores resultados:
# Test data set
t <- lapply(modellist,predict,test[,!(names(test) %in% c("gender"))])
cm <- lapply(t,confusionMatrix,test$gender)
tab <- sapply(cm,function(x) (x$table))
acc <- sapply(cm,function(x) (x$overall["Accuracy"]))
kap <- sapply(cm,function(x) (x$overall["Kappa"]))
prec <- sapply(cm,function(x) (x$byClass[,"Precision"]))
recall <- sapply(cm,function(x) (x$byClass[,"Recall"]))
f1 <- sapply(cm,function(x) (x$byClass[,"F1"]))
# Using gold data set:
tg <- lapply(modellist,predict,gold[,!(names(gold) %in% c("gender"))])
cmg <- lapply(tg,confusionMatrix,gold$gender)
tabg <- sapply(cmg,function(x) (x$table))
accg <- sapply(cmg,function(x) (x$overall["Accuracy"]))
kapg <- sapply(cmg,function(x) (x$overall["Kappa"]))
sensg <- sapply(cmg,function(x) (x$byClass[,"Sensitivity"]))
specg <- sapply(cmg,function(x) (x$byClass[,"Specificity"]))
precg <- sapply(cmg,function(x) (x$byClass[,"Precision"]))
recallg <- sapply(cmg,function(x) (x$byClass[,"Recall"]))
f1g <- sapply(cmg,function(x) (x$byClass[,"F1"])) # Overall: Accuracy & Kappa
model <- paste0("rf ",gsub(".Accuracy","",names(acc)))
n <- c("Model","Data", "Accuracy", "Kappa")
tmptest <- data.frame(model,dataset ="test",acc,kap, row.names=NULL)
names(tmptest) <- n
tmpgold <- data.frame(model,dataset ="gold",accg,kapg, row.names=NULL)
names(tmpgold) <- n
overall <- rbind(tmptest,tmpgold)
g <- ggplot(overall)
g <- g + geom_point(mapping = aes(Accuracy,Kappa,color=Model, alpha = 0.05))
g <- g + facet_grid(Data~.) + theme(legend.position="none")
g <- g + ggtitle("Comparación de modelos")
g <- g + xlab("Accuracy") + ylab("Kappa")
ggplotly(g)En cambio, si observamos el comportamiento de los modelos para cada uno de los géneros a inferir, las conclusiones son ligeramente diferentes.
# By Class
model <- paste0("rf ",gsub(".Accuracy","",names(acc)))
n <- c("Gender","Model","Data", "Precision", "Recall","F1")
# Brand class
brandtest <- data.frame("brand",model,"test",
t(data.frame(prec)["Class: brand",]),
t(data.frame(recall)["Class: brand",]),
t(data.frame(f1)["Class: brand",]))
names(brandtest) <- n
brandgold <- data.frame("brand",model,"gold",
t(data.frame(precg)["Class: brand",]),
t(data.frame(recallg)["Class: brand",]),
t(data.frame(f1g)["Class: brand",]))
names(brandgold) <- n
# Female class
femtest <- data.frame("female",model,"test",
t(data.frame(prec)["Class: female",]),
t(data.frame(recall)["Class: female",]),
t(data.frame(f1)["Class: female",]))
names(femtest) <- n
femgold <- data.frame("female",model,"gold",
t(data.frame(precg)["Class: female",]),
t(data.frame(recallg)["Class: female",]),
t(data.frame(f1g)["Class: female",]))
names(femgold) <- n
# Male class
maletest <- data.frame("male",model,"test",
t(data.frame(prec)["Class: male",]),
t(data.frame(recall)["Class: male",]),
t(data.frame(f1)["Class: male",]))
names(maletest) <- n
malegold <- data.frame("male",model,"gold",
t(data.frame(precg)["Class: male",]),
t(data.frame(recallg)["Class: male",]),
t(data.frame(f1g)["Class: male",]))
names(malegold) <- n
brand <- rbind(brandtest,brandgold)
female <- rbind(femtest,femgold)
male <- rbind(maletest,malegold)
all <- rbind(brand, female, male)
gb <- ggplot(brand)
gb <- gb + geom_point(mapping = aes(Precision,Recall,color=Model, alpha = 0.05))
gb <- gb + facet_grid(Data~.)
gb <- gb + ggtitle("Comparación de modelos para el género marca")
gb <- gb + xlab("Precision") + ylab("Recall")
ggplotly(gb)gf <- ggplot(female)
gf <- gf + geom_point(mapping = aes(Precision,Recall,color=Model, alpha = 0.05))
gf <- gf + facet_grid(Data~.)
gf <- gf + ggtitle("Comparación de modelos para el género mujer")
gf <- gf + xlab("Precision") + ylab("Recall")
ggplotly(gf)gm <- ggplot(male)
gm <- gm + geom_point(mapping = aes(Precision,Recall,color=Model, alpha = 0.05))
gm <- gm + facet_grid(Data~.)
gm <- gm + ggtitle("Comparación de modelos para el género hombre")
gm <- gm + xlab("Precision") + ylab("Recall")
ggplotly(gm)g <- ggplot(all, aes(x=Model, y=F1, color=Gender, fill=Model))
g <- g + geom_bar(stat= "identity")# mapping = aes(F1,color=Model))
g <- g + facet_grid(Gender ~ Data)
g <- g + theme(legend.position="none",axis.text.x = element_text(
angle = 90, hjust = 1))
g <- g + ggtitle("Comparación de modelos por género")
g <- g + xlab("Model") + ylab("F1")
ggplotly(g)Obtendremos las curvas ROC y el área bajo la curva (AUC) para nuestro mejor modelo cuándo se evalúa en el conjunto de datos test y gold unidos. El resultado es:
## ROC curves sólo para el mejor, con AUC!
bestFit <- modellist$gridSearch
ftest <- rbind(test,gold)
## Predicting
rocPredFTest <- predict(bestFit, ftest[,!(names(ftest) %in% c("gender"))])
prFTestAUC <- c(0,0,0)
colors <- c('red', 'blue', 'green') # 3 colors
genders <- c("brand","male","female")
for (i in 1:length(genders)) {
prFTest <- prediction(ifelse(rocPredFTest == genders[i],1,0),
ifelse(ftest$gender == genders[i],1,0))
prfFTest <- performance(prFTest, measure = "tpr", x.measure = "fpr")
prFTestAUC[i] <-performance(prFTest, measure = "auc")@y.values
plot(prfFTest,add=(i!=1),col=colors[i],lwd=2,lty=i, cex=0.8)
abline(a=0, b= 1)
}
legend("bottomright",legend=paste0(genders," AUC: ",
round(unlist(prFTestAUC),2)),
col=colors, lwd=2, lty=1:3, cex=0.8)
Conclusiones
Sería interesante comparar los resultados con los obtenidos por el proyecto que recopiló este conjunto de datos, en el que sólo indican que el modelo tenía una confianza del 60% cuando predecía el género, ya que esta comparación nos ayudaría a entender si el procesamiento tan exhaustivo del texto de los tweets y de la descripción de perfil, utilizando el teorema de Bayes para obtener nuevos features, nos llevan a conseguir mejores resultados.
Si esa métrica es el accuracy, los resultados han sido mejores en nuestro caso.