tests/testthat/test_code_writing.R

In iNZightVIT/iNZight: A GUI for Data Exploration and Visualisation

context("Code writing")

skip_on_cran()

# load_all("../iNZightPlots")

msg <- function(x, type = 1L) {
    Sys.sleep(0.5)
    x <- sprintf(
        "\n %s %s %s\n",
        switch(type,
            "++++++++++++",
            "--------",
            "-"
        ),
        x,
        switch(type,
            "++++++++++++",
            "",
            ""
        )
    )
    cat(x)
}

msg("Starting CODE WRITING test")

# try(ui$close()); load_all()
ui <- iNZGUI$new()
ui$initializeGui()
on.exit(gWidgets2::dispose(ui$win))
Sys.sleep(2)

msg("Data set code is applied", 2L)

test_that("Data set code is applied", {
    cas <- census.at.school.500
    attr(cas, "code") <- "read_csv('cas.csv')"
    ui$setDocument(iNZDocument$new(data = cas), reset = TRUE)
    Sys.sleep(2)

    expect_match(
        gsub("\\s\\s+", " ", paste(ui$rhistory$get(), collapse = " ")),
        "cas <- read_csv(\"cas.csv\")",
        fixed = TRUE
    )
})

# msg("magrittr library call is included", 2L)

# test_that("magrittr library call is included", {
#     expect_match(
#         gsub("\\s\\s+", " ", paste(ui$rhistory$get(), collapse = " ")),
#         "library(magrittr)",
#         fixed = TRUE
#     )
# })

msg("Plot code is generated correctly", 2L)
test_that("Plot code is generated correctly", {
    msg("height", 3L)
    svalue(ui$ctrlWidget$V1box) <- "height"
    expect_equal(
        attr(ui$curPlot, "code"),
        "inzplot(~height, data = cas)"
    )

    msg("height ~ travel", 3L)
    system("import -window root screen.jpeg")
    svalue(ui$ctrlWidget$V2box) <- "travel"
    msg("now checking the code ...", 3L)
    expect_equal(
        attr(ui$curPlot, "code"),
        "inzplot(height ~ travel, data = cas)"
    )

    msg("height ~ travel | gender", 3L)
    svalue(ui$ctrlWidget$G1box) <- "gender"
    expect_equal(
        attr(ui$curPlot, "code"),
        "inzplot(height ~ travel | gender, data = cas)"
    )

    msg("height ~ travel | gender + age", 3L)
    svalue(ui$ctrlWidget$G2box) <- "age"
    expect_equal(
        attr(ui$curPlot, "code"),
        "inzplot(height ~ travel | gender, data = cas)"
    )

    ui$ctrlWidget$ctrlGp$children[[1]][8L, 1L]$set_index(2L)
    expect_equal(
        attr(ui$curPlot, "code"),
        "inzplot(height ~ travel | gender + age, g2.level = \"[7 - 11]\", data = cas)"
    )

    msg("height ~ travel | gender + age[7 - 11]", 3L)
    svalue(ui$ctrlWidget$V2box, TRUE) <- 1L
    expect_equal(
        attr(ui$curPlot, "code"),
        "inzplot(~height | gender + age, g2.level = \"[7 - 11]\", data = cas)"
    )

    msg("height | age[7 - 11]", 3L)
    svalue(ui$ctrlWidget$G1box, TRUE) <- 1L
    expect_equal(
        attr(ui$curPlot, "code"),
        "inzplot(~height | age, data = cas, g1.level = \"[7 - 11]\")"
    )

    msg("height ...", 3L)
    ui$ctrlWidget$ctrlGp$children[[1]][8L, 1L]$set_index(1L)
    expect_equal(
        attr(ui$curPlot, "code"),
        "inzplot(~height, data = cas)"
    )

    msg("height | gender", 3L)
    svalue(ui$ctrlWidget$G2box, TRUE) <- 1L
    svalue(ui$ctrlWidget$G1box) <- "gender"
    expect_equal(
        attr(ui$curPlot, "code"),
        "inzplot(~height | gender, data = cas)"
    )
    svalue(ui$ctrlWidget$G1box, TRUE) <- 1L
})

msg("Plot code generated by add to plot - colour by", 2L)
test_that("Plot code generated by add to plot - colour by", {
    svalue(ui$ctrlWidget$V1box) <- "travel"
    expect_true(ui$plotToolbar$addToPlot(message = FALSE))

    # fill colour by gender
    tbl <- ui$moduleWindow$body$children[[1]]$children[[1]]
    wi <- which(
        sapply(
            seq_len(tbl$get_dim()[["nrow"]]),
            function(i) {
                z <- svalue(tbl[i, 1]) == "Colour by :"
                length(z) && z
            }
        )
    )
    ci <- which(
        sapply(tbl$child_positions, function(x) identical(x$child, tbl[wi, 3]))
    )
    colby <- tbl$children[[ci]]
    suppressWarnings(colby$set_value("gender"))
    expect_equal(as.character(ui$getActiveDoc()$getSettings()$colby), "gender")
    expect_equal(ui$getActiveDoc()$getSettings()$col.fun, "contrast")

    expect_equal(
        attr(ui$curPlot, "code"),
        "inzplot(~travel, colby = gender, data = cas, col.fun = \"contrast\")"
    )

    colby$set_index(1L)
    ui$moduleWindow$footer$children[[2]]$invoke_change_handler()

    svalue(ui$ctrlWidget$V1box) <- "height"
    svalue(ui$ctrlWidget$V2box) <- "armspan"
    expect_true(ui$plotToolbar$addToPlot(message = FALSE))

    tbl <- ui$moduleWindow$body$children[[1]]$children[[1]]
    wi <- which(
        sapply(
            seq_len(tbl$get_dim()[["nrow"]]),
            function(i) {
                z <- svalue(tbl[i, 1]) == "Colour by :"
                length(z) && z
            }
        )
    )
    ci <- which(
        sapply(tbl$child_positions, function(x) identical(x$child, tbl[wi, 3]))
    )
    colby <- tbl$children[[ci]]

    suppressWarnings(colby$set_value("gender"))
    expect_equal(as.character(ui$getActiveDoc()$getSettings()$colby), "gender")
    expect_equal(ui$getActiveDoc()$getSettings()$col.fun, "contrast")

    expect_equal(
        attr(ui$curPlot, "code"),
        "inzplot(height ~ armspan, colby = gender, data = cas, col.fun = \"contrast\")"
    )

    suppressWarnings(colby$set_value("age"))
    expect_equal(as.character(ui$getActiveDoc()$getSettings()$colby), "age")
    expect_equal(ui$getActiveDoc()$getSettings()$col.fun, "viridis")

    expect_equal(
        attr(ui$curPlot, "code"),
        "inzplot(height ~ armspan, colby = age, data = cas, col.fun = \"viridis\")"
    )

    ## Emphasize

    colby$set_index(1)
    ui$moduleWindow$footer$children[[2]]$invoke_change_handler()
})

# try(ui$close()); load_all()
# if (interactive()) {
#     ui <- iNZGUI$new()
#     ui$initializeGui(census.at.school.500)
#     on.exit(gWidgets2::dispose(ui$win))
#     Sys.sleep(2)
# }

msg("Plot code generated by add to plot - size by", 2L)
test_that("Plot code generated by add to plot - size by", {
    svalue(ui$ctrlWidget$V1box) <- "height"
    svalue(ui$ctrlWidget$V2box) <- "armspan"
    expect_true(ui$plotToolbar$addToPlot(message = FALSE))

    # fill colour by gender
    tbl <- ui$moduleWindow$body$children[[1]]$children[[1]]
    wi <- which(
        sapply(
            seq_len(tbl$get_dim()[["nrow"]]),
            function(i) {
                z <- svalue(tbl[i, 1]) == "Resize points by :"
                length(z) && z
            }
        )
    )
    ci <- which(
        sapply(tbl$child_positions, function(x) identical(x$child, tbl[wi, 3]))
    )
    sizeby <- tbl$children[[ci]]
    suppressWarnings(sizeby$set_value("age"))
    expect_equal(as.character(ui$getActiveDoc()$getSettings()$sizeby), "age")

    expect_equal(
        attr(ui$curPlot, "code"),
        "inzplot(height ~ armspan, sizeby = age, data = cas)"
    )

    # emphasize
    pri <- which(
        sapply(tbl$child_positions, function(x) identical(x$child, tbl[wi + 1, 3]))
    )
    prop <- tbl$children[[pri]]
    expect_equal(svalue(prop), "proportional")
    svalue(prop) <- "emphasize"
    expect_equal(
        attr(ui$curPlot, "code"),
        "inzplot(height ~ armspan, sizeby = age, data = cas, resize.method = \"emphasize\")"
    )

    expect_silent(svalue(sizeby, index = TRUE) <- 1)
    sizeby$set_index(1)
    expect_equal(
        attr(ui$curPlot, "code"),
        "inzplot(height ~ armspan, data = cas)"
    )

    ui$moduleWindow$footer$children[[2]]$invoke_change_handler()
})

msg("Plot ... - symbol by", 2L)
test_that("Plot code generated by add to plot - symbol by", {
    svalue(ui$ctrlWidget$V1box) <- "height"
    svalue(ui$ctrlWidget$V2box) <- "armspan"
    expect_true(ui$plotToolbar$addToPlot(message = FALSE))

    # fill colour by gender
    tbl <- ui$moduleWindow$body$children[[1]]$children[[1]]
    wi <- which(
        sapply(
            seq_len(tbl$get_dim()[["nrow"]]),
            function(i) {
                z <- svalue(tbl[i, 1]) == "Symbol by :"
                length(z) && z
            }
        )
    )
    ci <- which(
        sapply(tbl$child_positions, function(x) identical(x$child, tbl[wi, 3]))
    )
    symby <- tbl$children[[ci]]
    suppressWarnings(symby$set_value("gender"))
    expect_equal(as.character(ui$getActiveDoc()$getSettings()$symbolby), "gender")

    expect_equal(
        attr(ui$curPlot, "code"),
        "inzplot(height ~ armspan, symbolby = gender, data = cas)"
    )

    symby$set_index(1)
    expect_equal(
        attr(ui$curPlot, "code"),
        "inzplot(height ~ armspan, data = cas)"
    )

    ui$moduleWindow$footer$children[[2]]$invoke_change_handler()
})


msg("... cat x cat", 2L)
test_that("Plot code generated by add to plot - cat x cat", {
    svalue(ui$ctrlWidget$V1box) <- "travel"
    suppressWarnings(svalue(ui$ctrlWidget$V2box) <- "gender")
    expect_true(ui$plotToolbar$addToPlot(message = FALSE))

    # fill colour by gender
    tbl <- ui$moduleWindow$body$children[[1]]$children[[1]]
    wi <- which(
        sapply(
            seq_len(tbl$get_dim()[["nrow"]]),
            function(i) {
                z <- svalue(tbl[i, 1]) == "Colour palette : "
                length(z) && z
            }
        )
    )
    ci <- which(
        sapply(tbl$child_positions, function(x) identical(x$child, tbl[wi, 3]))
    )
    colpal <- tbl$children[[ci]]
    suppressWarnings(colpal$set_index(2L))
    expect_equal(as.character(ui$getActiveDoc()$getSettings()$col.fun), "bright")

    expect_equal(
        attr(ui$curPlot, "code"),
        "inzplot(travel ~ gender, data = cas, col.fun = \"bright\")"
    )

    suppressWarnings(colpal$set_index(1L))
    expect_equal(
        attr(ui$curPlot, "code"),
        "inzplot(travel ~ gender, data = cas, col.fun = \"contrast\")"
    )

    ui$moduleWindow$footer$children[[2]]$invoke_change_handler()
})

ui$close()

msg("Load survey", 2L)

data(api, package = "survey")
# load_all("../iNZightTools")
# try(ui$close(), TRUE); load_all()
ui <- iNZGUI$new()
ui$initializeGui(apiclus1)
on.exit(gWidgets2::dispose(ui$win))
Sys.sleep(2)

ui$getActiveDoc()$getModel()$setDesign(
    list(clus1 = "dnum", weights = "pw", fpc = "fpc", survey_type = "survey"),
    gui = ui
)

msg("Survey design code is valid", 2L)
test_that("Survey design code is valid", {
    svalue(ui$ctrlWidget$V1box) <- "enroll"
    expect_equal(ui$plotType, "hist")
    expect_equal(attr(ui$curPlot, "code"), "inzplot(~enroll, design = apiclus1.svy)")

    smry <- iNZGetSummary$new(ui)
    on.exit(gWidgets2::dispose(smry$win))
    expect_match(svalue(smry$code_box), "inzsummary(~enroll, design = apiclus1.svy)", fixed = TRUE)
    gWidgets2::dispose(smry$win)

    inf <- iNZGetInference$new(ui)
    on.exit(gWidgets2::dispose(inf$win))
    expect_match(
        svalue(inf$code_box),
        "inzinference(~enroll, design = apiclus1.svy, hypothesis = NULL)",
        fixed = TRUE
    )

    expect_silent(inf$hypothesis_test$set_index(2L))
    expect_silent(inf$hyp_null$set_value(500))
    expect_match(
        svalue(inf$code_box),
        "inzinference(~enroll, design = apiclus1.svy, hypothesis.value = 500)",
        fixed = TRUE
    )
})