require(quanteda) dict_newsmap <- dictionary(file = "../data/dictionary.yml") toks_test <- tokens(data_corpus_inaugural, remove_punct = TRUE) dfmt_test <- dfm(toks_test) %>% dfm_remove(stopwords("en")) toks_dict_test <- tokens_lookup(toks_test, dict_newsmap, level = 3) dfmt_dict_test <- dfm(toks_dict_test) test_that("textmodel_wordmap() works with different inputs", { toks <- tokens(data_corpus_inaugural, remove_punct = TRUE) %>% tokens_remove(stopwords()) dfmt <- dfm(toks) dfmt$Party <- factor(dfmt$Party) smat <- xtabs( ~ docid(dfmt) + dfmt$Party, sparse = TRUE) map1 <- textmodel_wordmap(dfmt, smat) expect_identical(map1$data, dfmt) expect_equal(names(coef(map1)), levels(dfmt$Party)) expect_null(map1$weight) mat <- as.matrix(smat) map2 <- textmodel_wordmap(dfmt, mat) expect_identical(map2$data, dfmt) expect_equal(names(coef(map2)), levels(dfmt$Party)) expect_null(map2$weight) map3 <- textmodel_wordmap(dfmt, mat, boolean = TRUE) expect_identical(map3$data, dfmt) expect_equal(names(coef(map3)), levels(dfmt$Party)) expect_false(identical(coef(map1), coef(map3))) expect_error(textmodel_wordmap(list(), smat)) expect_error(textmodel_wordmap(dfmt, list())) expect_error(textmodel_wordmap(dfmt, NULL)) expect_warning(textmodel_wordmap(dfmt, mat, aaa = 10), "aaa argument is not used") # use entropy weighting map_loc <- textmodel_wordmap(dfmt, mat, entropy = "local") expect_identical(dim(map_loc$weight), dim(map_loc$model)) expect_false(all(map_loc$weight[1,] == map_loc$weight[2,])) expect_equal(coef(map_loc, 10)[[1]], head(sort(map_loc$weight[1,] * map_loc$model[1,], decreasing = TRUE), 10)) map_avg <- textmodel_wordmap(dfmt, mat, entropy = "average") expect_identical(dim(map_avg$weight), dim(map_avg$model)) expect_true(all(map_avg$weight[1,] == map_avg$weight[2,])) expect_equal(coef(map_avg, 10)[[1]], head(sort(map_avg$weight[1,] * map_avg$model[1,], decreasing = TRUE), 10)) map_glo <- textmodel_wordmap(dfmt, mat, entropy = "global") expect_identical(dim(map_glo$weight), dim(map_glo$model)) expect_true(all(map_glo$weight[1,] == map_glo$weight[2,])) expect_equal(coef(map_glo, 10)[[1]], head(sort(map_glo$weight[1,] * map_glo$model[1,], decreasing = TRUE), 10)) expect_false(all(map_glo$weight[1,] == map_loc$weight[1,])) expect_false(all(map_loc$weight[1,] == map_avg$weight[1,])) expect_false(all(map_avg$weight[1,] == map_glo$weight[1,])) expect_error( textmodel_wordmap(dfmt, smat, smooth = -1), "The value of smooth must be between 0 and Inf" ) expect_error( textmodel_wordmap(dfmt, smat, smooth = c(1, 2)), "The length of smooth must be 1" ) expect_error( textmodel_wordmap(dfmt, smat, boolean = "yes"), "The value of boolean cannot be NA" ) expect_error( textmodel_wordmap(dfmt, smat, drop_label = "no"), "The value of drop_label cannot be NA" ) }) test_that("methods for textmodel_wordmap works correctly", { txt <- c("Ireland is famous for Guinness.", "Guinness began retailing in India in 2007.", "Cork is an Irish coastal city.", "Titanic departed Cork Harbour in 1912.") toks <- tokens(txt) label_toks <- tokens_lookup(toks, dict_newsmap, levels = 3) label_dfm <- dfm(label_toks) feat_dfm <- dfm(toks, tolower = FALSE) %>% dfm_select('^[A-Z][A-Za-z1-2]+', selection = "keep", valuetype = 'regex', case_insensitive = FALSE) map <- textmodel_wordmap(feat_dfm, label_dfm) expect_equal( names(map), c("model", "entropy", "data", "weight", "feature", "concatenator", "call", "version") ) # class association is calculated correctly # note: both Guinness and Cork occur in IE only once expect_equivalent(map$model['ie', c('Ireland', 'Guinness')], map$model['ie', c('Irish', 'Cork')] ) expect_identical(map$feature, featnames(feat_dfm)) # rank argument is working expect_equal(unname(predict(map)), factor(c("ie", "in", "ie", "ie"), levels = c("in", "ie"))) expect_equal(unname(predict(map, rank = 2)), factor(c("in", "ie", "in", "in"), levels = c("in", "ie"))) expect_error(predict(map, rank = 0)) # different prediction outputs agree pred_top <- predict(map, confidence = TRUE) pred_all <- predict(map, type = 'all') expect_equivalent(pred_top$confidence.fit, apply(pred_all, 1, max)) expect_equivalent(pred_top$confidence.fit[1], pred_top$confidence.fit[3]) expect_warning( predict(map, confidence.fit = TRUE), "'confidence.fit' is deprecated; use 'confidence'" ) expect_output( textmodel_wordmap(feat_dfm, label_dfm, verbose = TRUE), 'Fitting textmodel_wordmap.*label = "ie".* label = "in"' ) # print expect_output( print(map), paste0('(\n)', 'Call:(\n)', 'textmodel_wordmap\\(.*\\)(\n)') ) expect_output( print(summary(map)), paste0('(\n)', 'Call:(\n)', 'textmodel_wordmap\\(.*\\)(\n)', '\n', 'Labels:(\n)', '\\[1\\] "in" "ie"(\n)', '(\n)', 'Data Dimension:(\n)', '\\[1\\] 4 7(\n)') ) }) test_that("textmodel_wordmap() raises error if dfm is empty", { dfmt1 <- dfm(tokens("a b c")) dfmt2 <- dfm(tokens("A")) expect_error(textmodel_wordmap(dfm_trim(dfmt1, min_termfreq = 10), dfmt2), "x must have at least one non-zero feature") expect_error(textmodel_wordmap(dfmt1, dfm_trim(dfmt2, min_termfreq = 10)), "y must have at least one non-zero feature") }) test_that("label and drop_label are working", { txt <- c("American and Japanese leaders met in Tokyo.", "Paris Hilton visited British museum in London.", "India and Pakistan are neighbours.", "A man went to the Moon.") toks <- tokens(txt) toks_label <- tokens_lookup(toks, dict_newsmap, levels = 3) dfmt <- dfm(toks) dfmt_label <- dfm(toks_label) map1 <- textmodel_wordmap(dfmt, dfmt_label) expect_equal(names(coef(map1)), c("us", "jp", "in", "pk", "gb", "fr")) map2 <- textmodel_wordmap(dfmt, dfmt_label, label = "max") expect_equal(names(coef(map2)), c("jp", "in", "pk", "gb")) map3 <- textmodel_wordmap(dfmt, dfmt_label, drop_label = FALSE) expect_equal(names(coef(map3)), colnames(dfmt_label)) }) test_that("accuracy() is correct", { v1 <- c("c", NA, "b", "a", "b", "c", "b", "b", "a", "c") v2 <- c("c", "b", "a", "a", "b", "c", "b", "b", "a", "c") accu <- accuracy(v1, v2) expect_equal(accu$tp, c(2, 3, 3)) expect_equal(accu$fp, c(0, 1, 0)) expect_equal(accu$tn, c(6, 5, 6)) expect_equal(accu$fn, c(1, 0, 0)) expect_identical( accu, accuracy(rev(v1), rev(v2)) ) }) test_that("afe() is working", { txt <- c("American and Japanese leaders met in Tokyo.", "Paris Hilton visited British museum in London.", "India and Pakistan are neighbours.", "A man went to the Moon.") toks <- tokens(txt) toks_label <- tokens_lookup(toks, dict_newsmap, levels = 3) dfmt <- dfm(toks) dfmt_label <- dfm(toks_label) expect_equal(afe(dfmt, dfmt_label), 7.90, tolerance = 0.1) expect_error(afe(dfmt, matrix())) expect_error(afe(list(), dfmt_label)) }) test_that("coef() and dictionary() are working", { dfmt <- dfm_trim(dfmt_test, min_termfreq = 100) dfmt_dict <- dfm_trim(dfmt_dict_test, min_termfreq = 2) map <- textmodel_wordmap(dfmt, dfmt_dict) expect_true(all(lengths(coef(map, n = 5)) == 5)) expect_identical(coef(map)[c("us")], coef(map, select = c("us"))) expect_identical(coef(map)[c("us", "ru", "gb")], coef(map, select = c("us", "gb", "ru"))) expect_identical(coef(map, select = c("ru", "gb", "us")), coef(map, select = c("us", "gb", "ru"))) expect_error(coef(map, n = -1), "The value of n must be between 0 and Inf") expect_error(coef(map, select = "xx"), "Selected class must be in the model") expect_error(coef(map, select = character()), "The length of select must be between 1 and 16") # TODO: remove as.list() lis1 <- as.list(map) expect_equal(length(lis1), 16) expect_true(all(sapply(lis1, is.character))) expect_true(all(lengths(as.list(lis1)) == 10)) lis2 <- as.list(map, n = 20, c("ru", "fr")) expect_equal(names(lis2), c("ru", "fr")) expect_true(all(sapply(lis2, is.character))) expect_true(all(lengths(lis2) == 20)) # TODO: change to as.dictionary() dict1 <- as.dictionary(map) expect_s4_class(dict1, "dictionary2") expect_true(all(lengths(as.list(dict1)) == 10)) expect_equal(dict1@meta$object$separator, "_") dict2 <- as.dictionary(map, n = 20, select = c("ru", "fr")) expect_s4_class(dict2, "dictionary2") expect_equal(names(dict2), c("ru", "fr")) expect_true(all(lengths(dict2) == 20)) dict3 <- as.dictionary(map, separator = "+") expect_s4_class(dict3, "dictionary2") expect_equal(dict3@meta$object$separator, "+") })