Task2.R

library(tm)
library(readr)
library(gridExtra)
library(RColorBrewer)
library(skmeans)
library(dplyr)
library(tidyr)
library(ggplot2)
library(forcats)
library(countrycode)
library(patchwork)
library(corrplot)
library(purrr)
library(stringr)

## Loading out data
# Importing the data we obtained in task1
train_df <- read_csv("original_df.csv")

## General analysis
stat_cols <- c("annotator_id", "gender", "age", "ethnicity", "education", "country", "continent")

# Remove duplicated rows (if they even exist)
stat_df <- train_df[!duplicated(train_df[stat_cols]), ]

# Assure there are no annotators that have disparaging info
bad_ids <- stat_df$annotator_id[duplicated(stat_df$annotator_id)]

if (length(bad_ids) > 0) {cat("Repeated annotator_ids found:\n")
                          print(stat_df[stat_df$annotator_id %in% bad_ids, ])
}

# Function to plot multiple pie plots
plot_pie <- function(data, column) {
  column_sym <- sym(column)
  
  pie_data <- data %>%
    count(!!column_sym) %>%
    mutate(percent = n / sum(n) * 100,
           label = paste0(!!column_sym, " (", round(percent, 1), "%)"))
  
  ggplot(pie_data, aes(x = "", y = n, fill = !!column_sym)) +
    geom_bar(stat = "identity", width = 1) +
    coord_polar("y", start = 0) +
    labs(title = paste("", column), fill = column) +
    theme_void() +
    theme(
      plot.title = element_text(hjust = 0.5, face = "bold")
    ) +
    scale_fill_discrete(
      labels = pie_data$label
    )
}

# Sequentially plot each category to write up conclusions
columns_to_plot <- c("gender", "age", "ethnicity", "education", "country", "continent")
plots <- lapply(columns_to_plot, function(col) plot_pie(stat_df, col))
for (plot in plots) {
  print(plot)
  #readline(prompt = "Press [Enter] to see the next plot...")
}

## CONCLUSION
#' Gender and age are balanced categories 
#' We have an overwhelming number of Caucasians, and an extremely small percent of Middle Easterners, "Other"s and Multiracial people. It's unlikely we can trust a model trained on such a few individuals when it comes to the ethnicity attribute
#' The great majority of people have either an HS degree or a BS, and a few with a MS, the other categories being highly underrepresented
#' As expected a lot of countries will be unrepresented, with the United Kingdom, Poland, Portugal and South Africa having the highest amount of representation. 
#' As to be expected from the last results, most of the annotators are overwhelmingly european. From the get go we can see that this will skew a lot of our results, as it will have a bias towards an "European mindset". Asia is extremely underrepresented.

# Creating a summary of our data -> same as above but in a non visual manner
summarize_categorical <- function(x) {
  tbl <- table(x)
  list(
    mode = names(tbl)[which.max(tbl)],
    freq_table = tbl,
    proportions = prop.table(tbl),
    unique_values = length(unique(x))
  )
}

sum_cols <- c("gender", "age", "ethnicity", "education", "country", "continent")
summary_list <- lapply(stat_df[ , sum_cols], summarize_categorical)

summary_list

## Conclusions
#' Looking at this summary values we can see that we only have 1 ME person, 3 of unknown ethnicity and 5 of Asian/Mixed ethinicity. These, as above seen, are extremely low values and we can't take any conclusions based on ethinicity, especielly because Latins and Blacks are also pretty underrepresented. It may be better to ignore ethinicity all together
#' The same happens with the countries. One thing we could do here would be to create a cluster algorithm to group people by these countries instead of doing it based on the continents 

## TASK 2
# 1: individuals - overall, how likely is any individual to say a tweet is sexist?
# percent of yes/no per person
ind_percents <- train_df %>%
  group_by(annotator_id, label_task1_1) %>%
  summarise(n = n(), .groups = "drop") %>%
  group_by(annotator_id) %>%
  mutate(percent = n / sum(n))

# average of the percents
aver_percents <- ind_percents %>%
  group_by(label_task1_1) %>%
  summarise(avg_percent = mean(percent))

# for the label positioning in the plot
aver_percents <- aver_percents %>%
  arrange(desc(label_task1_1)) %>%
  mutate(
    ypos = cumsum(avg_percent) - 0.5 * avg_percent,
    label = paste0(label_task1_1, ": ", scales::percent(avg_percent, accuracy = 0.1))
  )

# plot pie of the averages
ggplot(aver_percents, aes(x = "", y = avg_percent, fill = label_task1_1)) +
  geom_col(width = 1, color = "white") +
  coord_polar(theta = "y") +
  geom_text(aes(y = ypos, label = label), color = "black", size = 3.5, fontface = "bold") +
  scale_fill_brewer(palette = "Blues") +
  labs(title = "Average Label Percent") +
  theme_void() +
  theme(
    legend.position = "none",
    plot.title = element_text(hjust = 0.5,face = "bold")
  )

# plot individual distributions
ggplot(ind_percents, aes(x = label_task1_1, y = percent)) +
  geom_boxplot(fill = c("lightblue", "lightgreen")) +
  labs(
    title = "Distribution of Percent by Label Task",
    x = "Label",
    y = "Percent"
  ) + 
  theme(
    legend.position = "none",
    plot.title = element_text(hjust = 0.5,face = "bold")
  )

#' CONCLUSIONS:
#' Annotators tend, in general, to label tweets as NOT sexist: there's a slight imbalance in our label data which is something we need to consider when we train our models

# 2: demographics - looking at specific demographics, what can we learn?
demo_vars<- c("gender", "age", "ethnicity", "education", "country", "continent")

# extend df 
demo_df <- train_df %>% pivot_longer(cols = all_of(demo_vars), names_to = "variable", values_to = "value")

# calculate proportions
prop_df <- demo_df %>%
  group_by(variable, value, label_task1_1) %>%
  summarise(n = n(), .groups = "drop") %>%
  group_by(variable, value) %>%
  mutate(percent = n / sum(n) * 100)

# order df by percent of YES for vizualization purposes
ordering_df <- prop_df %>%
  filter(label_task1_1 == "YES") %>%
  group_by(variable) %>%
  arrange(variable, desc(percent)) %>%
  mutate(order = row_number()) %>%
  select(variable, value, order)

prop_df_ordered <- prop_df %>%
  left_join(ordering_df, by = c("variable", "value")) %>%
  group_by(variable) %>%
  mutate(value = fct_reorder(value, order, .desc = FALSE)) %>%
  ungroup()

# plotting demographics
facet_vars <- unique(prop_df_ordered$variable)
angles <- c(0, 0, 90, 0, 0, 0)

plots <- lapply(seq_along(facet_vars), function(i) {
  df_sub <- subset(prop_df_ordered, variable == facet_vars[i])
  df_yes <- df_sub[df_sub$label_task1_1 == "YES", ]
  
  # Count number of groups for dynamic text size
  n_groups <- length(unique(df_sub$value))
  text_size = if (n_groups > 7) 30/n_groups else 3.0
  
  
  ggplot(df_sub, aes(x = value, y = percent, fill = label_task1_1)) +
    geom_bar(stat = "identity", position = "stack") +
    geom_text(
      data = df_yes,
      aes(label = paste0(round(percent, 1), "%")),
      position = position_stack(vjust = 0.5),
      color = "black",
      size = text_size
    ) +
    scale_fill_brewer(palette = "Blues") +
    labs(
      x = NULL,
      y = if (i %% 2 == 1) "Percentage" else NULL,
      fill = "Label",
      title = facet_vars[i]
    ) +
    theme_minimal() +
    theme(
      axis.text.x = element_text(angle = angles[i], hjust = 0.5, face = "bold"),
      plot.title = element_text(hjust = 0.5, face = "bold"),
      axis.title.y = element_text(face = "bold"),
      legend.position = if (i == 2) "right" else "none"
    )
})

wrap_plots(plots, nrow = 3, ncol = 2)

#' CONCLUSIONS:
#' Younger people tend to label things as NOT sexist at a sightly higher proportion than older generations, however it's an almost insignificant margin. Above the age of 23-45 there is basically no difference. 
#' There is onlya very slight difference when looking at the continents. Because of this and the fact that there's an overwhelming majority of european people this could be a category worth discarding.
#' It seems that the higher the education the more likely is someone to label a tweet as sexist. There is also very little difference between people with HS or CE educations (maybe we could join these two categories as being one and the same then). Same tends to happen with people with phd or higher education (as well as the middling education classes).
#' In ethnicity we can find racial groups that have very similar proportions, and in the case of ME we have a steep percent of NOT sexist labeling, however because we also have very few entries of ME people (just the one), this is clearly a sampling bias
#' When it comes to gender, on itself, the variable does not seem to be indicative of if the person would or not label a given tweet as sexist.

## Correlation analysis
to_encode_vars<- c("gender", "age", "ethnicity", "education", "country", "continent", "label_task1_1")
train_encoded <- train_df[to_encode_vars]
train_encoded[to_encode_vars] <- lapply(train_df[to_encode_vars], function(x) as.integer(factor(x)))

cor_matrix <- cor(train_encoded)
custom_col <- colorRampPalette(c("#00688B", "white", "#6B8E23"))(200)

# Plot the correlation matrix
corrplot(cor_matrix, method = "color", col = custom_col,  tl.col = "black", tl.cex = 0.8, tl.srt = 0, tl.pos = "r", is.corr = TRUE, addgrid.col = "white",diag = FALSE, addCoef.col = "black", number.cex = 0.7, cl.pos = "n")

## CONCLUSIONS
#' There seems to be no one to one correlation between any of the variables and our target
#' There are some correlations, but none appear to be too surprising (like country:continent:ethnicity:education) except country:age -> this could indicate that the samples form certain countries were skewed to certain ages (some countries have more aged population however the problem here does not lie with the population in itself but the sample which should have been more uniform among the various countries)

## Combination analysis - combine all possibilities and see which combo outputs the highest/lowest percent of YES 

# First we need to calculate the percent per individual - we already have in a previous step -> ind_percents
# To this df we only want to keep the information about the YES (the NO will be the reverse)
ind_percents <- ind_percents %>%  filter(label_task1_1 != "NO")

# We now add the individual percent to our stat_df
combine_df <- merge(ind_percents, stat_df, by = "annotator_id")

# Deleting unnecessary label column
combine_df <- combine_df %>%
  select(-label_task1_1.x) %>%
  rename(label_task1_1 = label_task1_1.y)

# Country was excluded because it divided too finely
cat_cols <- c("gender", "age", "ethnicity", "education", "continent")
total_rows <- nrow(combine_df)

# Function to compute mean percent, count, and normalized count
compute_combinations <- function(cols) {
  combo_df <- combine_df %>%
    mutate(combo = apply(select(., all_of(cols)), 1, paste, collapse = "_")) %>%
    group_by(combo) %>%
    summarise(
      percent_mean = mean(percent, na.rm = TRUE),
      count = n(),
      normalized_count = count / total_rows,
      .groups = 'drop'
    ) 
  return(combo_df)
}

# Generating all possible combinations 
all_combinations <- map_dfr(2:length(cat_cols),~ map_dfr(combn(cat_cols, .x, simplify = FALSE), compute_combinations))

# Ordering and trimming (if the normalized count is too low means we dont have enough individuals to really make an assertion)
all_combinations_ordered <- all_combinations[order(-all_combinations$count), ]
all_combinations_trim <- all_combinations_ordered[all_combinations_ordered$normalized_count> 0.15, ]

all_combinations_trim

## CONCLUSIONS
#' No combinations of demographics showed 

## Merging demographics
# Based on the previous conclusions, we'll merge certain groups and look to see if there is any significant shift
# In ethnicity we'll have caucasian vs not caucasian
train_df$ethnicity[train_df$ethnicity %in% c("ME", "Ot", "La", "Bl", "Mr", "As")] <- "Not_Ca"
# In continent we'll have eurpean vs not european
train_df$continent[train_df$continent %in% c("Asia", "Americas", "Oceania", "Africa")] <- "Not_Europe"
# In education we'll merge HS with CE as well as PhD with Other (both these categories pairs have similar percents of YES vs NO)
train_df$education[train_df$education %in% c("CE", "HS")] <- "HS_CE"
train_df$education[train_df$education %in% c("PhD", "Other", "MS")] <- "MS+"

# Vizualizing demographics
columns_to_plot <- c("ethnicity", "education", "continent")
plots <- lapply(columns_to_plot, function(col) plot_pie(train_df, col))
for (plot in plots) {
  print(plot)
  #readline(prompt = "Press [Enter] to see the next plot...")
}

# Looking into how it affects the percents of YES:NO
demo_df_comb <- train_df %>% pivot_longer(cols = all_of(columns_to_plot), names_to = "variable", values_to = "value")

demo_df_comb <- subset(demo_df_comb, select = -c(gender, age, country) )

prop_df_comb <- demo_df_comb %>%
  group_by(variable, value, label_task1_1) %>%
  summarise(n = n(), .groups = "drop") %>%
  group_by(variable, value) %>%
  mutate(percent = n / sum(n) * 100)

ordering_df_comb <- prop_df_comb %>%
  filter(label_task1_1 == "YES") %>%
  group_by(variable) %>%
  arrange(variable, desc(percent)) %>%
  mutate(order = row_number()) %>%
  select(variable, value, order)

prop_df_ordered_comb <- prop_df_comb %>%
  left_join(ordering_df_comb, by = c("variable", "value")) %>%
  group_by(variable) %>%
  mutate(value = fct_reorder(value, order, .desc = FALSE)) %>%
  ungroup()

facet_vars <- unique(prop_df_ordered_comb$variable)

plots <- lapply(seq_along(facet_vars), function(i) {
  df_sub <- subset(prop_df_ordered_comb, variable == facet_vars[i])
  df_yes <- df_sub[df_sub$label_task1_1 == "YES", ]
  
  # Count number of groups for dynamic text size
  n_groups <- length(unique(df_sub$value))
  text_size = if (n_groups > 7) 30/n_groups else 3.0
  
  ggplot(df_sub, aes(x = value, y = percent, fill = label_task1_1)) +
    geom_bar(stat = "identity", position = "stack") +
    geom_text(
      data = df_yes,
      aes(label = paste0(round(percent, 1), "%")),
      position = position_stack(vjust = 0.5),
      color = "black",
      size = text_size
    ) +
    scale_fill_brewer(palette = "Blues") +
    labs(
      x = NULL,
      y = if (i == 2) "Percentage" else NULL,
      fill = "Label",
      title = facet_vars[i]
    ) +
    theme_minimal() +
    theme(
      axis.text.x = element_text(angle = 0, hjust = 0.5, face = "bold"),
      plot.title = element_text(hjust = 0.5, face = "bold"),
      axis.title.y = element_text(face = "bold"),
      legend.position = if (i == 1) "right" else "none"
    )
})

wrap_plots(plots, nrow = 3, ncol = 1)

## Conclusion
#' Now that we balanced our classes a bit better we notice that the differences won't be as striking as before: now we only see a slight difference between demographics

## Saving our new classes and excluding country from our demographic variables
train_df <- train_df %>% select(-country)
write.csv(train_df, "original_df.csv", row.names = FALSE)