Nothing
R/btm.R
In BTM: Biterm Topic Models for Short Text
Defines functions
logLik.BTM
terms.data.frame
terms.BTM
predict.BTM
print.BTM
BTM
Documented in
BTM
logLik.BTM
predict.BTM
terms.BTM
terms.data.frame
#' @title Construct a Biterm Topic Model on Short Text
#' @description
#' The Biterm Topic Model (BTM) is a word co-occurrence based topic model that learns topics by modeling word-word co-occurrences patterns (e.g., biterms)
#'
#' \itemize{
#' \item A biterm consists of two words co-occurring in the same context, for example, in the same short text window.
#' \item BTM models the biterm occurrences in a corpus (unlike LDA models which model the word occurrences in a document).
#' \item It's a generative model. In the generation procedure, a biterm is generated by drawing two words independently from a same topic z.
#' In other words, the distribution of a biterm \eqn{b=(wi,wj)} is defined as: \eqn{P(b) = \sum_k{P(wi|z)*P(wj|z)*P(z)}}
#' where k is the number of topics you want to extract.
#' \item Estimation of the topic model is done with the Gibbs sampling algorithm. Where estimates are provided for \eqn{P(w|k)=phi} and \eqn{P(z)=theta}.
#' }
#' @references Xiaohui Yan, Jiafeng Guo, Yanyan Lan, Xueqi Cheng. A Biterm Topic Model For Short Text. WWW2013,
#' \url{https://github.com/xiaohuiyan/BTM}, \url{https://github.com/xiaohuiyan/xiaohuiyan.github.io/blob/master/paper/BTM-WWW13.pdf}
#' @param data a tokenised data frame containing one row per token with 2 columns
#' \itemize{
#' \item the first column is a context identifier (e.g. a tweet id, a document id, a sentence id, an identifier of a survey answer, an identifier of a part of a text)
#' \item the second column is a column called of type character containing the sequence of words occurring within the context identifier
#' }
#' @param k integer with the number of topics to identify
#' @param alpha numeric, indicating the symmetric dirichlet prior probability of a topic P(z). Defaults to 50/k.
#' @param beta numeric, indicating the symmetric dirichlet prior probability of a word given the topic P(w|z). Defaults to 0.01.
#' @param iter integer with the number of iterations of Gibbs sampling
#' @param window integer with the window size for biterm extraction. Defaults to 15.
#' @param background logical if set to \code{TRUE}, the first topic is set to a background topic that
#' equals to the empirical word distribution. This can be used to filter out common words. Defaults to FALSE.
#' @param trace logical indicating to print out evolution of the Gibbs sampling iterations. Defaults to FALSE.
#' @param biterms optionally, your own set of biterms to use for modelling.\cr
#' This argument should be a data.frame with column names doc_id, term1, term2 and cooc, indicating how many times each biterm (as indicated by terms term1 and term2)
#' is occurring within a certain doc_id. The field cooc indicates how many times this biterm happens with the doc_id. \cr
#' Note that doc_id's which are not in \code{data} are not allowed, as well as terms (in term1 and term2) which are not also in \code{data}.
#' See the examples.\cr
#' If provided, the \code{window} argument is ignored and the \code{data} argument will only be used to calculate the background word frequency distribution.
#' @param detailed logical indicating to return detailed output containing as well the vocabulary and the biterms used to construct the model. Defaults to FALSE.
#' @note
#' A biterm is defined as a pair of words co-occurring in the same text window.
#' If you have as an example a document with sequence of words \code{'A B C B'}, and assuming the window size is set to 3,
#' that implies there are two text windows which can generate biterms namely
#' text window \code{'A B C'} with biterms \code{'A B', 'B C', 'A C'} and text window \code{'B C B'} with biterms \code{'B C', 'C B', 'B B'}
#' A biterm is an unorder word pair where \code{'B C' = 'C B'}. Thus, the document \code{'A B C B'} will have the following biterm frequencies: \cr
#' \itemize{
#' \item 'A B': 1
#' \item 'B C': 3
#' \item 'A C': 1
#' \item 'B B': 1
#' }
#' These biterms are used to create the model.
#' @return an object of class BTM which is a list containing
#' \itemize{
#' \item{model: a pointer to the C++ BTM model}
#' \item{K: the number of topics}
#' \item{W: the number of tokens in the data}
#' \item{alpha: the symmetric dirichlet prior probability of a topic P(z)}
#' \item{beta: the symmetric dirichlet prior probability of a word given the topic P(w|z)}
#' \item{iter: the number of iterations of Gibbs sampling}
#' \item{background: indicator if the first topic is set to the background topic that equals the empirical word distribution.}
#' \item{theta: a vector with the topic probability p(z) which is determinated by the overall proportions of biterms in it}
#' \item{phi: a matrix of dimension W x K with one row for each token in the data. This matrix contains the probability of the token given the topic P(w|z).
#' the rownames of the matrix indicate the token w}
#' \item{vocab: a data.frame with columns token and freq indicating the frequency of occurrence of the tokens in \code{data}. Only provided in case argument \code{detailed} is set to \code{TRUE}}
#' \item{biterms: the result of a call to \code{terms} with type set to biterms, containing all the biterms used in the model. Only provided in case argument \code{detailed} is set to \code{TRUE}}
#' }
#' @export
#' @seealso \code{\link{predict.BTM}}, \code{\link{terms.BTM}}, \code{\link{logLik.BTM}}
#' @examples
#' \dontshow{if(require(udpipe) & require(data.table))\{}
#' library(udpipe)
#' data("brussels_reviews_anno", package = "udpipe")
#' x <- subset(brussels_reviews_anno, language == "nl")
#' x <- subset(x, xpos %in% c("NN", "NNP", "NNS"))
#' x <- x[, c("doc_id", "lemma")]
#' model <- BTM(x, k = 5, alpha = 1, beta = 0.01, iter = 10, trace = TRUE)
#' model
#' terms(model)
#' scores <- predict(model, newdata = x)
#'
#' ## Another small run with first topic the background word distribution
#' set.seed(123456)
#' model <- BTM(x, k = 5, beta = 0.01, iter = 10, background = TRUE)
#' model
#' terms(model)
#'
#' ##
#' ## You can also provide your own set of biterms to cluster upon
#' ## Example: cluster nouns and adjectives in the neighbourhood of one another
#' ##
#' library(data.table)
#' library(udpipe)
#' x <- subset(brussels_reviews_anno, language == "nl")
#' x <- head(x, 5500) # take a sample to speed things up on CRAN
#' biterms <- as.data.table(x)
#' biterms <- biterms[, cooccurrence(x = lemma,
#' relevant = xpos %in% c("NN", "NNP", "NNS", "JJ"),
#' skipgram = 2),
#' by = list(doc_id)]
#' head(biterms)
#' set.seed(123456)
#' x <- subset(x, xpos %in% c("NN", "NNP", "NNS", "JJ"))
#' x <- x[, c("doc_id", "lemma")]
#' model <- BTM(x, k = 5, beta = 0.01, iter = 10, background = TRUE,
#' biterms = biterms, trace = 10, detailed = TRUE)
#' model
#' terms(model)
#' bitermset <- terms(model, "biterms")
#' head(bitermset$biterms, 100)
#'
#' bitermset$n
#' sum(biterms$cooc)
#'
#' \dontshow{\} # End of main if statement running only if the required packages are installed}
#' \dontrun{
#' ##
#' ## Visualisation either using the textplot or the LDAvis package
#' ##
#' library(textplot)
#' library(ggraph)
#' library(concaveman)
#' plot(model, top_n = 4)
#'
#' library(LDAvis)
#' docsize <- table(x$doc_id)
#' scores <- predict(model, x)
#' scores <- scores[names(docsize), ]
#' json <- createJSON(
#' phi = t(model$phi),
#' theta = scores,
#' doc.length = as.integer(docsize),
#' vocab = model$vocabulary$token,
#' term.frequency = model$vocabulary$freq)
#' serVis(json)
#' }
BTM <- function(data, k = 5, alpha = 50/k, beta = 0.01, iter = 1000, window = 15, background = FALSE, trace = FALSE,
biterms, detailed = FALSE){
trace <- as.integer(trace)
background <- as.integer(as.logical(background))
stopifnot(k >= 1)
stopifnot(iter >= 1)
stopifnot(window >= 1)
iter <- as.integer(iter)
window <- as.integer(window)
stopifnot(inherits(data, "data.frame"))
if(ncol(data) == 2){
data <- data.frame(doc_id = data[[1]], token = data[[2]], stringsAsFactors = FALSE)
}else{
if(!all(c("doc_id", "token") %in% colnames(data))){
stop("please provide in data a data.frame with 2 columns as indicated in the help of BTM")
}
}
data <- data[!is.na(data$doc_id) & !is.na(data$token), ]
## Convert tokens to integer numbers which need to be pasted into a string separated by spaces
data$word <- factor(data$token)
if(detailed){
freq <- table(data$word)
freq <- as.data.frame(freq, responseName = "freq", stringsAsFactors = FALSE)
vocabulary <- data.frame(id = seq_along(levels(data$word)) - 1L,
token = levels(data$word),
freq = freq$freq[match(levels(data$word), freq$Var1)],
stringsAsFactors = FALSE)
}else{
vocabulary <- data.frame(id = seq_along(levels(data$word)) - 1L,
token = levels(data$word),
stringsAsFactors = FALSE)
}
data$word <- as.integer(data$word) - 1L
voc <- max(data$word) + 1
context <- split(data$word, data$doc_id)
context <- sapply(context, FUN=function(x) paste(x, collapse = " "))
## Handle manual set of biterms provided by user
if(missing(biterms)){
biterms <- data.frame(doc_id = character(), term1 = integer(), term2 = integer(), cooc = integer(), stringsAsFactors = FALSE)
biterms <- split(biterms, biterms$doc_id)
}else{
stopifnot(is.data.frame(biterms))
if(anyNA(biterms)){
stop("make sure there are no missing data in biterms")
}
if(!all(c("doc_id", "term1", "term2") %in% colnames(biterms))){
stop("please provide in biterms a data.frame with at least 3 columns: doc_id, term1, term2, cooc - see the example in the help of BTM")
}
if(!all("cooc" %in% colnames(biterms))){
biterms$cooc <- 1L
}else{
biterms$cooc <- as.integer(biterms$cooc)
}
recode <- function(x, from, to){
to[match(x, from)]
}
biterms$term1 <- recode(biterms$term1, from = vocabulary$token, to = vocabulary$id)
biterms$term2 <- recode(biterms$term2, from = vocabulary$token, to = vocabulary$id)
if(anyNA(biterms$term1) || anyNA(biterms$term2)){
stop("all terms in biterms should at least be available in data as well")
}
if(!all(biterms$doc_id %in% names(context))){
stop("all doc_id's of the biterms should at least be available data as well")
}
biterms <- split(biterms, factor(biterms$doc_id, levels = names(context)), drop = FALSE)
biterms <- lapply(biterms, FUN=function(x) as.list(x))
}
## build the model
model <- btm(biterms = biterms, x = context, K = k, W = voc, alpha = alpha, beta = beta, iter = iter, win = window, background = background, trace = as.integer(trace))
## make sure integer numbers are back tokens again
rownames(model$phi) <- vocabulary$token
## also include vocabulary
class(model) <- "BTM"
if(detailed){
model$vocabulary <- vocabulary[c("token", "freq")]
model$biterms <- terms.BTM(model, type = "biterms")
}
model
}
#' @export
print.BTM <- function(x, ...){
cat("Biterm Topic Model", sep = "\n")
cat(sprintf(" trained with %s Gibbs iterations, alpha: %s, beta: %s", x$iter, x$alpha, x$beta), sep = "\n")
cat(sprintf(" topics: %s", x$K), sep = "\n")
cat(sprintf(" size of the token vocabulary: %s", x$W), sep = "\n")
cat(sprintf(" topic distribution theta: %s", paste(round(x$theta, 3), collapse = " ")), sep = "\n")
}
#' @title Predict function for a Biterm Topic Model
#' @description Classify new text alongside the biterm topic model.\cr
#'
#' To infer the topics in a document, it is assumed that the topic proportions of a document
#' is driven by the expectation of the topic proportions of biterms generated from the document.
#' @param object an object of class BTM as returned by \code{\link{BTM}}
#' @param newdata a tokenised data frame containing one row per token with 2 columns
#' \itemize{
#' \item the first column is a context identifier (e.g. a tweet id, a document id, a sentence id, an identifier of a survey answer, an identifier of a part of a text)
#' \item the second column is a column called of type character containing the sequence of words occurring within the context identifier
#' }
#' @param type character string with the type of prediction.
#' Either one of 'sum_b', 'sub_w' or 'mix'. Default is set to 'sum_b' as indicated in the paper,
#' indicating to sum over the the expectation of the topic proportions of biterms generated from the document. For the other approaches, please inspect the paper.
#' @param ... not used
#' @references Xiaohui Yan, Jiafeng Guo, Yanyan Lan, Xueqi Cheng. A Biterm Topic Model For Short Text. WWW2013,
#' \url{https://github.com/xiaohuiyan/BTM}, \url{https://github.com/xiaohuiyan/xiaohuiyan.github.io/blob/master/paper/BTM-WWW13.pdf}
#' @seealso \code{\link{BTM}}, \code{\link{terms.BTM}}, \code{\link{logLik.BTM}}
#' @return a matrix containing containing P(z|d) - the probability of the topic given the biterms.\cr
#' The matrix has one row for each unique doc_id (context identifier)
#' which contains words part of the dictionary of the BTM model and has K columns,
#' one for each topic.
#' @export
#' @examples
#' \dontshow{if(require(udpipe))\{}
#' library(udpipe)
#' data("brussels_reviews_anno", package = "udpipe")
#' x <- subset(brussels_reviews_anno, language == "nl")
#' x <- subset(x, xpos %in% c("NN", "NNP", "NNS"))
#' x <- x[, c("doc_id", "lemma")]
#' model <- BTM(x, k = 5, iter = 5, trace = TRUE)
#' scores <- predict(model, newdata = x, type = "sum_b")
#' scores <- predict(model, newdata = x, type = "sub_w")
#' scores <- predict(model, newdata = x, type = "mix")
#' head(scores)
#' \dontshow{\} # End of main if statement running only if the required packages are installed}
predict.BTM <- function(object, newdata, type = c("sum_b", "sub_w", "mix"), ...){
type <- match.arg(type)
stopifnot(inherits(newdata, "data.frame"))
if(ncol(newdata) == 2){
newdata <- data.frame(doc_id = newdata[[1]], token = newdata[[2]], stringsAsFactors = FALSE)
}else{
if(!all(c("doc_id", "token") %in% colnames(newdata))){
stop("please provide in newdata a data.frame with 2 columns as indicated in the help of BTM")
}
}
newdata <- newdata[newdata$token %in% rownames(object$phi), ]
from <- rownames(object$phi)
to <- seq_along(rownames(object$phi))-1L
newdata$word <- to[match(newdata$token, from)]
context <- split(newdata$word, newdata$doc_id)
context <- sapply(context, FUN=function(x) paste(x, collapse = " "))
scores <- btm_infer(object, context, type)
rownames(scores) <- names(context)
scores
}
#' @title Get highest token probabilities for each topic or get biterms used in the model
#' @description Get highest token probabilities for each topic or get biterms used in the model
#' @param x an object of class BTM as returned by \code{\link{BTM}}
#' @param type a character string, either 'tokens' or 'biterms'. Defaults to 'tokens'.
#' @param threshold threshold in 0-1 range. Only the terms which are more likely than the threshold are returned for each topic. Only used in case type = 'tokens'.
#' @param top_n integer indicating to return the top n tokens for each topic only. Only used in case type = 'tokens'.
#' @param ... not used
#' @return
#' Depending if type is set to 'tokens' or 'biterms' the following is returned:
#' \itemize{
#' \item{If \code{type='tokens'}: }{Get the probability of the token given the topic P(w|z).
#' It returns a list of data.frames (one for each topic) where each data.frame contains columns token and probability ordered from high to low.
#' The list is the same length as the number of topics.}
#' \item{If \code{type='biterms'}: }{a list containing 2 elements:
#' \itemize{
#' \item \code{n} which indicates the number of biterms used to train the model
#' \item \code{biterms} which is a data.frame with columns term1, term2 and topic,
#' indicating for all biterms found in the data the topic to which the biterm is assigned to
#' }
#' Note that a biterm is unordered, in the output of \code{type='biterms'} term1 is always smaller than or equal to term2.}
#' }
#' @export
#' @seealso \code{\link{BTM}}, \code{\link{predict.BTM}}, \code{\link{logLik.BTM}}
#' @examples
#' \dontshow{if(require(udpipe))\{}
#' library(udpipe)
#' data("brussels_reviews_anno", package = "udpipe")
#' x <- subset(brussels_reviews_anno, language == "nl")
#' x <- subset(x, xpos %in% c("NN", "NNP", "NNS"))
#' x <- x[, c("doc_id", "lemma")]
#' model <- BTM(x, k = 5, iter = 5, trace = TRUE)
#' terms(model)
#' terms(model, top_n = 10)
#' terms(model, threshold = 0.01, top_n = +Inf)
#' bi <- terms(model, type = "biterms")
#' str(bi)
#' \dontshow{\} # End of main if statement running only if the required packages are installed}
terms.BTM <- function(x, type = c("tokens", "biterms"), threshold = 0, top_n = 5, ...){
type <- match.arg(type)
if(type %in% "biterms"){
from <- seq_along(rownames(x$phi))
to <- rownames(x$phi)
bit <- btm_biterms(x$model)
bit$biterms$term1 <- to[match(bit$biterms$term1, from)]
bit$biterms$term2 <- to[match(bit$biterms$term2, from)]
bit$biterms <- data.frame(term1 = bit$biterms$term1,
term2 = bit$biterms$term2,
topic = bit$biterms$topic, stringsAsFactors = FALSE)
bit <- bit[c("n", "biterms")]
bit
}else if(type == "tokens"){
apply(x$phi, MARGIN=2, FUN=function(x){
x <- data.frame(token = names(x), probability = x)
x <- x[x$probability >= threshold, ]
x <- x[order(x$probability, decreasing = TRUE), ]
rownames(x) <- NULL
head(x, top_n)
})
}
}
#' @title Get the set of Biterms from a tokenised data frame
#' @description
#' This extracts words occurring in the neighbourhood of one another, within a certain window range.
#' The default setting provides the biterms used when fitting \code{\link{BTM}} with the default window parameter.
#' @param x a tokenised data frame containing one row per token with 2 columns
#' \itemize{
#' \item the first column is a context identifier (e.g. a tweet id, a document id, a sentence id, an identifier of a survey answer, an identifier of a part of a text)
#' \item the second column is a column called of type character containing the sequence of words occurring within the context identifier
#' }
#' @param type a character string, either 'tokens' or 'biterms'. Defaults to 'tokens'.
#' @param window integer with the window size for biterm extraction. Defaults to 15.
#' @param ... not used
#' @return
#' Depending if type is set to 'tokens' or 'biterms' the following is returned:
#' \itemize{
#' \item{If \code{type='tokens'}: }{a list containing 2 elements:
#' \itemize{
#' \item \code{n} which indicates the number of tokens
#' \item \code{tokens} which is a data.frame with columns id, token and freq,
#' indicating for all tokens found in the data the frequency of occurrence
#' }
#' }
#' \item{If \code{type='biterms'}: }{a list containing 2 elements:
#' \itemize{
#' \item \code{n} which indicates the number of biterms used to train the model
#' \item \code{biterms} which is a data.frame with columns term1 and term2,
#' indicating all biterms found in the data. The same biterm combination can occur several times.
#' }
#' Note that a biterm is unordered, in the output of \code{type='biterms'} term1 is always smaller than or equal to term2.}
#' }
#' @note If \code{x} is a data.frame which has an attribute called 'terms', it just returns that \code{'terms'} attribute
#' @export
#' @seealso \code{\link{BTM}}, \code{\link{predict.BTM}}, \code{\link{logLik.BTM}}
#' @examples
#' \dontshow{if(require(udpipe))\{}
#' library(udpipe)
#' data("brussels_reviews_anno", package = "udpipe")
#' x <- subset(brussels_reviews_anno, language == "nl")
#' x <- subset(x, xpos %in% c("NN", "NNP", "NNS"))
#' x <- x[, c("doc_id", "lemma")]
#' biterms <- terms(x, window = 15, type = "biterms")
#' str(biterms)
#' tokens <- terms(x, type = "tokens")
#' str(tokens)
#' \dontshow{\} # End of main if statement running only if the required packages are installed}
terms.data.frame <- function(x, type = c("tokens", "biterms"), window = 15, ...){
v <- attr(x, "terms")
if(!is.null(v)){
return(v)
}
type <- match.arg(type)
stopifnot(window >= 1)
window <- as.integer(window)
data <- x
stopifnot(inherits(data, "data.frame"))
if(ncol(data) == 2){
data <- data.frame(doc_id = data[[1]], token = data[[2]], stringsAsFactors = FALSE)
}else{
if(!all(c("doc_id", "token") %in% colnames(data))){
stop("please provide in data a data.frame with 2 columns as indicated in the help of BTM")
}
}
data <- data[!is.na(data$doc_id) & !is.na(data$token), ]
## Convert tokens to integer numbers which need to be pasted into a string separated by spaces
data$word <- factor(data$token)
freq <- table(data$word)
freq <- as.data.frame(freq, responseName = "freq", stringsAsFactors = FALSE)
vocabulary <- data.frame(id = seq_along(levels(data$word)) - 1L,
token = levels(data$word),
freq = freq$freq[match(levels(data$word), freq$Var1)],
stringsAsFactors = FALSE)
if(type == "tokens"){
return(list(n = nrow(vocabulary), tokens = vocabulary))
}
data$word <- as.integer(data$word) - 1L
voc <- max(data$word) + 1
context <- split(data$word, data$doc_id)
context <- sapply(context, FUN=function(x) paste(x, collapse = " "))
from <- vocabulary$id + 1L
to <- vocabulary$token
bit <- btm_biterms_text(x = context, W = voc, win = window)
bit$biterms$term1 <- to[match(bit$biterms$term1, from)]
bit$biterms$term2 <- to[match(bit$biterms$term2, from)]
bit$biterms <- data.frame(term1 = bit$biterms$term1,
term2 = bit$biterms$term2,
stringsAsFactors = FALSE)
bit <- bit[c("n", "biterms")]
bit
}
#' @title Get the likelihood of biterms in a BTM model
#' @description Get the likelihood how good biterms are fit by the BTM model
#' @param object an object of class BTM as returned by \code{\link{BTM}}
#' @param data a data.frame with 2 columns term1 and term2 containing biterms. Defaults to the
#' biterms used to construct the model.
#' @param ... other arguments not used
#' @seealso \code{\link{BTM}}, \code{\link{predict.BTM}}, \code{\link{terms.BTM}}
#' @return a list with elements
#' \itemize{
#' \item likelihood: a vector with the same number of rows as \code{data} containing the likelihood
#' of the biterms alongside the BTM model. Calculated as \code{sum(phi[term1, ] * phi[term2, ] * theta)}.
#' \item \code{ll} the sum of the log of the biterm likelihoods
#' }
#' @export
#' @examples
#' \dontshow{if(require(udpipe))\{}
#' library(udpipe)
#' data("brussels_reviews_anno", package = "udpipe")
#' x <- subset(brussels_reviews_anno, language == "nl")
#' x <- subset(x, xpos %in% c("NN", "NNP", "NNS"))
#' x <- x[, c("doc_id", "lemma")]
#'
#' model <- BTM(x, k = 5, iter = 5, trace = TRUE, detailed = TRUE)
#' fit <- logLik(model)
#' fit$ll
#' \dontshow{\} # End of main if statement running only if the required packages are installed}
logLik.BTM <- function(object, data = terms.BTM(object, type = 'biterms')$biterms, ...){
stopifnot(inherits(data, "data.frame"))
stopifnot(all(c(data[[1]], data[[2]]) %in% rownames(object$phi)))
lik <- mapply(w1 = data[[1]],
w2 = data[[2]],
FUN = function(w1, w2){
sum(object$phi[w1, ] * object$phi[w2, ] * object$theta)
})
list(likelihood = lik, ll = sum(log(lik)))
}
Try the BTM package in your browser
Any scripts or data that you put into this service are public.
BTM documentation built on Feb. 16, 2023, 10:14 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions logLik.BTM terms.data.frame terms.BTM predict.BTM print.BTM BTM
Documented in BTM logLik.BTM predict.BTM terms.BTM terms.data.frame
#' @title Construct a Biterm Topic Model on Short Text
#' @description
#' The Biterm Topic Model (BTM) is a word co-occurrence based topic model that learns topics by modeling word-word co-occurrences patterns (e.g., biterms)
#'
#' \itemize{
#' \item A biterm consists of two words co-occurring in the same context, for example, in the same short text window.
#' \item BTM models the biterm occurrences in a corpus (unlike LDA models which model the word occurrences in a document).
#' \item It's a generative model. In the generation procedure, a biterm is generated by drawing two words independently from a same topic z.
#' In other words, the distribution of a biterm \eqn{b=(wi,wj)} is defined as: \eqn{P(b) = \sum_k{P(wi|z)*P(wj|z)*P(z)}}
#' where k is the number of topics you want to extract.
#' \item Estimation of the topic model is done with the Gibbs sampling algorithm. Where estimates are provided for \eqn{P(w|k)=phi} and \eqn{P(z)=theta}.
#' }
#' @references Xiaohui Yan, Jiafeng Guo, Yanyan Lan, Xueqi Cheng. A Biterm Topic Model For Short Text. WWW2013,
#' \url{https://github.com/xiaohuiyan/BTM}, \url{https://github.com/xiaohuiyan/xiaohuiyan.github.io/blob/master/paper/BTM-WWW13.pdf}
#' @param data a tokenised data frame containing one row per token with 2 columns
#' \itemize{
#' \item the first column is a context identifier (e.g. a tweet id, a document id, a sentence id, an identifier of a survey answer, an identifier of a part of a text)
#' \item the second column is a column called of type character containing the sequence of words occurring within the context identifier
#' }
#' @param k integer with the number of topics to identify
#' @param alpha numeric, indicating the symmetric dirichlet prior probability of a topic P(z). Defaults to 50/k.
#' @param beta numeric, indicating the symmetric dirichlet prior probability of a word given the topic P(w|z). Defaults to 0.01.
#' @param iter integer with the number of iterations of Gibbs sampling
#' @param window integer with the window size for biterm extraction. Defaults to 15.
#' @param background logical if set to \code{TRUE}, the first topic is set to a background topic that
#' equals to the empirical word distribution. This can be used to filter out common words. Defaults to FALSE.
#' @param trace logical indicating to print out evolution of the Gibbs sampling iterations. Defaults to FALSE.
#' @param biterms optionally, your own set of biterms to use for modelling.\cr
#' This argument should be a data.frame with column names doc_id, term1, term2 and cooc, indicating how many times each biterm (as indicated by terms term1 and term2)
#' is occurring within a certain doc_id. The field cooc indicates how many times this biterm happens with the doc_id. \cr
#' Note that doc_id's which are not in \code{data} are not allowed, as well as terms (in term1 and term2) which are not also in \code{data}.
#' See the examples.\cr
#' If provided, the \code{window} argument is ignored and the \code{data} argument will only be used to calculate the background word frequency distribution.
#' @param detailed logical indicating to return detailed output containing as well the vocabulary and the biterms used to construct the model. Defaults to FALSE.
#' @note
#' A biterm is defined as a pair of words co-occurring in the same text window.
#' If you have as an example a document with sequence of words \code{'A B C B'}, and assuming the window size is set to 3,
#' that implies there are two text windows which can generate biterms namely
#' text window \code{'A B C'} with biterms \code{'A B', 'B C', 'A C'} and text window \code{'B C B'} with biterms \code{'B C', 'C B', 'B B'}
#' A biterm is an unorder word pair where \code{'B C' = 'C B'}. Thus, the document \code{'A B C B'} will have the following biterm frequencies: \cr
#' \itemize{
#' \item 'A B': 1
#' \item 'B C': 3
#' \item 'A C': 1
#' \item 'B B': 1
#' }
#' These biterms are used to create the model.
#' @return an object of class BTM which is a list containing
#' \itemize{
#' \item{model: a pointer to the C++ BTM model}
#' \item{K: the number of topics}
#' \item{W: the number of tokens in the data}
#' \item{alpha: the symmetric dirichlet prior probability of a topic P(z)}
#' \item{beta: the symmetric dirichlet prior probability of a word given the topic P(w|z)}
#' \item{iter: the number of iterations of Gibbs sampling}
#' \item{background: indicator if the first topic is set to the background topic that equals the empirical word distribution.}
#' \item{theta: a vector with the topic probability p(z) which is determinated by the overall proportions of biterms in it}
#' \item{phi: a matrix of dimension W x K with one row for each token in the data. This matrix contains the probability of the token given the topic P(w|z).
#' the rownames of the matrix indicate the token w}
#' \item{vocab: a data.frame with columns token and freq indicating the frequency of occurrence of the tokens in \code{data}. Only provided in case argument \code{detailed} is set to \code{TRUE}}
#' \item{biterms: the result of a call to \code{terms} with type set to biterms, containing all the biterms used in the model. Only provided in case argument \code{detailed} is set to \code{TRUE}}
#' }
#' @export
#' @seealso \code{\link{predict.BTM}}, \code{\link{terms.BTM}}, \code{\link{logLik.BTM}}
#' @examples
#' \dontshow{if(require(udpipe) & require(data.table))\{}
#' library(udpipe)
#' data("brussels_reviews_anno", package = "udpipe")
#' x <- subset(brussels_reviews_anno, language == "nl")
#' x <- subset(x, xpos %in% c("NN", "NNP", "NNS"))
#' x <- x[, c("doc_id", "lemma")]
#' model <- BTM(x, k = 5, alpha = 1, beta = 0.01, iter = 10, trace = TRUE)
#' model
#' terms(model)
#' scores <- predict(model, newdata = x)
#'
#' ## Another small run with first topic the background word distribution
#' set.seed(123456)
#' model <- BTM(x, k = 5, beta = 0.01, iter = 10, background = TRUE)
#' model
#' terms(model)
#'
#' ##
#' ## You can also provide your own set of biterms to cluster upon
#' ## Example: cluster nouns and adjectives in the neighbourhood of one another
#' ##
#' library(data.table)
#' library(udpipe)
#' x <- subset(brussels_reviews_anno, language == "nl")
#' x <- head(x, 5500) # take a sample to speed things up on CRAN
#' biterms <- as.data.table(x)
#' biterms <- biterms[, cooccurrence(x = lemma,
#' relevant = xpos %in% c("NN", "NNP", "NNS", "JJ"),
#' skipgram = 2),
#' by = list(doc_id)]
#' head(biterms)
#' set.seed(123456)
#' x <- subset(x, xpos %in% c("NN", "NNP", "NNS", "JJ"))
#' x <- x[, c("doc_id", "lemma")]
#' model <- BTM(x, k = 5, beta = 0.01, iter = 10, background = TRUE,
#' biterms = biterms, trace = 10, detailed = TRUE)
#' model
#' terms(model)
#' bitermset <- terms(model, "biterms")
#' head(bitermset$biterms, 100)
#'
#' bitermset$n
#' sum(biterms$cooc)
#'
#' \dontshow{\} # End of main if statement running only if the required packages are installed}
#' \dontrun{
#' ##
#' ## Visualisation either using the textplot or the LDAvis package
#' ##
#' library(textplot)
#' library(ggraph)
#' library(concaveman)
#' plot(model, top_n = 4)
#'
#' library(LDAvis)
#' docsize <- table(x$doc_id)
#' scores <- predict(model, x)
#' scores <- scores[names(docsize), ]
#' json <- createJSON(
#' phi = t(model$phi),
#' theta = scores,
#' doc.length = as.integer(docsize),
#' vocab = model$vocabulary$token,
#' term.frequency = model$vocabulary$freq)
#' serVis(json)
#' }
BTM <- function(data, k = 5, alpha = 50/k, beta = 0.01, iter = 1000, window = 15, background = FALSE, trace = FALSE,
biterms, detailed = FALSE){
trace <- as.integer(trace)
background <- as.integer(as.logical(background))
stopifnot(k >= 1)
stopifnot(iter >= 1)
stopifnot(window >= 1)
iter <- as.integer(iter)
window <- as.integer(window)
stopifnot(inherits(data, "data.frame"))
if(ncol(data) == 2){
data <- data.frame(doc_id = data[[1]], token = data[[2]], stringsAsFactors = FALSE)
}else{
if(!all(c("doc_id", "token") %in% colnames(data))){
stop("please provide in data a data.frame with 2 columns as indicated in the help of BTM")
}
}
data <- data[!is.na(data$doc_id) & !is.na(data$token), ]
## Convert tokens to integer numbers which need to be pasted into a string separated by spaces
data$word <- factor(data$token)
if(detailed){
freq <- table(data$word)
freq <- as.data.frame(freq, responseName = "freq", stringsAsFactors = FALSE)
vocabulary <- data.frame(id = seq_along(levels(data$word)) - 1L,
token = levels(data$word),
freq = freq$freq[match(levels(data$word), freq$Var1)],
stringsAsFactors = FALSE)
}else{
vocabulary <- data.frame(id = seq_along(levels(data$word)) - 1L,
token = levels(data$word),
stringsAsFactors = FALSE)
}
data$word <- as.integer(data$word) - 1L
voc <- max(data$word) + 1
context <- split(data$word, data$doc_id)
context <- sapply(context, FUN=function(x) paste(x, collapse = " "))
## Handle manual set of biterms provided by user
if(missing(biterms)){
biterms <- data.frame(doc_id = character(), term1 = integer(), term2 = integer(), cooc = integer(), stringsAsFactors = FALSE)
biterms <- split(biterms, biterms$doc_id)
}else{
stopifnot(is.data.frame(biterms))
if(anyNA(biterms)){
stop("make sure there are no missing data in biterms")
}
if(!all(c("doc_id", "term1", "term2") %in% colnames(biterms))){
stop("please provide in biterms a data.frame with at least 3 columns: doc_id, term1, term2, cooc - see the example in the help of BTM")
}
if(!all("cooc" %in% colnames(biterms))){
biterms$cooc <- 1L
}else{
biterms$cooc <- as.integer(biterms$cooc)
}
recode <- function(x, from, to){
to[match(x, from)]
}
biterms$term1 <- recode(biterms$term1, from = vocabulary$token, to = vocabulary$id)
biterms$term2 <- recode(biterms$term2, from = vocabulary$token, to = vocabulary$id)
if(anyNA(biterms$term1) || anyNA(biterms$term2)){
stop("all terms in biterms should at least be available in data as well")
}
if(!all(biterms$doc_id %in% names(context))){
stop("all doc_id's of the biterms should at least be available data as well")
}
biterms <- split(biterms, factor(biterms$doc_id, levels = names(context)), drop = FALSE)
biterms <- lapply(biterms, FUN=function(x) as.list(x))
}
## build the model
model <- btm(biterms = biterms, x = context, K = k, W = voc, alpha = alpha, beta = beta, iter = iter, win = window, background = background, trace = as.integer(trace))
## make sure integer numbers are back tokens again
rownames(model$phi) <- vocabulary$token
## also include vocabulary
class(model) <- "BTM"
if(detailed){
model$vocabulary <- vocabulary[c("token", "freq")]
model$biterms <- terms.BTM(model, type = "biterms")
}
model
}
#' @export
print.BTM <- function(x, ...){
cat("Biterm Topic Model", sep = "\n")
cat(sprintf(" trained with %s Gibbs iterations, alpha: %s, beta: %s", x$iter, x$alpha, x$beta), sep = "\n")
cat(sprintf(" topics: %s", x$K), sep = "\n")
cat(sprintf(" size of the token vocabulary: %s", x$W), sep = "\n")
cat(sprintf(" topic distribution theta: %s", paste(round(x$theta, 3), collapse = " ")), sep = "\n")
}
#' @title Predict function for a Biterm Topic Model
#' @description Classify new text alongside the biterm topic model.\cr
#'
#' To infer the topics in a document, it is assumed that the topic proportions of a document
#' is driven by the expectation of the topic proportions of biterms generated from the document.
#' @param object an object of class BTM as returned by \code{\link{BTM}}
#' @param newdata a tokenised data frame containing one row per token with 2 columns
#' \itemize{
#' \item the first column is a context identifier (e.g. a tweet id, a document id, a sentence id, an identifier of a survey answer, an identifier of a part of a text)
#' \item the second column is a column called of type character containing the sequence of words occurring within the context identifier
#' }
#' @param type character string with the type of prediction.
#' Either one of 'sum_b', 'sub_w' or 'mix'. Default is set to 'sum_b' as indicated in the paper,
#' indicating to sum over the the expectation of the topic proportions of biterms generated from the document. For the other approaches, please inspect the paper.
#' @param ... not used
#' @references Xiaohui Yan, Jiafeng Guo, Yanyan Lan, Xueqi Cheng. A Biterm Topic Model For Short Text. WWW2013,
#' \url{https://github.com/xiaohuiyan/BTM}, \url{https://github.com/xiaohuiyan/xiaohuiyan.github.io/blob/master/paper/BTM-WWW13.pdf}
#' @seealso \code{\link{BTM}}, \code{\link{terms.BTM}}, \code{\link{logLik.BTM}}
#' @return a matrix containing containing P(z|d) - the probability of the topic given the biterms.\cr
#' The matrix has one row for each unique doc_id (context identifier)
#' which contains words part of the dictionary of the BTM model and has K columns,
#' one for each topic.
#' @export
#' @examples
#' \dontshow{if(require(udpipe))\{}
#' library(udpipe)
#' data("brussels_reviews_anno", package = "udpipe")
#' x <- subset(brussels_reviews_anno, language == "nl")
#' x <- subset(x, xpos %in% c("NN", "NNP", "NNS"))
#' x <- x[, c("doc_id", "lemma")]
#' model <- BTM(x, k = 5, iter = 5, trace = TRUE)
#' scores <- predict(model, newdata = x, type = "sum_b")
#' scores <- predict(model, newdata = x, type = "sub_w")
#' scores <- predict(model, newdata = x, type = "mix")
#' head(scores)
#' \dontshow{\} # End of main if statement running only if the required packages are installed}
predict.BTM <- function(object, newdata, type = c("sum_b", "sub_w", "mix"), ...){
type <- match.arg(type)
stopifnot(inherits(newdata, "data.frame"))
if(ncol(newdata) == 2){
newdata <- data.frame(doc_id = newdata[[1]], token = newdata[[2]], stringsAsFactors = FALSE)
}else{
if(!all(c("doc_id", "token") %in% colnames(newdata))){
stop("please provide in newdata a data.frame with 2 columns as indicated in the help of BTM")
}
}
newdata <- newdata[newdata$token %in% rownames(object$phi), ]
from <- rownames(object$phi)
to <- seq_along(rownames(object$phi))-1L
newdata$word <- to[match(newdata$token, from)]
context <- split(newdata$word, newdata$doc_id)
context <- sapply(context, FUN=function(x) paste(x, collapse = " "))
scores <- btm_infer(object, context, type)
rownames(scores) <- names(context)
scores
}
#' @title Get highest token probabilities for each topic or get biterms used in the model
#' @description Get highest token probabilities for each topic or get biterms used in the model
#' @param x an object of class BTM as returned by \code{\link{BTM}}
#' @param type a character string, either 'tokens' or 'biterms'. Defaults to 'tokens'.
#' @param threshold threshold in 0-1 range. Only the terms which are more likely than the threshold are returned for each topic. Only used in case type = 'tokens'.
#' @param top_n integer indicating to return the top n tokens for each topic only. Only used in case type = 'tokens'.
#' @param ... not used
#' @return
#' Depending if type is set to 'tokens' or 'biterms' the following is returned:
#' \itemize{
#' \item{If \code{type='tokens'}: }{Get the probability of the token given the topic P(w|z).
#' It returns a list of data.frames (one for each topic) where each data.frame contains columns token and probability ordered from high to low.
#' The list is the same length as the number of topics.}
#' \item{If \code{type='biterms'}: }{a list containing 2 elements:
#' \itemize{
#' \item \code{n} which indicates the number of biterms used to train the model
#' \item \code{biterms} which is a data.frame with columns term1, term2 and topic,
#' indicating for all biterms found in the data the topic to which the biterm is assigned to
#' }
#' Note that a biterm is unordered, in the output of \code{type='biterms'} term1 is always smaller than or equal to term2.}
#' }
#' @export
#' @seealso \code{\link{BTM}}, \code{\link{predict.BTM}}, \code{\link{logLik.BTM}}
#' @examples
#' \dontshow{if(require(udpipe))\{}
#' library(udpipe)
#' data("brussels_reviews_anno", package = "udpipe")
#' x <- subset(brussels_reviews_anno, language == "nl")
#' x <- subset(x, xpos %in% c("NN", "NNP", "NNS"))
#' x <- x[, c("doc_id", "lemma")]
#' model <- BTM(x, k = 5, iter = 5, trace = TRUE)
#' terms(model)
#' terms(model, top_n = 10)
#' terms(model, threshold = 0.01, top_n = +Inf)
#' bi <- terms(model, type = "biterms")
#' str(bi)
#' \dontshow{\} # End of main if statement running only if the required packages are installed}
terms.BTM <- function(x, type = c("tokens", "biterms"), threshold = 0, top_n = 5, ...){
type <- match.arg(type)
if(type %in% "biterms"){
from <- seq_along(rownames(x$phi))
to <- rownames(x$phi)
bit <- btm_biterms(x$model)
bit$biterms$term1 <- to[match(bit$biterms$term1, from)]
bit$biterms$term2 <- to[match(bit$biterms$term2, from)]
bit$biterms <- data.frame(term1 = bit$biterms$term1,
term2 = bit$biterms$term2,
topic = bit$biterms$topic, stringsAsFactors = FALSE)
bit <- bit[c("n", "biterms")]
bit
}else if(type == "tokens"){
apply(x$phi, MARGIN=2, FUN=function(x){
x <- data.frame(token = names(x), probability = x)
x <- x[x$probability >= threshold, ]
x <- x[order(x$probability, decreasing = TRUE), ]
rownames(x) <- NULL
head(x, top_n)
})
}
}
#' @title Get the set of Biterms from a tokenised data frame
#' @description
#' This extracts words occurring in the neighbourhood of one another, within a certain window range.
#' The default setting provides the biterms used when fitting \code{\link{BTM}} with the default window parameter.
#' @param x a tokenised data frame containing one row per token with 2 columns
#' \itemize{
#' \item the first column is a context identifier (e.g. a tweet id, a document id, a sentence id, an identifier of a survey answer, an identifier of a part of a text)
#' \item the second column is a column called of type character containing the sequence of words occurring within the context identifier
#' }
#' @param type a character string, either 'tokens' or 'biterms'. Defaults to 'tokens'.
#' @param window integer with the window size for biterm extraction. Defaults to 15.
#' @param ... not used
#' @return
#' Depending if type is set to 'tokens' or 'biterms' the following is returned:
#' \itemize{
#' \item{If \code{type='tokens'}: }{a list containing 2 elements:
#' \itemize{
#' \item \code{n} which indicates the number of tokens
#' \item \code{tokens} which is a data.frame with columns id, token and freq,
#' indicating for all tokens found in the data the frequency of occurrence
#' }
#' }
#' \item{If \code{type='biterms'}: }{a list containing 2 elements:
#' \itemize{
#' \item \code{n} which indicates the number of biterms used to train the model
#' \item \code{biterms} which is a data.frame with columns term1 and term2,
#' indicating all biterms found in the data. The same biterm combination can occur several times.
#' }
#' Note that a biterm is unordered, in the output of \code{type='biterms'} term1 is always smaller than or equal to term2.}
#' }
#' @note If \code{x} is a data.frame which has an attribute called 'terms', it just returns that \code{'terms'} attribute
#' @export
#' @seealso \code{\link{BTM}}, \code{\link{predict.BTM}}, \code{\link{logLik.BTM}}
#' @examples
#' \dontshow{if(require(udpipe))\{}
#' library(udpipe)
#' data("brussels_reviews_anno", package = "udpipe")
#' x <- subset(brussels_reviews_anno, language == "nl")
#' x <- subset(x, xpos %in% c("NN", "NNP", "NNS"))
#' x <- x[, c("doc_id", "lemma")]
#' biterms <- terms(x, window = 15, type = "biterms")
#' str(biterms)
#' tokens <- terms(x, type = "tokens")
#' str(tokens)
#' \dontshow{\} # End of main if statement running only if the required packages are installed}
terms.data.frame <- function(x, type = c("tokens", "biterms"), window = 15, ...){
v <- attr(x, "terms")
if(!is.null(v)){
return(v)
}
type <- match.arg(type)
stopifnot(window >= 1)
window <- as.integer(window)
data <- x
stopifnot(inherits(data, "data.frame"))
if(ncol(data) == 2){
data <- data.frame(doc_id = data[[1]], token = data[[2]], stringsAsFactors = FALSE)
}else{
if(!all(c("doc_id", "token") %in% colnames(data))){
stop("please provide in data a data.frame with 2 columns as indicated in the help of BTM")
}
}
data <- data[!is.na(data$doc_id) & !is.na(data$token), ]
## Convert tokens to integer numbers which need to be pasted into a string separated by spaces
data$word <- factor(data$token)
freq <- table(data$word)
freq <- as.data.frame(freq, responseName = "freq", stringsAsFactors = FALSE)
vocabulary <- data.frame(id = seq_along(levels(data$word)) - 1L,
token = levels(data$word),
freq = freq$freq[match(levels(data$word), freq$Var1)],
stringsAsFactors = FALSE)
if(type == "tokens"){
return(list(n = nrow(vocabulary), tokens = vocabulary))
}
data$word <- as.integer(data$word) - 1L
voc <- max(data$word) + 1
context <- split(data$word, data$doc_id)
context <- sapply(context, FUN=function(x) paste(x, collapse = " "))
from <- vocabulary$id + 1L
to <- vocabulary$token
bit <- btm_biterms_text(x = context, W = voc, win = window)
bit$biterms$term1 <- to[match(bit$biterms$term1, from)]
bit$biterms$term2 <- to[match(bit$biterms$term2, from)]
bit$biterms <- data.frame(term1 = bit$biterms$term1,
term2 = bit$biterms$term2,
stringsAsFactors = FALSE)
bit <- bit[c("n", "biterms")]
bit
}
#' @title Get the likelihood of biterms in a BTM model
#' @description Get the likelihood how good biterms are fit by the BTM model
#' @param object an object of class BTM as returned by \code{\link{BTM}}
#' @param data a data.frame with 2 columns term1 and term2 containing biterms. Defaults to the
#' biterms used to construct the model.
#' @param ... other arguments not used
#' @seealso \code{\link{BTM}}, \code{\link{predict.BTM}}, \code{\link{terms.BTM}}
#' @return a list with elements
#' \itemize{
#' \item likelihood: a vector with the same number of rows as \code{data} containing the likelihood
#' of the biterms alongside the BTM model. Calculated as \code{sum(phi[term1, ] * phi[term2, ] * theta)}.
#' \item \code{ll} the sum of the log of the biterm likelihoods
#' }
#' @export
#' @examples
#' \dontshow{if(require(udpipe))\{}
#' library(udpipe)
#' data("brussels_reviews_anno", package = "udpipe")
#' x <- subset(brussels_reviews_anno, language == "nl")
#' x <- subset(x, xpos %in% c("NN", "NNP", "NNS"))
#' x <- x[, c("doc_id", "lemma")]
#'
#' model <- BTM(x, k = 5, iter = 5, trace = TRUE, detailed = TRUE)
#' fit <- logLik(model)
#' fit$ll
#' \dontshow{\} # End of main if statement running only if the required packages are installed}
logLik.BTM <- function(object, data = terms.BTM(object, type = 'biterms')$biterms, ...){
stopifnot(inherits(data, "data.frame"))
stopifnot(all(c(data[[1]], data[[2]]) %in% rownames(object$phi)))
lik <- mapply(w1 = data[[1]],
w2 = data[[2]],
FUN = function(w1, w2){
sum(object$phi[w1, ] * object$phi[w2, ] * object$theta)
})
list(likelihood = lik, ll = sum(log(lik)))
}
Try the BTM package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.