tests/testthat/test-CMDist-e-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"
    ))
})