########################################################
# Tobias Ackermann, University of Zurich
# DDJ 2018, 12.3.2018
# Text-Analysen
#########################################################
#ACHTUNG durch den Umfang der Daten arbeite ich zeitweise auf dem Uni Server
#ACHTUNG weil auf dem Uni server R gewisse funktionen nicht gehen muss ich wieder auf meinem PC arbeiten
#ACHTUNG es wird immer gekennzeichnet wenn ich die Arbeitsumgebung wechsle

#########################################################
#1) Vorbereotung
#########################################################
rm(list=ls(all=TRUE)) # Den Workspace leeren
setwd("/Users/toacke/Desktop/lsdmf") # definieren working directory
options(stringsAsFactors=F) # verbieten von automatischer conversion von strings in factors
set.seed(123) # macht die Reproduzierbarkeit möglich
#########################################################

# Laden der notwendigen Packete:
#libs <- c("tm", "stringr", "RTextTools", "stm", "ggplot2", "textcat", "countrycode","wordcloud", "ngram", "dplyr", "tidytext", "parallel", "car", "quanteda" ) 
# Installieren aller Packete
#install.packages(libs) # only once!


#########################################################
#2) Korpus importiere
#########################################################

library(tm)
library(stringr)
library(ngram)

# Pfad zu den Dokumenten definieren
dir <- "/Users/toacke/Desktop/lsdmf" 
#"./XYZ" macht dass man im richtigen ordner ist wen man "dir" verwendet
dir()

#########################################################
# ACHTUNG: Weil die Texte in "latin1" encoded sind muss ich folgenden Cod eingeben - löst aber nicht alle Encoding-Probleme
#Sys.setlocale("LC_ALL", "pt_PT.ISO8859-1")
#Sys.getlocale("LC_ALL")
#########################################################

# Lässt alle Cores, die zur verfügung stehen arbeiten
library(parallel)
detectCores(all.tests=TRUE, logical=TRUE)
options(mc.cores = parallel::detectCores())# will let you use multiple cores of your computer
#laden des eigentlichen Korpus mit Zeitmessung
system.time(textcorpus <- VCorpus(DirSource(dir), readerControl = list(encoding<-"latin1")))
Encoding(textcorpus[[1]]$content)
textcorpus[[1]]$content
#Umwandeln der Umlaute:
for (i in 1:length(textcorpus)){
  textcorpus[[i]]$content<-gsub("<fc>", "ü",textcorpus[[i]]$content)
  textcorpus[[i]]$content<-gsub("<e4>", "ä",textcorpus[[i]]$content)
  textcorpus[[i]]$content<-gsub("<f6>", "ö",textcorpus[[i]]$content)
  textcorpus[[i]]$content<-gsub("<e9>", "é",textcorpus[[i]]$content)
  textcorpus[[i]]$content<-gsub("<dc>", "Ü",textcorpus[[i]]$content)
  textcorpus[[i]]$content<-gsub("<c4>", "Ä",textcorpus[[i]]$content)
  textcorpus[[i]]$content<-gsub("<d6>", "Ö",textcorpus[[i]]$content)
}

#########################################################
# 3) META DATA
#########################################################

# Was ist an Metadaten vorhanden?
summary(textcorpus)

# Eine Liste mit den Dokumenten Namen erstellen:
docnames <- list.files(dir, pattern = ".txt")
docnames

#########################################################
#loop um einen split-string zu erhalten für die Variable "ID"
for (i in 1:length(textcorpus)){
  meta(textcorpus[[i]], "id") <-paste(unlist(strsplit(docnames[i], "\\-|\\.")) [4:6], collapse = " ")  #\\- takes out the "-" and \\. the "." - two argumets possible =)
} 
#########################################################
#loop um einen split-string zu erhalten für die Variable "DATE"
for (i in 1:length(textcorpus)){
  meta(textcorpus[[i]], "datetimestamp") <-as.Date(paste(unlist(strsplit(docnames[i], "\\-|\\.")) [3:1], collapse = "-"))  #\\- takes out the "-" and \\. the "." - two argumets possible =)
} 
#Funktion ob das generierte argument ein Datum ist:
IsDate <- function(mydate, date.format = "%y/%m/%d") {
  tryCatch(!is.na(as.Date(mydate, date.format)),  
           error = function(err) {FALSE})  
}
#Test
#Dataframe mit Meta daten kreieren
test<-textcorpus[[1]]$meta
IsDate(test$datetimestamp)
rm(test)

########################################################
#loop um einen split-string zu erhalten für die Variable "startyear"
for (i in 1:length(textcorpus)){
  meta(textcorpus[[i]], "startyear") <-unlist(strsplit(docnames[i], "\\-|\\.")) [6]  #\\- takes out the "-" and \\. the "." - two argumets possible =)
} 

#loop um einen split-string zu erhalten für die Variable "endyear"
for (i in 1:length(textcorpus)){
  meta(textcorpus[[i]], "endyear") <-unlist(strsplit(docnames[i], "\\-|\\.")) [3]  #\\- takes out the "-" and \\. the "." - two argumets possible =)
} 

########################################################
#Variable der Sprache
#ACHTUNG GEHT LANGE
library(textcat)
for (i in 1:length(textcorpus)){
  meta(textcorpus[[i]], "language") <-textcat(textcorpus[i]$content, p = textcat::TC_char_profiles, method = "CT",
                                              options = list())
} 

########################################################
#search for gregex "Die Beschwerde wird abgewiesen." um ein logisches Argument zu erhalten
for (i in 1:length(textcorpus)){
  meta(textcorpus[[i]],"abgewiesen")<-grepl(pattern="Beschwerde wird abgewiesen", paste(textcorpus[[i]]$content, collapse = " "), Encoding <- "latin1")
}

#search for gregex "Die Beschwerde wird gutgeheissen" um ein logisches Argument zu erhalten
for (i in 1:length(textcorpus)){
  meta(textcorpus[[i]],"gutgeheissen")<-grepl(pattern="Beschwerde wird gutgeheissen", paste(textcorpus[[i]]$content, collapse= " "), Encoding <- "latin1")
}

########################################################
#die Herkunft der Personen Bestimmen
library(countrycode) 
countries<-as.data.frame(codelist)
cname<-countries$country.name.de
cname
#########################################################
#loop for unlist words aber zuerst die Punktuation, Nummern und das wort "Schweiz" zu entfernen
textcorpus <- tm_map(textcorpus, removePunctuation)
textcorpus <- tm_map(textcorpus, removeNumbers)
textcorpus <- tm_map(textcorpus, removeWords, "Schweiz") # Das muss weg, da vor dem Herkunftsland in seltenen fällen das Wort "Schweiz" vorkommt
textcorpus[[1]]$content

#########################################################
#loop für die Variable "origin"
x<-0 # Platzhalter Definieren 
for (i in 1:length(textcorpus)){
  x[i]<-(which(unlist(strsplit(textcorpus[[i]]$content," ","\\,")) %in% cname))[1] 
  meta(textcorpus[[i]],"origin")<-unlist(strsplit(textcorpus[[i]]$content," "))[x[i]]
}
#macht eine Wort pro Linie und schaut nach ob das wort in dem Vektor "cname" vorkommt
#es nimmt den ersten eintrag, weil dieser das Herkunftsland ist. bei mehreren Personen die gemeinsam den Antrag stellen muss die Annahme gtroffen werden, 
#dass sie aus dem gleichen Land kommen

#### Entfernen von Wörtern die das Recht betreffen und Worte mit ü/ö welche nicht erkannt werden von der folgenden Stopwortfunktion
textcorpus <- tm_map(textcorpus, removeWords,c( "Art", "Abs", "VwVG","iVm", "vgl","Bst","AsylG", "Ziff", "ff", 
                                                "BFM","für","können", "über","könnte", "würed", "würden","sei",
                                                "art", "Asylg","Bundesverwaltungsgericht","Tribunal administratif fédéral",
                                                "Tribunale amministrativo federale", "Tribunal administrativ federal"))

#### Testen ob es geklappt hat
textcorpus[[1]]$meta
textcorpus[[1]]$content

#########################################################
# 4) Preprocessing
#########################################################
#basic settings
library(tm)
library(stm)
library(parallel)
library(ggplot2)
library(car)
options(stringsAsFactors = F)
set.seed(0213)

#########################################################
#alles kleinschreiben
textcorpus <- tm_map(textcorpus, content_transformer(tolower))

#########################################################
#alle Stopworte und Schweizerdeutsche Wörter Plus das Encoding, welches geprintet wurde
stopwords("german") # stoplist für Deutsche Wörter!
textcorpus <- tm_map(textcorpus, removeWords, c(stopwords("german"), "dass", "dadurch", "vgg", "latin1")) # verschweizert 
textcorpus[[1]]$content
for (i in 1:length(textcorpus)) {#Beispielsweise doppelte Leerschläge rausnehmen und durch einen ersetzen
  textcorpus[[i]]$content <- gsub("[[:space:]]", " ", textcorpus[[i]])
}
#########################################################
#ACHTUNG: durch das itterative Arbeiten, ist aufgefallen, dass die Topics generiert unter 6) 
#noch viele Inhaltsleere worte besitzt, weshalb diese hier entfernt werden:
textcorpus <-tm_map(textcorpus, stemDocument)
textcorpus <- tm_map(textcorpus, removeWords,c("worden","wurde","worden","oktob","darauf","wegen","somit","seit","bvge",
                                               "jedoch","gemacht","bgg","januar","april","ark","juni","seien","hätten","august",
                                               "deren","mai","sowi","weder","konkret","jedoch","beim","daher","novemb","weshalb","gemäss",
                                               "aug","april","februar","demnach","emark","allgemein","dezemb","mehr","ltte","juli"))
textcorpus[[1]]$content


#########################################################
# 5) Filtern der Texte
#########################################################
#Nur deutsche Texte
deutschTXT<- tm_filter(textcorpus, FUN = function(textcorpus) meta(textcorpus)[["language"]] == "german")
summary(deutschTXT)
deutschTXT[[1]]$content

#########################################################
#Zu einem Dataframe umwandeln
docs<- 
  data.frame(id=sapply(deutschTXT, meta, "id"),
             language=sapply(deutschTXT, meta, "language"),
             origin=sapply(deutschTXT,meta,"origin"),
             gutgeheissen=sapply(deutschTXT,meta,"gutgeheissen"),
             abgewiesen=sapply(deutschTXT,meta,"abgewiesen"),
             startyear=sapply(deutschTXT,meta,"startyear"),
             endyear=sapply(deutschTXT,meta,"endyear"),
             content=unlist(lapply(sapply(deutschTXT, '[', "content"),paste,collapse=" ")),
             stringsAsFactors=FALSE)

#########################################################
#recode "gutgeheissen":
docs$gutgeheissen2<-NA
docs$gutgeheissen2<- as.numeric(ifelse(docs$gutgeheissen == TRUE, 1,0 ))
is.numeric(docs$gutgeheissen2)

#########################################################
#Test wie nun ein Dokument im DF abgelegt ist:
head(docs, n=1)

#########################################################
#Speichern:
docs <- na.omit(docs) # alle Fälle mit NA's auf einer Variablen rauswerfen
saveRDS(docs,file="deutschetexte_3.Rda")
#docs<-readRDS(file="deutschetexte_3.Rda")


#########################################################
# 6) Structural Topic Model - STM
#########################################################
# ACHTUNG ab hier arbeite ich auf dem Server!


#########################################################
#Korpus für STM erstellen
lang <- "german"
corpus <- textProcessor(docs[,c("content")],
                        metadata=docs[,c("origin", "gutgeheissen2")],
                        stem=T, language=lang, removestopwords=F,
                        lowercase=F, removenumbers=F,
                        removepunctuation=F, customstopwords=NULL)
corpus <- prepDocuments(corpus$documents, corpus$vocab, corpus$meta, lower.thresh = 1)
corpus$meta

#########################################################
# Optimale Nummer von Topics (k)
K<-c(3,6,9,12)
system.time(srchK <- searchK(corpus$documents, corpus$vocab, K,
                             verbose = TRUE, init.type = "Spectral",
                             cores = 1))

#########################################################
# ACHTUNG ab hier arbeite ich auf dem eigen PC!
#jpeg(filename="./SearchK.jpeg") #Automatisches speichern des bides im Directory
plot(srchK)
#dev.off()

help(exclusivity)
help(semanticCoherence)

#########################################################
# Fit stm with optimal k = 6
STM <- stm(corpus$documents, corpus$vocab, 6,
           prevalence =~origin + s(gutgeheissen2), content = NULL,
           data = corpus$meta, max.em.its = 100, verbose = TRUE, init.type = "Spectral")

#########################################################
#Speichern des gesamten Immages
#save.image(file='Env_STM_final.RData') 
#load("Env_STM_final.RData")


#########################################################
# 7) Darstellungen
#########################################################

# topic descriptives mit Wordclouds
library(wordcloud)

#die Lables
labelTopics(STM, topics = 1:6, n = 10)

#Wordcloud
cloud(STM, topic = 6) # letzter Wert wählt das Topic
?cloud
#plot der Labels
plot(STM, type = 'labels', topics = 1:6)

plot(STM, type = "perspectives", topics = c(2,6))

# Topic Verhältnisse
plot(STM, type = 'summary', topics = 1:6)


#########################################################
#Ordnung hineinbringen:
library(tidytext)
library(dplyr)
#########################################################
#Funktionen definieren vom Package "drlib", weil im Moment nicht vorhanden für R Version 3.5.0
reorder_within <- function(x, by, within, fun = mean, sep = "___", ...) {
  new_x <- paste(x, within, sep = sep)
  stats::reorder(new_x, by, FUN = fun)
}
scale_x_reordered <- function(..., sep = "___") {
  reg <- paste0(sep, ".+$")
  ggplot2::scale_x_discrete(labels = function(x) gsub(reg, "", x), ...)
}

#########################################################
#Wahrscheinlichkeit für Wörter nach Topich
td_beta <- tidy(STM)

td_beta %>%
  group_by(topic) %>%
  top_n(10, beta) %>%
  ungroup() %>%
  mutate(topic = paste0("Topic ", topic),
         term = reorder_within(term, beta, topic)) %>%
  ggplot(aes(term, beta, fill = as.factor(topic))) +
  geom_col(alpha = 0.8, show.legend = FALSE) +
  facet_wrap(~ topic, scales = "free_y") +
  coord_flip() +
  scale_x_reordered() +
  labs(x = NULL, y = expression(beta),
       title = "Höchste Wahrscheinlichkeit von Worten für jede Topic",
       subtitle = "Unterschiedliche Worte sind mit unterschiedlichen Topics assoziiert")

#########################################################
#lesen der "document feature matrix"
library(quanteda)
dfm1<- dfm(docs$content)

#########################################################
#Verteilung der Dokumentwahrscheinlichkeit für jedes Topic
td_gamma <- tidy(STM, matrix = "gamma",                    
                 document_names = rownames(dfm))

ggplot(td_gamma, aes(gamma, fill = as.factor(topic))) +
  geom_histogram(alpha = 0.8, show.legend = FALSE, binwidth = 0.01) +
  facet_wrap(~ topic, ncol = 3) +
  labs(title = "Verteilung der Wahrscheinlichkeiten, dass ein Dokument einem Topic zugeordned wird", subtitle = " ",
       y = "Anzahl von Dokumenten", x = expression(gamma))

#########################################################
#plot die Korrelation der Kovariaten "origin" und Topics
#Schätzen des Effekts 
prep <- estimateEffect(c(6) ~ origin, STM, meta = corpus$meta) # c(#) -> nimmt das Topic nr.#
plot.estimateEffect(prep, covariate = "origin")


#########################################################
#plot die Differenz des effektes zwischen zwei fällen bzgl. Herkunft
#prep <- estimateEffect(1:4 ~ origin, STM, meta = corpus$meta)
#plot(prep, "origin", method = 'difference', cov.value1 = "Eritrea",
#     cov.value2 = "Irak" )

#########################################################
#Speichern der 200 wahrscheinlichsten Wörter je Topic
out = "./stm_mostProbWords.tsv"
write.table(labelTopics(STM, n = 200)[[1]], out, quote = F, sep = "\t")

#########################################################
# speicher der Topic proportionen nach kovariaten
out <- cbind(STM$theta, corpus$meta$origin, corpus$meta$gutgeheissen)
thetaOut <- "./stm_Theta.txt"
write.table(out, thetaOut, quote = F, row.names = F, sep = "\t")

#########################################################
#topic-vs-topic
plot(STM, type = "perspectives", topics = c(1,5))

#########################################################
#topic relations
mod.out.corr <- topicCorr(STM)
plot(mod.out.corr)


####################################################################
# 8) Dinge die ich für die Shiny-Webaplication brauche:
#########################################################
#save to .Rda
save(STM, file = "STM.Rda")
save(dfm1, file = "dfm.Rda")
#see which countries are actualy in the data:
cnames<-sort(tolower(unique(docs$origin)), decreasing = FALSE)
cnames
save(cnames, file="cnames.Rda")