#---------------------------------------------------------------------------#
# Nom : Ontario.R                                                           #
# Description : Clean obituary data and extract demographic variables       #
# Author(s) : Pietro Violo and Nadine Ouellette                             #
# Date : June 20 2025                                                       #
#---------------------------------------------------------------------------#

# This is essentially the same code as Quebec, on Ontario obituaries

options(scipen = 999)
rm(list = ls())

#---------------------------------------------------------------------------#
# Libraries                                                                 #
#---------------------------------------------------------------------------#

library(tidyverse)
library(ggpubr)
library(xtable)
library(data.table)
library(cld2)
library(gender)
library(stringi)


#---------------------------------------------------------------------------#
# Load obituaries                                                           #
#---------------------------------------------------------------------------#
obituaries <- read.csv("./Mock data/mock_obits_ont.csv") %>% 
  mutate(Name = paste(first_name, last_name),
         Year = year(date_of_death)) %>% 
  rename(Description = obituary_text) %>% 
  as.data.table()

# Standardize text
obituaries[, Description := stri_trans_general(Description, "Latin-ASCII")]
obituaries[, Name := stri_trans_general(Name, "Latin-ASCII")]
obituaries <- obituaries %>% mutate(Description = tolower(Description),
                                    Year = year(date_of_death))

# Identify likely infants
obituaries <- obituaries %>%
  mutate(
    baby = ifelse(str_detect(Name, "((B|b)aby)|(bebe\\b)|(\\bbb\\b)"), TRUE, FALSE),
    baby2 = ifelse(str_detect(Description, "age de \\d{1,2} (mois?|jours?|semaines?)"), TRUE, FALSE),
    baby = ifelse(is.na(baby), baby2, baby)
  ) %>% select(-baby2)


#---------------------------------------------------------------------------#
# Load and clean French obituaries                                          #
#---------------------------------------------------------------------------#

obituaries$language <- cld2::detect_language(obituaries$Description)

obituaries_fr <- obituaries %>%
  filter(language == "fr", Year %in% 2017:2022) %>%
  select(-language)


#---------------------------------------------------------------------------#
# Gender extraction for french obituaries in Ontario                        #
#---------------------------------------------------------------------------#

obituaries_fr <- obituaries_fr %>%
  mutate(
    Woman = str_extract(Description, regex("est decedee? (mme|madame)|le deces de madame|elle laisse dans le deuil|epouse de|elle etait|fille de feu|deces de mme")),
    Man = str_extract(Description, regex("est decede (m\\.|monsieur)|le deces de monsieur|il laisse dans le deuil|epoux de|il etait|fils de feu|deces de (m\\.|monsieur)")),
    gender = case_when(!is.na(Woman) & is.na(Man) ~ "Woman", is.na(Woman) & !is.na(Man) ~ "Man")
  ) %>%
  select(Name, Description, gender, Year, baby)

# Backup gender detection using pronoun frequency
obituaries_fr <- obituaries_fr %>%
  mutate(
    count_il = str_count(Description, "\\bil\\b"),
    count_elle = str_count(Description, "\\belle\\b"),
    gender3 = case_when(count_il > count_elle ~ "Man", count_elle > count_il ~ "Woman", TRUE ~ NA),
    gender = ifelse(is.na(gender), gender3, gender)
  ) %>% select(Name, Description, Year, gender, baby)


#---------------------------------------------------------------------------#
# Age extraction for french obituaries in Quebec                            #
#---------------------------------------------------------------------------#
obituaries_fr <- obituaries_fr %>%
  mutate(
    # Directly extracted ages from normalized French (no accents)
    age1 = as.numeric(str_extract(str_extract(Description, "agee?( de)? \\d{1,3} ans?"), "\\d{1,3}")),
    age2 = as.numeric(str_extract(str_extract(Description, "a \\d{1,3} ans?"), "\\d{1,3}")),
    
    # Extract birth year from description and compute age from obituary Year
    birth_year_desc = as.numeric(str_extract(Description, "\\b(19[0-9]{2}|200[0-9]|201[0-9]|202[0-2])(?=\\s*-)")),
    age3 = ifelse(!is.na(birth_year_desc) & !is.na(Year), Year - birth_year_desc, NA),
    
    # Same for birth year from Name
    birth_year_name = as.numeric(str_extract(Name, "\\b(19[0-9]{2}|200[0-9]|201[0-9]|202[0-2])(?=\\s*-)")),
    age4 = ifelse(!is.na(birth_year_name) & !is.na(Year), Year - birth_year_name, NA)
  ) %>%
  mutate(
    # Combine age signals
    age_at_death = coalesce(age1, age2, age3, age4),
    
    # Handle baby deaths via year ranges or baby flag
    age_at_death = case_when(
      baby == TRUE |
        str_detect(Description, "20(1[7-9]|20|21|22)\\s*-\\s*20(1[7-9]|20|21|22)") ~ 0,
      TRUE ~ age_at_death
    ),
    
    # If age is 0 but no sign it's a child, set to NA
    age_at_death = ifelse(
      age_at_death == 0 &
        !str_detect(Description, "petit ange|fils de|fille de|ses parents|ses grands-parents|enfant de"),
      NA,
      age_at_death
    )
  ) %>%
  select(Name, Description, Year, Gender = gender, age_at_death)


# Save french obituaries which have age at death and gender extracted
save(obituaries_fr, file = "./Data/obituaries_ont_fr.RData")






#---------------------------------------------------------------------------#
# English obituaries in Ontario                                             #
#---------------------------------------------------------------------------#

obituaries_eng <- obituaries %>%
  filter(language == "en", Year %in% 2017:2022) %>%
  select(-language)

# Extract first name
obituaries_eng <- obituaries_eng %>%
  mutate(First_Name = str_extract(Name, "^[^\\s]+"))


#---------------------------------------------------------------------------#
# Gender extraction                                                         #
#---------------------------------------------------------------------------#

# Predict gender from first names
genders <- gender(obituaries_eng$First_Name) %>%
  select(name, proportion_male, proportion_female, gender) %>%
  rename(First_Name = name) %>%
  group_by(First_Name) %>%
  slice(1) %>% ungroup()

obituaries_eng <- obituaries_eng %>%
  left_join(genders, by = "First_Name") %>%
  mutate(
    gender = case_when(
      gender == "male" & proportion_male > 0.8 ~ "Man",
      gender == "female" & proportion_female > 0.8 ~ "Woman",
      TRUE ~ NA
    )
  )

# Backup gender identification from pronouns
obituaries_eng <- obituaries_eng %>%
  mutate(
    Woman_Count = str_count(Description, " she | her |mother|wife|daughter|sister|grandmother"),
    Man_Count = str_count(Description, " he | his |father|husband|son|brother|grandfather"),
    gender2 = case_when(Woman_Count > Man_Count ~ "Woman", Man_Count > Woman_Count ~ "Man"),
    gender = ifelse(is.na(gender), gender2, gender)
  ) %>% select(Name, Description, Year, gender, baby)

#---------------------------------------------------------------------------#
# Age extraction                                                            #
#---------------------------------------------------------------------------#
# Please note that in "real obituaries" there are multiple indications
# of age at death, e.g. explicitly said or inferred by years,
# which fails to be replicated with AI-generated texts.

# Custom regular expressions to extract age at death
obituaries_eng <- obituaries_eng %>%
  mutate(
    # Extract direct ages
    age1 = as.numeric(str_extract(Description, "at(?: the)? aged(?: of)? (\\d{1,3})") %>% str_extract("\\d{1,3}")),
    age2 = as.numeric(str_extract(Description, "at (\\d{1,3}) years? of age\\.") %>% str_extract("\\d{1,3}")),
    age3 = as.numeric(str_extract(Description, "\\b(\\d{1,3})(?:th|rd|st|nd) (?:year|birthday)") %>% str_extract("\\d{1,3}")),
    
    # Extract birth year from description
    birth_year_desc = as.numeric(str_extract(Description, "\\b(19[0-9]{2}|200[0-9]|201[0-9]|202[0-2])(?=\\s*-)")),
    
    # Extract death year from description (fixing look-behind issue)
    death_year_desc = as.numeric(str_extract(
      str_extract(Description, "-\\s*(19[0-9]{2}|200[0-9]|201[0-9]|202[0-2])"),
      "\\d{4}"
    )),
    
    # Calculate age if both birth & death year found in description
    age4 = ifelse(!is.na(birth_year_desc) & !is.na(death_year_desc), death_year_desc - birth_year_desc, NA),
    
    # Extract birth year from Name and subtract from obituary Year
    birth_year_name = as.numeric(str_extract(Name, "\\b(19[0-9]{2}|200[0-9]|201[0-9]|202[0-2])(?=\\s*-)")),
    age5 = ifelse(!is.na(birth_year_name) & !is.na(Year), Year - birth_year_name, NA),
    
    # Extract age from "in his/her 95th year/years"
    age6 = as.numeric(str_extract(
      str_extract(Description, "(in )?(his|her) (\\d{1,3})(?:th|rd|st|nd) years?"),
      "\\d{1,3}"
    ))
  )



# Before extracting min year, remove any year that has parentheses ()
# as they may be referring to the year of death of a parent or spouse

obituaries_eng$Description <- gsub("\\(\\d{4}\\)", "", obituaries_eng$Description)

# Infer age from birth year in Name or Description
extract_min_year <- function(text, lower, upper) {
  years <- as.numeric(unlist(str_extract_all(text, "\\b\\d{4}\\b")))
  years <- years[years >= lower & years <= upper]
  if (length(years)) return(min(years)) else return(NA)
}

obituaries_eng$minyear_name <- sapply(obituaries_eng$Name, extract_min_year, 1907, 2022)
obituaries_eng$minyear_desc <- sapply(obituaries_eng$Description, extract_min_year, 1907, 2022)

# Calculate age at death of the current year minus the lowest year found,
# in the name and in the obituary description respectively

obituaries_eng <- obituaries_eng %>% mutate(age7 = Year - minyear_name,
                      age8 = Year - minyear_desc)

# Final age at death equals to age1. If that missing:
# Find the oldest age at death between age2 to age7. If the age at death - 1 exists, take that one  well.
obituaries_eng <- obituaries_eng %>%
  mutate(
    # Create a vector of the available ages
    max_known_age = pmax(age2, age3, age4, age5, age6, age7, age8, na.rm = TRUE),
    max_known_age_minus1 = max_known_age - 1,
    
    # Find the correct age at death
    age_at_death = case_when(
      !is.na(age1) ~ age1,  # Use age1 if available
      !is.na(max_known_age) ~ max_known_age,  # Else use oldest non-NA among age2:age7
      !is.na(max_known_age_minus1) ~ max_known_age_minus1,  # Else use (oldest age - 1)
      baby == TRUE ~ 0,  # Babies with no age get 0
      TRUE ~ NA_real_   # Otherwise NA
    )
  ) %>%
  select(-max_known_age, -max_known_age_minus1) # Remove helpers

# Final baby confirmation
phrases <- c("his mother", "her mother", "son of", "daughter of", "grandson of", 
             "granddaughter of", "baby", "infant", "premature", "their son", 
             "their daughter", "by parents", "his \\w+ parents", "her \\w+ parents")


# Too many 0-age so confirm that they are indeed a baby
obituaries_eng$true_baby <- str_detect(obituaries_eng$Description, paste(phrases, collapse = "|"))

obituaries_eng <- obituaries_eng %>%
  mutate(age_at_death = case_when(
    baby == TRUE | (age_at_death == 0 & true_baby == TRUE) ~ 0,
    age_at_death > 0 ~ age_at_death,
    TRUE ~ NA
  )) %>%
  select(Name, Description, Year, Gender = gender, age_at_death)




# Save english obituaries which have age at death and gender extracted
save(obituaries_eng, file = "./Data/obituaries_ont_eng.RData")



#---------------------------------------------------------------------------#
# Merge French and English datasets                                         #
#---------------------------------------------------------------------------#
rm(list = ls())

load(file = "./Data/obituaries_ont_fr.RData")
load(file = "./Data/obituaries_ont_eng.RData")

obituaries_ontario <- rbind(obituaries_fr %>% mutate(language = "fr"), 
                            obituaries_eng %>% mutate(language = "eng"))

save(obituaries_ontario, file = "./Data/Ontario_obituaries_extracted.RData")

