tests/testthat/test-rJST.R

In sentopics: Tools for Joint Sentiment and Topic Analysis of Textual Data

context("testing rJST")
toks <- ECB_press_conferences_tokens[1:10]

rJST <- rJST(toks, lexicon = LoughranMcDonald)

test_that("rJST works", {
  expect_output(
    print(rJST),
    "A reverse-JST model with 5 topics and 3 sentiments. Currently fitted by 0 Gibbs sampling iterations."
  )
  tabl <- table(rJST$vocabulary$lexicon)
  expect_length(tabl, 3)
  expect_gt(sum(tabl), 0)
  rJST <- fit(rJST, 2, displayProgress = FALSE)
  expect_true(check_integrity(rJST, fast = FALSE))
  expect_s3_class(rJST, "rJST")
  expect_equal(attr(rJST, "reverse"), TRUE)

  rJST2 <- fit(rJST, 2, nChains = 2, displayProgress = FALSE)
  rJST2 <- fit(rJST2, 2, displayProgress = FALSE)
  expect_identical(attr(rJST2, "containedClass"), "rJST")

  expect_true(all(sapply(rJST2, function(x) attr(x, "reverse"))))
  expect_true(all(sapply(rJST2, check_integrity, fast = FALSE)))
})

test_that("invalid hyperparameter updates do not corrupt the model", {
  model <- rJST(
    ECB_press_conferences_tokens[1],
    K = 20,
    lexicon = LoughranMcDonald,
    alphaCycle = 1,
    gammaCycle = 1
  )

  expect_warning(
    model <- fit(model, 3, displayProgress = FALSE),
    "Invalid (alpha|gamma) hyperparameter update discarded"
  )
  expect_true(all(is.finite(model$alpha)))
  expect_true(all(model$alpha > 0))
  expect_true(all(is.finite(model$gamma)))
  expect_true(all(model$gamma > 0))
  expect_true(check_integrity(model, fast = FALSE))
})

rJST <- fit(rJST, 2, displayProgress = FALSE)

test_that("functions works", {
  expect_s3_class(top_words(rJST), "data.table")
  expect_true(is.matrix(top_words(rJST, output = "matrix")))
  expect_silent(p <- top_words(rJST, output = "plot"))
  expect_s3_class(p, "ggplot")
  expect_silent(print(p))
  expect_silent(m <- melt(rJST))
  expect_s3_class(m, "data.table")
  # expect_equal(ncol(m), 6)
  skip_if_not_installed("plotly")
  expect_silent(p <- plot(rJST))
  expect_s3_class(p, "plotly")
  expect_silent(print(p))
})

test_that("test convergence", {
  vocab <- generateVocab(
    nTopics = 3,
    nSentiments = 2,
    nWords = 3,
    nCommonWords = 1
  )
  toks <- generateDocuments(
    vocab,
    nDocs = 100,
    L1prior = .1,
    L2prior = 5,
    nWords = 100
  )
  lex <- generatePartialLexicon(toks, Sindex = 1:2)

  ## With lexicon
  retry <- 0
  convergence <- FALSE
  while (convergence == FALSE && retry < 5) {
    rJST <- rJST(toks, lex, K = 3, S = 2, alpha = .1)
    rJST <- fit(rJST, 100, nChains = 2, displayProgress = FALSE)
    count <- 0
    while (convergence == FALSE && count < 30) {
      rJST <- fit(rJST, 100, nChains = 2, displayProgress = FALSE)
      count <- count + 1
      if (all(distToGenerative(rJST, vocab) < .15)) convergence <- TRUE
    }
    retry <- retry + 1
  }
  sapply(distToGenerative(rJST, vocab), expect_lte, .15)

  ## No lexicon
  retry <- 0
  convergence <- FALSE
  while (convergence == FALSE && retry < 20) {
    rJST <- rJST(toks, K = 3, S = 2, alpha = .1)
    rJST <- fit(rJST, 100, nChains = 2, displayProgress = FALSE)
    expect_message(
      distToGenerative(rJST, vocab),
      "No lexicon detected, allowing"
    )
    count <- 0
    while (convergence == FALSE && count < 30) {
      rJST <- fit(rJST, 100, nChains = 2, displayProgress = FALSE)
      count <- count + 1
      if (all(suppressMessages(distToGenerative(rJST, vocab)) < .15)) {
        convergence <- TRUE
      }
    }
    retry <- retry + 1
  }
  sapply(suppressMessages(distToGenerative(rJST, vocab)), expect_lte, .15)
})

test_that("from LDA works", {
  toks <- ECB_press_conferences_tokens[1:10]
  LDA <- fit(LDA(toks), 10, displayProgress = FALSE)
  rJST <- rJST(LDA, lexicon = LoughranMcDonald)

  expect_identical(LDA$theta, rJST$theta)
  expect_equal(
    unlist(LDA$za, use.names = FALSE),
    (unlist(rJST$za, use.names = FALSE) - 1) %/% rJST$S + 1
  )
  expect_identical(LDA$it, rJST$it)
  expect_identical(LDA$logLikelihood, rJST$logLikelihood)
})