tests/testthat/test-CMDist-sensitivity.R

In text2map: R Tools for Text Matrices, Embeddings, and Networks

test_that("sens_interval = TRUE works", {


    ## works with cw
    out.sens <- CMDist(dtm=dtm.dgc,
                      cw = cw,
                      cv = NULL,
                      wv = fake_word_vectors,
                      sens_interval = TRUE,
                      alpha = 1,
                      n_iters = 10L,
                      missing = "remove")


    expect_s3_class(out.sens, "data.frame")
    expect_type(out.sens[,2], "double")
    expect_identical(out.sens$doc_id, rownames(dtm.dgc))
    expect_identical(ncol(out.sens), 4L)
    expect_identical(colnames(out.sens), c("doc_id",
                                          "choose",
                                          "choose_upper",
                                          "choose_lower"))

    ## works with multiple cw
    out.sens <- CMDist(dtm=dtm.dgc,
                      cw = cw.2,
                      cv = NULL,
                      wv = fake_word_vectors,
                      sens_interval = TRUE,
                      alpha = 1,
                      n_iters = 10L,
                      missing = "remove")

    expect_s3_class(out.sens, "data.frame")
    expect_type(out.sens[,2], "double")
    expect_identical(out.sens$doc_id, rownames(dtm.dgc))
    expect_identical(ncol(out.sens), 7L)
    expect_identical(colnames(out.sens), c("doc_id",
                                          "choose",
                                          "choose_upper",
                                          "choose_lower",
                                          "decade",
                                          "decade_upper",
                                          "decade_lower"))

    ## works with multiple cw and cv
    out.sens <- CMDist(dtm=dtm.dgc,
                      cw = cw.2,
                      cv = sd.01,
                      wv = fake_word_vectors,
                      sens_interval = TRUE,
                      alpha = 1,
                      n_iters = 10L,
                      missing = "remove")

    expect_s3_class(out.sens, "data.frame")
    expect_type(out.sens[,2], "double")
    expect_identical(out.sens$doc_id, rownames(dtm.dgc))
    expect_identical(ncol(out.sens), 10L)
    expect_identical(colnames(out.sens), c("doc_id",
                                          "choose",
                                          "choose_upper",
                                          "choose_lower",
                                          "decade",
                                          "decade_upper",
                                          "decade_lower",
                                          "rich_pole",
                                          "rich_pole_upper",
                                          "rich_pole_lower"))

})

test_that("check internal .get_sensitivity_intervals()", {

    ## prep for test
    prep <- .prep_cmd_INPUT(dtm=dtm.dgc,
                           cw = cw,
                           cv = NULL,
                           wv = fake_word_vectors,
                           missing = "stop")

    fullDist <- text2vec::RWMD$new(prep$DTM, prep$wem)$sim2(prep$pDTM)
    fullDist <- t(fullDist[seq_len(prep$n_pd), , drop = FALSE])

    sampList <- lapply(seq_len(10L), function(x) {
        sampDTM <- dtm_resampler(prep$DTM, alpha = 1L)
        sampDist <- text2vec::RWMD$new(sampDTM, prep$wem)$sim2(prep$pDTM)
        sampDist <- t(sampDist[seq_len(prep$n_pd), , drop = FALSE])
        return(sampDist)
        })

    # actual test
    out.sen <- .get_sensitivity_intervals(sampList,
                               fullDist,
                               prep,
                               probs = c(0.025, 0.975),
                               type = 7,
                               scale = FALSE)

    #expect_s3_class(out.sen, "data.frame")
    expect_type(out.sen[,2], "double")
    expect_identical(out.sen$doc_id, rownames(dtm.dgc))
    expect_identical(ncol(out.sen), 4L)
    expect_identical(colnames(out.sen), c("doc_id",
                                          "choose",
                                          "choose_upper",
                                          "choose_lower"))


    ## prep for test with multiple cws ----------------------------------------
    prep <- .prep_cmd_INPUT(dtm=dtm.dgc,
                            cw = cw.2,
                            cv = NULL,
                            wv = fake_word_vectors,
                            missing = "stop")

    fullDist <- text2vec::RWMD$new(prep$DTM, prep$wem)$sim2(prep$pDTM)
    fullDist <- t(fullDist[seq_len(prep$n_pd), , drop = FALSE])

    sampList <- lapply(seq_len(10L), function(x) {
        sampDTM <- dtm_resampler(prep$DTM, alpha = 1L)
        sampDist <- text2vec::RWMD$new(sampDTM, prep$wem)$sim2(prep$pDTM)
        sampDist <- t(sampDist[seq_len(prep$n_pd), , drop = FALSE])
        return(sampDist)
    })

    # actual test
    out.sen <- .get_sensitivity_intervals(sampList,
                                          fullDist,
                                          prep,
                                          probs = c(0.025, 0.975),
                                          type = 7,
                                          scale = FALSE)

    expect_s3_class(out.sen, "data.frame")
    expect_type(out.sen[,2], "double")
    expect_identical(out.sen$doc_id, rownames(dtm.dgc))
    expect_identical(ncol(out.sen), 7L)
    expect_identical(colnames(out.sen), c("doc_id",
                                          "choose",
                                          "choose_upper",
                                          "choose_lower",
                                          "decade",
                                          "decade_upper",
                                          "decade_lower"))

})