---
title: "Topic Modelling for Screening of Systematic Review Abstracts- Wilson dataset"
author: "Leacky Kamau"
date: "09/08/2020"
Manuscript: html_document
editor_options: 
  chunk_Manuscript_type: console
---

# Introduction
For this case study, we merged and matched the whole set of 3453 documents to the 174 relevant documents using the **label** column. While this worked fine, for 4 documents, the titles were different as shown below. In these cases,  decided to assign the title corresponding to the subset of relevant documents.

```{r setup, include=FALSE}
# https://github.com/asreview/systematic-review-datasets
knitr::opts_chunk$set(echo = TRUE)
rm(list=ls())
while(!is.null(dev.list()))dev.off()
cat('\014')

pkglist <- list('plyr', 'tidyverse','tidytext', 'stringr', 'topicmodels', 
                'viridis', 'ldatuning', 'doParallel', 'tm', 'english',
                'wordcloud', 'tinytex')
lapply(pkglist, function(x)do.call('require', list(x)))

srabstracts <- readRDS('SRAbstracts_wilson.RDS')

srabstracts <- srabstracts %>% 
  dplyr::mutate(title=case_when(title.x!=title.y~title.y,
                                TRUE~title.x),
                abstract=paste(title, abstract))



dtmfunc <- function(infile, withstemming=TRUE, minFreqNum=3, maxFreqPerq=1, minwordLength=2){

ndocs <- as.numeric(length(infile))

# ignore extremely rare words i.e. terms that appear in less then 1% of the documents
minTermFreq <- minFreqNum# as.integer(ndocs*.01)

# ignore overly common words i.e. terms that appear in more than 50% of the documents
maxTermFreq <- as.integer(ndocs*maxFreqPerq)#as.integer( 30)


dtm  <-  DocumentTermMatrix(infile,
                         control = list(tolower=TRUE,
                                        removePunctuation =T,
                                        stopwords = TRUE, 
                                        removeNumbers = T,
                                        stemming = withstemming,
                                        bounds = list(global = c(minTermFreq, maxTermFreq)),
                                        wordLengths=c(minwordLength, Inf),
                                        stripWhitespace=T
))#%>%removeSparseTerms(sparse=.999)

 a <- apply(dtm,1 , sum)
dtm <-   dtm[a>0,]
 
return(dtm)
}



```

We combined the title and abstract to one string for classification for all documents. 

The data set comprises of `r dim(srabstracts)[1]` documents, with the distribution between documents that were classified as relevant/not relevant for the systematic review shown below. Only `r round(prop.table(xtabs(~ relevant, srabstracts))*100,2)[2]` \% of abstracts was considered relevant.

```{r}
xtabs(~ relevant, srabstracts)
```

 
## Methodological approach
The idea is to perform unsupervised text analysis using  'Topic modelling' methodology. With text modelling, the unique words across all documents form the vocabulary from which topics are learn't/derived.

Based on the derived topics,  a probabilistic model for each document is fitted to generate the document text. The key assumption to the topic modelling approach used in this manuscript (Latent Dirichlet Allocation) is that a document is generated from a set of topics which is a reasonable assumption for our intended use.

My idea of applying this methodology in systematic review is basically twofold:

\begin{enumerate}
\item First, I assume the standard steps in systematic review are followed in terms of defining search, inclusion and exclusion criteria.

\item  Then, based on the criteria, a set of documents is downloaded (we only need title and abstract).

\item  The third step would normally be a review of the downloaded documents  (**manually**) to screen for  potentially relevant documents based on their **title and abstract text**.

\begin{itemize}
\item This is the step we seek to automate to at least reduce the workload in manually screening systematic review text 
\end{itemize}

\item The potentially identified subset of relevant text (based on title and abstract text) is further scrutinized via a full text review. Since only a smaller subset of documents reach this step, there is  (***probably***) no much human-resource burden to necessitate automation at this step
\end{enumerate}

 
## Novelty
While topic modelling is a standard analysis, the novelty of this paper is in the adaptation of topic modelling to systematic review, particularly in the screening stage. The way we intend to implement this is to  define a **two-stage model**.

### First stage: LDA model
In the first stage, an LDA topic model  is estimated based on all available documents with a valid title and abstract.

For the case studies, the  relevance status of each document is known but in routine use, this is the label we wish to predict in an unsupervised way. From this model, we can have an idea of the training mis-classification error by evaluating the predicted versus true relevance status


### Second stage: Scoring keywords

The keyword corpus comprises of a data frame where each keyword used in the search strategy is a row. The idea is to use the model from the first stage to estimate the posterior probability of each keyword to belong to each modelled topic.

**topic_keyword_score**
The sum of posterior keyword probability given topic is an indicator of the topic relevance relative to the search terms used. Topics with high topic_keyword_score are potentially  more relevant than those with low topic_keyword_score.

  - ***The definition of the threshold score and topics to use for scoring a new document are described in the manuscript in details***



## Search terms used 

Process the search terms with the same options as the corpus, particularly stemming

```{r}
srsearchterms <- read.table('Search words_wilson_v2.txt', header=F ) %>%
# srsearchterms <- read.table('Search words_wilson.txt', header=F ) %>% 
  unite(col='text', sep=' ') %>%
  dplyr::mutate(text=iconv(text, 'utf-8', 'ascii', sub=' '),
                text=gsub('[0-9]','', text ))%>%
  unnest_tokens(word, text)%>%anti_join(stop_words) %>%
  dplyr::rename(keyword=word) %>% 
dplyr::filter(nchar(keyword)>3) %>% 
  dplyr::mutate(keyword=tolower(keyword)) %>%
  dplyr::distinct(keyword) %>% 
  arrange(keyword) %>% 
    dplyr::mutate(doc_id=1:n()) %>% 
    dplyr::rename(text=keyword) %>% 
  dplyr::select(doc_id, text)

srInfile <- Corpus(DataframeSource(srsearchterms))

srInfile <- dtmfunc(infile = srInfile, withstemming=TRUE, minFreqNum=1, maxFreqPerq=1, minwordLength=1)
                                        

srsearchstem <- sort(tidy(srInfile)$term)
srsearchterms$stemword <- tidy(srInfile)$term

```



## Exploratory

## Most frequent words in the abstracts

 
```{r}
corpus <- srabstracts %>% 
  dplyr::mutate(docid=paste0(1:n(), '_', relevantFT) , docid=paste(docid, relevant, sep='#')) %>% 
  dplyr::select(docid, abstract, year)%>%
  dplyr::rename(text=abstract)%>% unnest_tokens(word, text) %>% 
  anti_join(stop_words) %>% 
  dplyr::mutate(word=str_extract(word, "[a-z]+")) %>% 
  dplyr::filter(!is.na(word))

cleaned <- corpus %>% dplyr::count(word, sort=T) %>% dplyr::mutate(nperc=100*(n/n()))

cleaned %>%#filter( n>50) %>% arrange(nperc) %>% 
  top_n(20) %>% 
  dplyr::mutate(word=reorder(word, nperc)) %>% 
  ggplot(aes(x=word, y=nperc))+geom_col()+
  labs(x=NULL, y='Word occurrence (%)')+coord_flip()


```



## Perform LDA
First recreate the text per document without stopwords and puctuation. Also filter any specific words if needed.

```{r}
ldacorpus <- corpus %>% group_by(docid) %>% 
  dplyr::summarise(text=toString(word)) %>% 
  dplyr::mutate(text=gsub(',|textcopyright', ' ', text),
                text=gsub(paste0(english(1:100), collapse='|'),' ', text),
                text=stripWhitespace(gsub('[[:punct:]]+',' ', text))
                ) %>%
   dplyr::rename(doc_id=docid)


infile <-  Corpus(DataframeSource(data.frame(ldacorpus)))


full_data=dtmfunc(infile = infile )
```


# LDA tuning approach


```{r, echo=TRUE}

burnin = 100
iter = 2000
keep = 50 
NTopics <- c(seq(2,50, 4)) 
Nstart <- 3 #Number of chains?
seed <- seq(2010, 2020, length.out = Nstart)

ldalist <- list(burnin=burnin, iter=iter, keep=keep, seed=seed, nstart=Nstart)
```

## without stemming
```{r}
tunetopics <- function(full_data){
tunes <-   FindTopicsNumber(
   dtm = full_data,
   topics=NTopics,
   metrics = c("Griffiths2004", "CaoJuan2009", "Arun2010"),
   method = "Gibbs",
   control = list(seed = seed, burnin = burnin, iter = iter),#, keep = keep),
   mc.cores = detectCores(),
   verbose = TRUE
)
 
saveRDS(tunes, 'Manuscript/tunes_wilson.rds')
}

```

```{r, LDatuning, cache=TRUE}
tunetopics(full_data)

```

```{r, plotldatuning, fig.cap='Abstracts: number of topics.'}
tunes <- readRDS('Manuscript/tunes_wilson.rds')
FindTopicsNumber_plot(tunes)

```


# Perform LDA and visualize the topics
```{r, ldafunc}
#=====================Presentation of results===============

LDAFinal <- function(full_data, appendname, nclust=10, model='LDA', homedir=getwd()){
   
  if(model=='LDA'){
FinalModel <- LDA(full_data, k = nclust, method = "Gibbs",
                  control = ldalist#list(burnin = burnin, iter = iter, seed=seed) 
                  )
  }
  
  if(model=='CTM'){
FinalModel <- CTM(full_data, k = nclust, method = "VEM")
  }
  
  ggsave(paste0(model, '_Loglike_', nclust, '.pdf'), width=11, height = 6,

(data.frame(loglike=FinalModel@logLiks) %>% rowid_to_column() %>% 
  ggplot(aes(x=rowid, y=loglike))+geom_point()+geom_line()
  ) 
)
# approach to drawing word clouds of all topics from an object created with LDA,
# taken from /blog/2016/12/31/sparse-bags
# Beta matrix: probability of a word to belong to a given topic  
 lda <- FinalModel

p <- posterior(lda)
w1 <- as.data.frame(t(p$terms)) 
w2 <- w1 %>%
   dplyr::mutate(word = rownames(w1)) %>%
   tidyr::gather(topic, weight, -word) 

dirTopic <- paste0(homedir, '/Topics_', appendname, '_', nclust)

if(dir.exists(dirTopic)){
  unlink(dirTopic, recursive = T)
}

dir.create(dirTopic)
 

# need to be careful for warnings that words didn't fit in, 
# in which case make the png device larger
# remove any PNG files sitting around in the temp folder
unlink("*.png")
outlist <- list.files(dirTopic)

if(length(outlist)>0){
  lapply(outlist, function(x)file.remove(file.path(dirTopic, x)))
}

# create a PNG for each frame of the animation

for(i in 1:ncol(w1)){
  picname <-  file.path(getwd(), dirTopic, paste0('Topic',i, ".png"))
   
  png(filename=picname, width=8 * 100, height=8 * 100, res = 100)
   
  par(bg = "grey95")
   w3 <- w2 %>%
      filter(topic == i ) %>%
      arrange(desc(weight))
   
n <- min(100, nrow(w3)); palette = "Greens";
pal <- rep( brewer.pal(9, palette), each = ceiling(n / 9))[n:1]

   
   with(w3[1:n, ]%>%dplyr::filter(!is.na(weight)), 
        wordcloud(word, freq = weight, random.order = FALSE, 
                  ordered.colors = TRUE, colors = pal))
   title(paste("Topic", i))
   dev.off()
}

while(!is.null(dev.list()))dev.off()
# combine all those png frames into a single animated GIF
# system('magick -loop 0 -delay 120 *.png "UoNArticles.gif"')
 
return(FinalModel)
}
```

```{r, cache=TRUE}
ldatopics <- 35
# FinalAbstract<- LDAFinal(full_data=full_data, appendname='Abstract', model = 'LDA', nclust=10)
FinalAbstract<- LDAFinal(full_data=full_data, appendname='Abstract', model = 'LDA', nclust=ldatopics, homedir = 'Manuscript')

saveRDS(FinalAbstract, paste0('Manuscript/FinalAbstract_wilson',  '.Rdata'))

```
 

# Document-topic and topic-word probabilities
Besides estimating each topic as a mixture of words, LDA also models each document as a mixture of topics. We can examine the per-document-per-topic probabilities, called  
$\gamma$  (“gamma”), with the matrix = "gamma" argument to tidy(). The beta matrix- denoting the word-topic probability is extracted with the  


## Words comprising a topic
Top 5 words per topic
```{r} 
FinalAbstract <- readRDS(paste0('Manuscript/FinalAbstract_wilson',  '.Rdata'))

TopicTermsFunc <- function(FinalModel){
ap_top_terms <- FinalModel %>%tidy()%>%
  group_by(topic) %>%
  top_n(5, beta) %>%
  ungroup()%>%
  arrange(topic, -beta)
   
print(ap_top_terms %>%
  dplyr::mutate(term = reorder_within(term, beta, topic)) %>%
  ggplot(aes(term, beta, fill = factor(topic))) +
  geom_col(show.legend = FALSE) +
  facet_wrap(~ topic, scales = "free_y") +
  coord_flip() +
  scale_x_reordered())#%>%print())

return(ap_top_terms)
}


```

```{r, fig.cap='Topics based on Abstracts-20'}
ap_top_terms <- TopicTermsFunc(FinalModel = FinalAbstract)

```

## Documents -topic composition

```{r}
DocumentsTopic <- function(FinalModel, topn=TRUE, n=10){
ap_documents <- tidy(FinalModel, matrix = "gamma")%>%
  group_by(topic) %>%   
  ungroup() %>%
  arrange(topic, -gamma)%>%
  tidyr::separate(document, into=c('document', 'relevant'), sep='#')
   
if(topn==TRUE){
ap_documents <- tidy(FinalModel, matrix = "gamma")%>%
  group_by(topic) %>%   top_n(n, gamma)  %>%
  ungroup() %>%
  arrange(topic, -gamma)%>%
  tidyr::separate(document, into=c('document', 'relevant'), sep='#')
   
}

print(ap_documents %>%#filter(!is.na(topic)&gamma>0.02),
  mutate(document = reorder_within(document, gamma, topic)) %>%
  ggplot(aes(document, gamma, fill = relevant)) +
  geom_col(show.legend = T) +
  facet_wrap(~ topic, scales = "free_y") +
  coord_flip() +
  scale_x_reordered())#%>%print()



return(ap_documents)
}

```


 Top 10 documents per topic

```{r, fig.cap='Topics based on Abstracts'}
ap_documents_abstract <-DocumentsTopic(FinalModel = FinalAbstract)
```



<!-- ## Top document per topic -->

<!-- See how well the top document in a topic is unique to the topics. -->

```{r}
# 
#  
ap_documentsCheck <- list( tidy(FinalAbstract, matrix = "gamma")%>%mutate(method='Abstract')#,
                           )%>%bind_rows()%>%
  tidyr::separate(document, into=c( 'document', 'relevant'), sep='#')


```


All topics composition

```{r}


ap_documentsCheck%>%group_by(relevant)%>%
  dplyr::summarise(n=n())

ap_documentsCheck%>%
  # filter(document%in%topdocs$document)%>%
    mutate(topic =factor(topic ), relevant=factor(relevant, levels=c(0,1), labels = c('Not relevant', 'Relevant'))) %>%
  ggplot(aes(y=document, x=topic, fill = gamma)) +
  geom_raster()+
  scale_fill_viridis(option = 'A', discrete = F)+
  # geom_bar(stat = 'identity' ) +
  facet_wrap(~ relevant, scales = "free_y")  +
  theme(axis.text.y = element_blank())#, axis.text.x = element_text(angle=90))
  # coord_flip() #+



```
  


# Search keywords scoring

Check posterior probability of the search keywords of interest per topic

```{r}
srtermfuncall <- function(FinalModel = FinalAbstract){
  wordmatch <- FinalModel %>%tidy()%>%
  group_by(topic) %>%
    right_join(data.frame(term=srsearchstem), by='term') %>% 
    right_join(srsearchterms %>% dplyr::select(-doc_id), by=c('term'='stemword')) %>% 
   ungroup()%>%
  arrange(topic, -beta) #%>% #dplyr::filter(topic==1) %>% 
  # group_by(topic)# %>% 
  # dplyr::mutate(nmatch=term%in%(srsearchstem)) %>% 
  # dplyr::summarise(nmatch=sum(nmatch)) %>% 
  # arrange(-nmatch) %>% 
    # dplyr::mutate(nwords=nwords)
  return(wordmatch)
  
}

# wordvec <- as.list(c(seq(5, 24, 2)))

wordmatchall <-  srtermfuncall() 

wordmatchall <- wordmatchall%>% 
  dplyr::mutate(topic=factor(topic, levels=1:ldatopics, labels=1:ldatopics))

(ggplot(wordmatchall  %>% filter(#!is.na(beta)#& topic%in%1:ldatopics
                                 ), 
        aes(y=topic, #reorder(term, beta),
            # x=reorder_within(term, beta, topic),
            x=text, fill=beta))+
  labs(x='Search term', y='Topic') +
    geom_tile()+
    # facet_wrap(~topic, scale='free_y')+
      # coord_flip() +
    theme(axis.text.x = element_text(angle=90, vjust=0.5, hjust=0.5, size=7))
  )


srsearchscore <- wordmatchall %>% filter(!is.na(beta)) %>% group_by(topic) %>% 
  dplyr::summarise(score=sum(beta, na.rm=TRUE)) %>% 
  dplyr::mutate(zscore=c(scale(score))
) %>% 
  arrange(-score)

cutperc <- c(0, 0.2, 0.5, 0.8, 0.85,
             0.9, .95, 1)
ndig <- 5

(quantperc <- quantile(srsearchscore$score, cutperc))

(a <- levels(cut(srsearchscore$score, quantperc, dig.lab = ndig)))

(b=quantperc %>% data.frame() %>% rownames_to_column('percentile') %>% rename(upperbnd= '.') %>% mutate(upperbnd=signif(upperbnd, ndig))
)

srsearchscore <- srsearchscore %>% dplyr::mutate(
  Cat=cut(score, quantile(score, cutperc), include.lowest = T, dig.lab = ndig ),
                catnum=as.numeric(Cat)) %>% 
  tidyr::separate(Cat, into=c('lowerbnd', 'upperbnd'), sep=',', remove=F) %>% 
  dplyr::mutate_if(colnames(.)%in% c('lowerbnd', 'upperbnd'), function(x)as.numeric(gsub('\\(|\\]|\\[','',x))) %>% left_join(b, by='upperbnd')%>% 
  dplyr::mutate(percentile=factor(percentile, levels=names(quantperc)))


```

## Keywords score per topic: raw score or a z-score?

Work with raw score
***Raw score***

```{r}
(ggplot(srsearchscore, aes(x= reorder(topic, score), y=score, fill=percentile))+
   geom_col()+
   theme(axis.text.x = element_text(angle=90))+
   labs(x='Topic')#+coord_flip()
   )

```

```{r}
(ggplot(srsearchscore, aes( y=score , fill=percentile))+
   geom_histogram(bins=40, position = 'dodge')+
   coord_flip()
   )

```
 

For the **selected most relevant topics**, compute the corresponding document probability **relevance threshold**.

So also for a new document, the posterior document probability score for the selected topics document would be evaluated against this threshold to determining its relevance.

```{r}
srsearchscore %>% distinct(percentile, catnum, Cat)

#Selected topics
catrange <- 4:20
topwordscore <- srsearchscore %>% arrange(-score) %>%
  dplyr::filter(catnum%in%catrange)%>%
  dplyr::select(topic) 

topwordscore <-  as.numeric(as.character(topwordscore[[1]]))

#Score of documnet for selected topics
documentscore <- ap_documentsCheck%>%
  dplyr::filter(topic%in%topwordscore)%>%
  group_by(document, relevant) %>% 
  dplyr::summarise(score=sum(gamma, na.rm = TRUE))

documentscore$zscore <- c(scale(documentscore$score))

    

#Score threshold associated with selected topics

documentterms <- full_data %>% tidy() %>%
  left_join(srsearchterms %>% dplyr::select(-doc_id) %>% 
              dplyr::rename(term=stemword), by='term')
 

betamat <- FinalAbstract %>%tidy() %>% dplyr::filter(topic%in%topwordscore)
 
relevancethreshold <- srsearchscore %>% dplyr::filter(topic%in%topwordscore) %>%
  dplyr::summarise(score=sum(score)) %>% pull()

documenttermscore <-  plyr::ddply(documentterms, .(document), function(x)(x %>% left_join(betamat, by='term'))) %>%
  dplyr::mutate(beta=case_when(is.na(text)~0,
                               TRUE~beta))%>% group_by(document) %>% 
  dplyr::summarise(scoreterm=sum(beta*count, na.rm = T)) %>% 
 tidyr::separate(document, into=c('document', 'relevant'), sep='#') %>% 
  tidyr::separate(document, into=c('document', 'relevantFT'), sep='_') %>% 
  left_join(documentscore, by=c('document', 'relevant'))%>% 
  dplyr::mutate(predrelevant=as.numeric(scoreterm>=relevancethreshold) 
)
 
#Documents without search keywords
documenttermscore %>% filter(scoreterm==0) %>% nrow()
xtabs(~relevant+predrelevant, documenttermscore)
prop.table(xtabs(~relevant+predrelevant, documenttermscore), margin = 1)*100
 



xtabs(~relevant+relevantFT, documenttermscore)
xtabs(~relevant+relevantFT+predrelevant, documenttermscore)
prop.table(xtabs(~relevantFT+predrelevant, documenttermscore), margin = 1)*100

xtabs(~relevant+relevantFT+predrelevant, documenttermscore) %>%
  data.frame() %>% arrange(relevant)

```

 
  