R/test-rect-methods.R

In autotest: Automatic Package Testing

# S3 dispatch methods for autotest_rectangular class objects.

autotest_rectangular <- function (x = NULL, test_data = NULL, ...) {
    UseMethod ("autotest_rectangular", x)
}

#' @exportS3Method
autotest_rectangular.NULL <- function (x = NULL, ...) { # nolint

    env <- pkgload::ns_env ("autotest")
    all_names <- ls (env, all.names = TRUE)
    tests <- all_names [grep ("^test\\_", all_names)]
    tests <- tests [which (!grepl ("^.*\\.(default|NULL)$", tests))]

    tests <- grep ("^test\\_rect\\_", tests, value = TRUE)
    tests <- unique (gsub ("\\..*$", "", tests))

    res <- lapply (tests, function (i) {
        do.call (paste0 (i, ".NULL"), list (NULL))
    })

    return (do.call (rbind, res))
}

#' @exportS3Method
autotest_rectangular.autotest_obj <- function (x, test_data = NULL, ...) { # nolint

    ret <- NULL

    x$classes <- x$classes [which (!is.na (x$classes))]

    rect_index <- which (x$param_types == "tabular")

    for (r in rect_index) {

        x$i <- r

        x$class <- NULL
        if (names (x$params) [r] %in% names (x$classes)) {

            x$class <- x$classes [[match (
                names (x$params) [r],
                names (x$classes)
            )]]
            # then only proceed if class is not explicitly restricted:
            if (!x$class %in% c ("data.table", "tbl_df", "data.table")) {
                next
            }
        }

        ret <- rbind (ret, test_rect_as_other (x, test_data))

        ret <- rbind (ret, test_rect_compare_outputs (x, test_data))

        # Modify class definitions for rectangular inputs if not excluded by
        # an explicit class restriction
        if (!names (x$params) [r] %in% names (x$classes)) {
            ret <- rbind (ret, test_rect_extend_class (x, test_data))

            ret <- rbind (ret, test_rect_replace_class (x, test_data))
        }
    }
    return (ret)
}


test_rect_as_other <- function (x = NULL, test_data = NULL, ...) {
    UseMethod ("test_rect_as_other", x)
}

#' @exportS3Method
test_rect_as_other.NULL <- function (x = NULL, ...) {

    report_object (
        type = "dummy",
        test_name = "rect_as_other",
        parameter_type = "rectangular",
        operation = "Convert one rectangular class to another",
        content = "check for error/warning messages"
    )
}


#' @exportS3Method
test_rect_as_other.autotest_obj <- function (x, test_data = NULL, ...) { # nolint

    ret <- NULL

    these_tests <- test_rect_as_other.NULL ()
    this_op <- these_tests$operation

    if (is.null (test_data)) {
        these_tests$fn_name <- x$fn
        these_tests$parameter <- names (x$params) [x$i]
    } else {
        these_tests <- test_data [test_data$operation == this_op, ]
    }

    ret <- these_tests [which (!these_tests$test), ]
    if (nrow (ret) == 0) {
        ret <- NULL
    }
    these_tests <- these_tests [which (these_tests$test), ]

    if (x$test) {
        this_ret <- pass_rect_as_other (x, these_tests)
    } else {
        this_ret <- dummy_rect_as_other (x, these_tests)
    }

    return (rbind (ret, this_ret))
}

test_rect_compare_outputs <- function (x = NULL, test_data = NULL, ...) {
    UseMethod ("test_rect_compare_outputs", x)
}

#' test_rect_compare_outputs
#'
#' The `NULL` method here is different to most others in that it comprises three
#' distinct tests, rather than the usual single test. This is because the
#' comparisons are themselves between multiple objects, with each pairwise
#' comparison of types of objects subject to each of these three tests. The
#' whole thing is therefore easier to construct by having the three primary
#' tests listed within the following initial `NULL` method.
#'
#' @noRd
#' @exportS3Method
test_rect_compare_outputs.NULL <- function (x = NULL, ...) {

    report_object (
        type = "dummy",
        test_name = c (
            "rect_compare_dims",
            "rect_compare_col_names",
            "rect_compare_col_structure"
        ),
        parameter_type = "rectangular",
        operation = "Convert one rectangular class to another",
        content = c (
            "expect dimensions are same ",
            "expect column names are retained ",
            "expect all columns retain identical structure "
        )
    )
}

#' @exportS3Method
test_rect_compare_outputs.autotest_obj <- function (x, test_data = NULL, ...) { # nolint

    if (x$test) {
        ret <- compare_rect_outputs (x, test_data)
    } else {
        ret <- dummy_compare_rect_outputs (x, test_data)
    }

    return (ret)
}

#' Extend class structure of tabular objects, which should still work
#' @noRd
test_rect_extend_class <- function (x = NULL, test_data = NULL, ...) {
    UseMethod ("test_rect_extend_class", x)
}

#' @exportS3Method
test_rect_extend_class.NULL <- function (x = NULL, ...) {

    report_object (
        type = "dummy",
        test_name = "extend_rect_class",
        parameter_type = "rectangular",
        operation = "Extend existent class with new class",
        content = "(Should yield same result)"
    )
}

#' @exportS3Method
test_rect_extend_class.autotest_obj <- function (x, test_data = NULL, ...) { # nolint

    if (x$test) {
        res <- do_extend_rect_class_struct (x)
    } else {
        res <- dummy_extend_rect_class (x)
    }

    return (res)
}

#' Replacing class structure of tabular objects entirely should generally fail
#' @noRd
test_rect_replace_class <- function (x = NULL, test_data = NULL, ...) {
    UseMethod ("test_rect_replace_class", x)
}

#' @exportS3Method
test_rect_replace_class.NULL <- function (x = NULL, ...) { # nolint

    report_object (
        type = "dummy",
        test_name = "replace_rect_class",
        parameter_type = "rectangular",
        operation = "Replace class with new class",
        content = "(Should yield same result)"
    )
}

#' @exportS3Method
test_rect_replace_class.autotest_obj <- function (x, test_data = NULL, ...) { # nolint

    ret <- test_rect_replace_class.NULL ()

    ret$fn_name <- x$fn
    ret$parameter <- names (x$params) [x$i]
    this_class <- class (x$params [[x$i]]) [1]
    ret$parameter_type <- this_class
    ret$operation <- paste0 ("Replace class [", this_class, "] with new class")

    if (x$test) {

        p <- x$params [[x$i]]
        x$params [[x$i]] <- structure (p, class = "newclass")
        f <- tempfile (fileext = ".txt")
        msgs <- catch_all_msgs (f, x$fn, x$params)

        if (null_or_not (msgs, "error")) {
            msgs$parameter <- rep (names (x$params) [x$i], nrow (msgs))
            ret$type <- "diagnostic"
            ret$content <- paste0 (
                "Function [",
                x$fn,
                "] does not error when class structure of [",
                this_class, "] is removed."
            )
        } else {
            ret <- NULL
        }
    }

    return (ret)

}