# File-Name:       priority_inbox.R           
# Date:            2012-02-10                                
# Author:          Drew Conway (drew.conway@nyu.edu)
# Purpose:         Kod do rozdziału 4.  W tym studium próbujemy napisać algorytm "priorytetowej
#                   skrzynki pocztowej" do układania rankingu wiadomości na podstawie pewnych
#                   miar istotności. Miary te zdefiniujemy na podstawie zestawu cech wiadomości,
#                   wychodząc poza proste zliczanie wyrazów z rozdziału 3.
# Data Used:       Wiadomości e-mail z katalogu ../../03-Classification/code/data/,
#                   pochodzące z http://spamassassin.apache.org/publiccorpus/
# Packages Used:   tm, ggplot2, plyr

# All source code is copyright (c) 2012, under the Simplified BSD License.  
# For more information on FreeBSD see: http://www.opensource.org/licenses/bsd-license.php

# All images and materials produced by this code are licensed under the Creative Commons 
# Attribution-Share Alike 3.0 United States License: http://creativecommons.org/licenses/by-sa/3.0/us/

# All rights reserved.

# UWAGA: w przypadku uruchamiania z konsoli R (w trybie interaktywnym) należy wykonać polecenie 'setwd'
# w celu zmiany katalogu roboczego na katalog zawierający plik skryptu.
# Inaczej może dojsć do błędów wczytywania danych i zapisu obrazków!

# Załadowanie bibliotek
library('tm')
library('ggplot2')
library('plyr')
library('reshape')

# Ustawienie ścieżek do plików
data.path <- file.path("..", "03-Classification", "data")
easyham.path <- file.path(data.path, "easy_ham")

# Definiujemy zestaw funkcji do wyodrębniania danych (cech) decydujących o umiejscowieniu
# w rankingu ważności wiadomości; są to: treść wiadomości, nadawca wiadomości,
# temat wiadomości i data wysłania wiadomości.

# Funkcja zwraca po prostu pełną treść przekazanej wiadomości.
msg.full <- function(path)
{
  con <- file(path, open = "rt", encoding = "latin1")
  msg <- readLines(con)
  close(con)
  return(msg)
}

# Zwraca adres nadawcy danej wiadomości
get.from <- function(msg.vec)
{
  from <- msg.vec[grepl("From: ", msg.vec)]
  from <- strsplit(from, '[":<> ]')[[1]]
  from <- from[which(from  != "" & from != " ")]
  return(from[grepl("@", from)][1])
}

# Zwraca temat danej wiadomości
get.subject <- function(msg.vec)
{
  subj <- msg.vec[grepl("Subject: ", msg.vec)]
  if(length(subj) > 0)
  {
    return(strsplit(subj, "Subject: ")[[1]][2])
  }
  else
  {
    return("")
  }
}

# Analogicznie do funkcji z rozdziału 3., zwraca jedynie treść
# danej wiadomości.
get.msg <- function(msg.vec)
{
  msg <- msg.vec[seq(which(msg.vec == "")[1] + 1, length(msg.vec), 1)]
  return(paste(msg, collapse = "\n"))
}

# Zwraca datę wysłania danej wiadomości
get.date <- function(msg.vec)
{
  date.grep <- grepl("^Date: ", msg.vec)
  date.grep <- which(date.grep == TRUE)
  date <- msg.vec[date.grep[1]]
  date <- strsplit(date, "\\+|\\-|: ")[[1]][2]
  date <- gsub("^\\s+|\\s+$", "", date)
  return(strtrim(date, 25))
}

# Funkcja wiążąca wszystkie powyższe funkcje pomocnicze.
# Zwraca wektor danych zawierający zestaw cech wykorzystywanych
# do ułożenia wiadomości według ważności.
parse.email <- function(path)
{
  full.msg <- msg.full(path)
  date <- get.date(full.msg)
  from <- get.from(full.msg)
  subj <- get.subject(full.msg)
  msg <- get.msg(full.msg)
  return(c(date, from, subj, msg, path))
}

# Tutaj nie chcemy klasyfikować typu wiadomości, więc przyjmiemy że wiadomości zostały już
# odsiane; weźmiemy więc do zbioru uczącego tylko wiadomości niewątpliwie treściwe.
easyham.docs <- dir(easyham.path)
easyham.docs <- easyham.docs[which(easyham.docs != "cmds")]
easyham.parse <- lapply(easyham.docs,
                        function(p) parse.email(file.path(easyham.path, p)))

# Zamiana surowych danych z listy na ramkę danych
ehparse.matrix <- do.call(rbind, easyham.parse)
allparse.df <- data.frame(ehparse.matrix, stringsAsFactors = FALSE)
names(allparse.df) <- c("Date", "From.EMail", "Subject", "Message", "Path")

# Zamiana ciągów dat wiadomości na format zapisu POSIX, dla celów porównywania dat.
# Ponieważ dane wiadomości mogą zawierać różne zapisy dat, musimy uwzględnić zróżnicowanie
# i ujednolicić zapis.
date.converter <- function(dates, pattern1, pattern2)
{
  pattern1.convert <- strptime(dates, pattern1)
  pattern2.convert <- strptime(dates, pattern2)
  pattern1.convert[is.na(pattern1.convert)] <- pattern2.convert[is.na(pattern1.convert)]
  return(pattern1.convert)
}

pattern1 <- "%a, %d %b %Y %H:%M:%S"
pattern2 <- "%d %b %Y %H:%M:%S"

allparse.df$Date <- date.converter(allparse.df$Date, pattern1, pattern2)

# Zamiana zapisu treści i tematów wiadomości na małe litery.
allparse.df$Subject <- tolower(allparse.df$Subject)
allparse.df$From.EMail <- tolower(allparse.df$From.EMail)

# Ułożenie wiadomości w porządku chronologicznym.
priority.df <- allparse.df[with(allparse.df, order(Date)), ]

# Do wyuczenia algorytmu użyjemy pierwszej połowy zbioru priority.df; drugą połówkę
# użyjemy później do testowania algorytmu.
priority.train <- priority.df[1:(round(nrow(priority.df) / 2)), ]

# W pierwszym kroku wyznaczamy wagi dla poszczególnych cech.
# Zaczynamy od najprostszej: od kogo pochodzi wiadomość.

# Obliczamy częstość korespondencji z wszystkimi nadawcami w zbiorze uczącym.
#from.weight <- melt(with(priority.train, table(From.EMail)), 
#                    value.name="Freq")
priority.train$Date <- as.POSIXct(priority.train$Date)
from.weight <- ddply(priority.train, .(From.EMail), summarise, Freq=length(Subject))
from.weight <- from.weight[with(from.weight, order(Freq)), ]

# Bieżemy podzbiór ramki danych from.weight z największymi częstościami.
from.ex <- subset(from.weight, Freq > 6)

from.scales <- ggplot(from.ex) +
  geom_rect(aes(xmin = 1:nrow(from.ex) - 0.5,
                xmax = 1:nrow(from.ex) + 0.5,
                ymin = 0,
                ymax = Freq,
                fill = "lightgrey",
                color = "darkblue")) +
  scale_x_continuous(breaks = 1:nrow(from.ex), labels = from.ex$From.EMail) +
  coord_flip() +
  scale_fill_manual(values = c("lightgrey" = "lightgrey"), guide = "none") +
  scale_color_manual(values = c("darkblue" = "darkblue"), guide = "none") +
  ylab("Liczba odebranych wiadomości (min. 6)") +
  xlab("Adres nadawcy") +
  theme_bw() +
  theme(axis.text.y = element_text(size = 5, hjust = 1))
ggsave(plot = from.scales,
       filename = file.path("images", "0011_from_scales.png"),
       height = 4.8,
       width = 7)

# Wagowanie logarytmiczne (proste, ale efektywne)
from.weight <- transform(from.weight,
                         Weight = log(Freq + 1),
                         log10Weight = log10(Freq + 1))

from.rescaled <- ggplot(from.weight, aes(x = 1:nrow(from.weight))) +
  geom_line(aes(y = Weight, linetype = "ln")) +
  geom_line(aes(y = log10Weight, linetype = "log10")) +
  geom_line(aes(y = Freq, linetype = "brak")) +
  scale_linetype_manual(values = c("ln" = 1,
                                   "log10" = 2,
                                   "brak" = 3),
                        name = "Skala") +
  xlab("") +
  ylab("Liczba odebranych wiadomości") +
  theme_bw() +
  theme(axis.text.y = element_blank(), axis.text.x = element_blank())
ggsave(plot = from.rescaled,
       filename = file.path("images", "0012_from_rescaled.png"),
       height = 4.8,
       width = 7)

# Aby obliiczyć ważność wiadomości powinniśmy obliczyć pewne prawdopodobieństwo,
# że użytkownik odpowie na wiadomośc. W naszym przypadku mamy tylko dane z jednej strony
# komunikacji; możemy co najwyżej wyznaczyć częstość na podstawie słów w wątkach, w których
# było wymienianych dużo wiadomości.

# Funkcja służąca do zgrupowania wiadomości w wątki. Oczywiste podejście polega na dopasowaniu
# po zawartości temató∑ wiadomości z przedrostkiem 're:'
find.threads <- function(email.df)
{
  response.threads <- strsplit(email.df$Subject, "re: ")
  is.thread <- sapply(response.threads,
                      function(subj) ifelse(subj[1] == "", TRUE, FALSE))
  threads <- response.threads[is.thread]
  senders <- email.df$From.EMail[is.thread]
  threads <- sapply(threads,
                    function(t) paste(t[2:length(t)], collapse = "re: "))
  return(cbind(senders,threads))
}

threads.matrix <- find.threads(priority.train)

# Na podstawie macierzy wątków wygenerowanej z funkcji 'find.threads', poniższa funkcja
# zbiera dane z częstości wiaodmości od danego nadawcy i waży (logarytmicznie) ważność
# nadawcy na podstawie częstości korespondencji.
email.thread <- function(threads.matrix)
{
  senders <- threads.matrix[, 1]
  senders.freq <- table(senders)
  senders.matrix <- cbind(names(senders.freq),
                          senders.freq,
                          log(senders.freq + 1))
  senders.df <- data.frame(senders.matrix, stringsAsFactors=FALSE)
  row.names(senders.df) <- 1:nrow(senders.df)
  names(senders.df) <- c("From.EMail", "Freq", "Weight")
  senders.df$Freq <- as.numeric(senders.df$Freq)
  senders.df$Weight <- as.numeric(senders.df$Weight)
  return(senders.df)
}

senders.df <- email.thread(threads.matrix)

# Jako dodatkową wagę możemy mierzyć czas pomiędzy odpowiedziami dla danej wiadomości.
# Funkcja dla danego wątku i ramki danych email.df wyznacza wagi na podstawie poziomu
# aktywności w wątku. Wynikiem funkcji jest wektor aktywności wątku, czas trwania wątku
# i logarytmiczna waga.
thread.counts <- function(thread, email.df)
{
  # Trzeba sprawdzić, czy nie analizujemy pierwotnej wiadomości wątku,
  # więc filtrujemy tematy nie zawierające przedrostka 're:'
  thread.times <- email.df$Date[which(email.df$Subject == thread |
                                      email.df$Subject == paste("re:", thread))]
  freq <- length(thread.times)
  min.time <- min(thread.times)
  max.time <- max(thread.times)
  time.span <- as.numeric(difftime(max.time, min.time, units = "secs"))
  if(freq < 2)
  {
    return(c(NA, NA, NA))
  }
  else
  {
    trans.weight <- freq / time.span
    log.trans.weight <- 10 + log(trans.weight, base = 10)
    return(c(freq, time.span, log.trans.weight))
  }
}

# Funkcja wykorzystująca funkcję threads.counts do generowania wag dla wszystkich wątków.
get.threads <- function(threads.matrix, email.df)
{
  threads <- unique(threads.matrix[, 2])
  thread.counts <- lapply(threads,
                          function(t) thread.counts(t, email.df))
  thread.matrix <- do.call(rbind, thread.counts)
  return(cbind(threads, thread.matrix))
}

# Teraz wykorzystamy wszystkie funkcje do utworzenia zbioru uczącego na podstawie cech wątkowości.
thread.weights <- get.threads(threads.matrix, priority.train)
thread.weights <- data.frame(thread.weights, stringsAsFactors = FALSE)
names(thread.weights) <- c("Thread", "Freq", "Response", "Weight")
thread.weights$Freq <- as.numeric(thread.weights$Freq)
thread.weights$Response <- as.numeric(thread.weights$Response)
thread.weights$Weight <- as.numeric(thread.weights$Weight)
thread.weights <- subset(thread.weights, is.na(thread.weights$Freq) == FALSE)

# Podobnie jak w rozdziale 3. tworzymy prostą funkcję do zwracania wektora
# liczników wystąpień wyrazów. Tym razem jednak z użyciem parametru sterującego tworzeniem TDM.
term.counts <- function(term.vec, control)
{
  vec.corpus <- Corpus(VectorSource(term.vec))
  vec.tdm <- TermDocumentMatrix(vec.corpus, control = control)
  return(rowSums(as.matrix(vec.tdm)))
}

thread.terms <- term.counts(thread.weights$Thread,
                            control = list(stopwords = TRUE))
thread.terms <- names(thread.terms)

term.weights <- sapply(thread.terms,
                       function(t) mean(thread.weights$Weight[grepl(t, thread.weights$Thread, fixed = TRUE)]))
term.weights <- data.frame(list(Term = names(term.weights),
                                Weight = term.weights),
                           stringsAsFactors = FALSE,
                           row.names = 1:length(term.weights))

# Na koniec generujemy wagi na podstawie częstości występowania wyrazów w wiadomościach.
# Będzie to podobne jak przy wykrywaniu SPAM-u, ale tu wysokie wagi otrzymają słowa
# bardziej typowe dla wiadomości treściwych.

msg.terms <- term.counts(priority.train$Message,
                         control = list(stopwords = TRUE,
                         removePunctuation = TRUE,
                         removeNumbers = TRUE))
msg.weights <- data.frame(list(Term = names(msg.terms),
                               Weight = log(msg.terms, base = 10)),
                          stringsAsFactors = FALSE,
                          row.names = 1:length(msg.terms))

# Usunięcie słów z zerową wagą
msg.weights <- subset(msg.weights, Weight > 0)

# Funkcja, która na podstawie przeliczonych ramek danych wag wyłuskuje wagę
# dla słowa 'search.term'. Parametr 'term' określa, czy szukamy słowa w ramce
# weight.df pod kątem ważenia w treści wiadomości, czy ważenia w tematach.
get.weights <- function(search.term, weight.df, term = TRUE)
{
  if(length(search.term) > 0)
  {
    if(term)
    {
      term.match <- match(names(search.term), weight.df$Term)
    }
    else
    {
      term.match <- match(search.term, weight.df$Thread)
    }
    match.weights <- weight.df$Weight[which(!is.na(term.match))]
    if(length(match.weights) < 1)
    {
      return(1)
    }
    else
    {
      return(mean(match.weights))
    }
  }
  else
  {
    return(1)
  }
}

# W ostatnim kroku piszemy funkcję, która przypisze wagi do poszczególnych wiadomości,
# na podstawie wszystkich wag cząstkowych dla poszczególnych cech wiadomości.
rank.message <- function(path)
{
  msg <- parse.email(path)
  # Ważenie na bazie nadawcy wiadomości
  
  # Najpierw tylko częstość łączna
  from <- ifelse(length(which(from.weight$From.EMail == msg[2])) > 0,
                 from.weight$Weight[which(from.weight$From.EMail == msg[2])],
                 1)
  
  # Potem częstość w wątkach
  thread.from <- ifelse(length(which(senders.df$From.EMail == msg[2])) > 0,
                        senders.df$Weight[which(senders.df$From.EMail == msg[2])],
                        1)
  
  subj <- strsplit(tolower(msg[3]), "re: ")
  is.thread <- ifelse(subj[[1]][1] == "", TRUE, FALSE)
  if(is.thread)
  {
    activity <- get.weights(subj[[1]][2], thread.weights, term = FALSE)
  }
  else
  {
    activity <- 1
  }
  
  # Ważenie na bazie wyrazów
  # w wątkach
  thread.terms <- term.counts(msg[3], control = list(stopwords = TRUE))
  thread.terms.weights <- get.weights(thread.terms, term.weights)
  
  # we wszystkich wiadomościach
  msg.terms <- term.counts(msg[4],
                           control = list(stopwords = TRUE,
                           removePunctuation = TRUE,
                           removeNumbers = TRUE))
  msg.weights <- get.weights(msg.terms, msg.weights)
  
  # Obliczenie rankingu wiadomości jako iloczynu wszystkich wag.
  rank <- prod(from,
               thread.from,
               activity, 
               thread.terms.weights,
               msg.weights)
  
  return(c(msg[1], msg[2], msg[3], rank))
}

# Ponowny podział zbioru wejściowego
train.paths <- priority.df$Path[1:(round(nrow(priority.df) / 2))]
test.paths <- priority.df$Path[((round(nrow(priority.df) / 2)) + 1):nrow(priority.df)]

# Skonstruowanie pełnego zbioru uczącego
train.ranks <- suppressWarnings(lapply(train.paths, rank.message))
train.ranks.matrix <- do.call(rbind, train.ranks)
train.ranks.matrix <- cbind(train.paths, train.ranks.matrix, "TRENING")
train.ranks.df <- data.frame(train.ranks.matrix, stringsAsFactors = FALSE)
names(train.ranks.df) <- c("Message", "Date", "From", "Subj", "Rank", "Type")
train.ranks.df$Rank <- as.numeric(train.ranks.df$Rank)

# Ustawienie progu ważności jako mediany wszystkich wag
priority.threshold <- median(train.ranks.df$Rank)

# Wizualizacja wyników w celu zlokalizowania progu
threshold.plot <- ggplot(train.ranks.df, aes(x = Rank)) +
  stat_density(aes(fill="darkred")) +
  labs(x = "Ranking", y = "gęstość") +
  geom_vline(xintercept = priority.threshold, linetype = 2) +
  scale_fill_manual(values = c("darkred" = "darkred"), guide = "none") +
  theme_bw()
ggsave(plot = threshold.plot,
       filename = file.path("images", "01_threshold_plot.png"),
       height = 4.7,
       width = 7)

# Klasyfikacja wiadomości jako ważnych albo mniej ważnych
train.ranks.df$Priority <- ifelse(train.ranks.df$Rank >= priority.threshold, 1, 0)

# Sprawdzenie algorytmu przez wykonanie tej samej procedury na danych testowych
test.ranks <- suppressWarnings(lapply(test.paths,rank.message))
test.ranks.matrix <- do.call(rbind, test.ranks)
test.ranks.matrix <- cbind(test.paths, test.ranks.matrix, "TEST")
test.ranks.df <- data.frame(test.ranks.matrix, stringsAsFactors = FALSE)
names(test.ranks.df) <- c("Message","Date","From","Subj","Rank","Type")
test.ranks.df$Rank <- as.numeric(test.ranks.df$Rank)
test.ranks.df$Priority <- ifelse(test.ranks.df$Rank >= priority.threshold, 1, 0)

# Końcowe połączenie zbiorów danych
final.df <- rbind(train.ranks.df, test.ranks.df)
final.df$Date <- date.converter(final.df$Date, pattern1, pattern2)
final.df <- final.df[rev(with(final.df, order(Date))), ]

# Zapisanie wynikowego zbioru danych i wygenerowanie wykresów
write.csv(final.df, file.path("data", "final_df.csv"), row.names = FALSE)

testing.plot <- ggplot(subset(final.df, Type == "TRENING"), aes(x = Rank)) +
  stat_density(aes(fill = Type, alpha = 0.65)) +
  labs(x = "Ranking", y = "gęstość", fill = "Typ") +
  stat_density(data = subset(final.df, Type == "TEST"),
               aes(fill = Type, alpha = 0.65)) +
  geom_vline(xintercept = priority.threshold, linetype = 2) +
  scale_alpha(guide = "none") +
  scale_fill_manual(values = c("TRENING" = "darkred", "TEST" = "darkblue")) +
  theme_bw()
ggsave(plot = testing.plot,
       filename = file.path("images", "02_testing_plot.png"),
       height = 4.7,
       width = 7)
