Allow seed words for #30

quanteda · Aug 10, 2020 · c22bd43 · c22bd43
1 parent 9a50fbc
commit c22bd43
Show file tree

Hide file tree

Showing 5 changed files with 52 additions and 12 deletions.
diff --git a/R/RcppExports.R b/R/RcppExports.R
@@ -5,8 +5,8 @@ qatd_cpp_ca <- function(dfm, residual_floor) {
     .Call(`_quanteda_textmodels_qatd_cpp_ca`, dfm, residual_floor)
 }
 
-qatd_cpp_lda <- function(mt, k, max_iter, alpha, beta, verbose) {
-    .Call(`_quanteda_textmodels_qatd_cpp_lda`, mt, k, max_iter, alpha, beta, verbose)
+qatd_cpp_lda <- function(mt, k, max_iter, alpha, beta, seeds, verbose) {
+    .Call(`_quanteda_textmodels_qatd_cpp_lda`, mt, k, max_iter, alpha, beta, seeds, verbose)
 }
 
 qatd_cpp_tbb_enabled <- function() {

diff --git a/R/textmodel_lda.R b/R/textmodel_lda.R
@@ -17,10 +17,16 @@ textmodel_lda.dfm <- function(
         alpha <- -1.0
     if (is.null(beta))
         beta <- -1.0
-
-    result <- qatd_cpp_lda(x, k, max_iter, alpha, beta, verbose)
-
-    topic <- paste0("topic", seq_len(k))
+    if (is.null(seeds)) {
+        seeds <- as(Matrix::sparseMatrix(nfeat(x), k), "dgCMatrix")
+        topic <- paste0("topic", seq_len(k))
+    } else {
+        if (!identical(colnames(x), rownames(seeds)))
+            stop("seeds must have the same features")
+        k <- ncol(seeds)
+        topic <- colnames(seeds)
+    }
+    result <- qatd_cpp_lda(x, k, max_iter, alpha, beta, seeds, verbose)
     dimnames(result$phi) <- list(topic, colnames(x))
     dimnames(result$theta) <- list(rownames(x), topic)
     result$alpha <- alpha
@@ -56,3 +62,34 @@ topics <- function(x) {
 topics.textmodel_lda <- function(x) {
     colnames(x$theta)[max.col(x$theta)]
 }
+
+#' Internal function to construct topic-feature matrix
+#' @import Matrix quanteda
+#' @noRd
+tfm <- function(x, dictionary,
+                valuetype = c("glob", "regex", "fixed"),
+                case_insensitive = TRUE,
+                weight = 0.01, residual = TRUE) {
+
+    valuetype <- match.arg(valuetype)
+    if (weight < 0)
+        stop("weight must be pisitive a value")
+    id_key <- id_feat <- integer()
+    for (i in seq_along(dictionary)) {
+        f <- featnames(dfm_select(x, dictionary[i]))
+        id_key <- c(id_key, rep(i, length(f)))
+        id_feat <- c(id_feat, match(f, featnames(x)))
+    }
+    count <- rep(floor(sum(x) * weight), length(id_feat))
+    key <- names(dictionary)
+    if (residual)
+        key <- c(key, "other")
+    result <- Matrix::sparseMatrix(
+        i = id_feat,
+        j = id_key,
+        x = count,
+        dims = c(nfeat(x), length(key)),
+        dimnames = list(featnames(x), key)
+    )
+    as.dfm(result)
+}
diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp
@@ -19,8 +19,8 @@ BEGIN_RCPP
 END_RCPP
 }
 // qatd_cpp_lda
-List qatd_cpp_lda(arma::sp_mat& mt, int k, int max_iter, double alpha, double beta, bool verbose);
-RcppExport SEXP _quanteda_textmodels_qatd_cpp_lda(SEXP mtSEXP, SEXP kSEXP, SEXP max_iterSEXP, SEXP alphaSEXP, SEXP betaSEXP, SEXP verboseSEXP) {
+List qatd_cpp_lda(arma::sp_mat& mt, int k, int max_iter, double alpha, double beta, arma::sp_mat& seeds, bool verbose);
+RcppExport SEXP _quanteda_textmodels_qatd_cpp_lda(SEXP mtSEXP, SEXP kSEXP, SEXP max_iterSEXP, SEXP alphaSEXP, SEXP betaSEXP, SEXP seedsSEXP, SEXP verboseSEXP) {
 BEGIN_RCPP
     Rcpp::RObject rcpp_result_gen;
     Rcpp::RNGScope rcpp_rngScope_gen;
@@ -29,8 +29,9 @@ BEGIN_RCPP
     Rcpp::traits::input_parameter< int >::type max_iter(max_iterSEXP);
     Rcpp::traits::input_parameter< double >::type alpha(alphaSEXP);
     Rcpp::traits::input_parameter< double >::type beta(betaSEXP);
+    Rcpp::traits::input_parameter< arma::sp_mat& >::type seeds(seedsSEXP);
     Rcpp::traits::input_parameter< bool >::type verbose(verboseSEXP);
-    rcpp_result_gen = Rcpp::wrap(qatd_cpp_lda(mt, k, max_iter, alpha, beta, verbose));
+    rcpp_result_gen = Rcpp::wrap(qatd_cpp_lda(mt, k, max_iter, alpha, beta, seeds, verbose));
     return rcpp_result_gen;
 END_RCPP
 }
@@ -83,7 +84,7 @@ END_RCPP
 
 static const R_CallMethodDef CallEntries[] = {
     {"_quanteda_textmodels_qatd_cpp_ca", (DL_FUNC) &_quanteda_textmodels_qatd_cpp_ca, 2},
-    {"_quanteda_textmodels_qatd_cpp_lda", (DL_FUNC) &_quanteda_textmodels_qatd_cpp_lda, 6},
+    {"_quanteda_textmodels_qatd_cpp_lda", (DL_FUNC) &_quanteda_textmodels_qatd_cpp_lda, 7},
     {"_quanteda_textmodels_qatd_cpp_tbb_enabled", (DL_FUNC) &_quanteda_textmodels_qatd_cpp_tbb_enabled, 0},
     {"_quanteda_textmodels_qatd_cpp_wordfish_dense", (DL_FUNC) &_quanteda_textmodels_qatd_cpp_wordfish_dense, 7},
     {"_quanteda_textmodels_qatd_cpp_wordfish", (DL_FUNC) &_quanteda_textmodels_qatd_cpp_wordfish, 9},

diff --git a/src/lda.cpp b/src/lda.cpp
@@ -8,7 +8,7 @@ using namespace Rcpp;
 
 // [[Rcpp::export]]
 List qatd_cpp_lda(arma::sp_mat &mt, int k, int max_iter, double alpha, double beta,
-                  bool verbose) {
+                  arma::sp_mat &seeds, bool verbose) {
     model lda;
     lda.set_data(mt);
 
@@ -22,6 +22,8 @@ List qatd_cpp_lda(arma::sp_mat &mt, int k, int max_iter, double alpha, double be
     if (verbose)
         lda.verbose = verbose;
     if (lda.init_est() == 0) {
+        if (arma::size(seeds) == arma::size(lda.nw) && arma::accu(seeds) > 0)
+            lda.nw = lda.nw + arma::conv_to<arma::umat>::from(arma::mat(seeds));
         lda.estimate();
     }
 

diff --git a/src/lda.h b/src/lda.h
@@ -212,7 +212,7 @@ int model::sampling(int m, int n, int w) {
     // do multinomial sampling via cumulative method
     for (int k = 0; k < K; k++) {
         p[k] = (nw.at(w, k) + beta) / (nwsum[k] + Vbeta) *
-            (nd.at(m, k) + alpha) / (ndsum[m] + Kalpha);
+               (nd.at(m, k) + alpha) / (ndsum[m] + Kalpha);
     }
     // cumulate multinomial parameters
     for (int k = 1; k < K; k++) {