R/test-return-object.R

In autotest: Automatic Package Testing

#' Check (1) whether return values are documented at all; and (2) If so, whether
#' they describe the class or type of return object. The latter is currently
#' only crudely tested with a simple `grep([[Cc]lass|[Oo]bject)`.
#' @noRd
autotest_return <- function (x = NULL, ...) {
    UseMethod ("autotest_return", x)
}

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

    # The NULL dispatch here is different from all others, because no parameters
    # are actually tested, so results are identical to test = F, and can be
    # triggered with a dummy `autotest_obj`:
    x <- autotest_obj (
        package = "",
        parameters = list (),
        parameter_types = list (),
        fn_name = "",
        classes = NULL,
        test = FALSE
    )

    rbind (
        test_return_success (),
        test_return_is_described (),
        test_return_has_class (),
        test_return_primary_val_matches_desc ()
    )
}

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

    rbind (
        test_return_success (x, test_data),
        test_return_is_described (x, test_data),
        test_return_has_class (x, test_data),
        test_return_primary_val_matches_desc (x, test_data)
    )
}

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

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

    op <- "Check that function successfully returns an object"
    report_object (
        type = "dummy",
        test_name = "return_successful",
        parameter_type = "(return object)",
        parameter = "(return object)",
        operation = op
    )
}


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

    ret <- test_return_success.NULL ()
    ret$fn_name <- x$fn

    if (!is.null (test_data)) {
        test_flag <- test_these_data (test_data, ret)
        if (length (test_flag) == 1L) {
            x$test <- test_flag
        }
        if (!x$test) {
            ret$type <- "no_test"
        }
    }

    if (x$test) {

        # pkgs with examples for internal fns have to have their namespace
        # (re-)loaded which prompts a warning via memoise
        retobj <- suppressWarnings (m_capture_return_object (x))

        if (methods::is (retobj, "error")) {
            ret$type <- "error"
            ret$operation <- "error from normal operation"
            ret$content <- retobj$message
        } else {
            ret <- NULL
        }
    }

    return (ret)
}

capture_return_object <- function (x) {

    ret <- NULL
    f <- tempfile (fileext = ".txt")

    if (any (x$params == "NULL")) {
        x$params <- x$params [x$params != "NULL"]
    }

    msgs <- catch_all_msgs (f, x$fn, x$params)
    ret <- add_msg_output (ret, msgs,
        types = "warning",
        operation = "normal function call"
    )

    # assignment must stay nested here: 'capture.output()' returns the
    # printed text, not the value of its expression, so this is the only
    # way to capture both in one call.
    o <- suppressMessages (
        utils::capture.output (
            retobj <- with_null_device ( # nolint
                tryCatch (do.call (x$fn, x$params, quote = TRUE),
                    warning = function (w) w,
                    error = function (e) e
                )
            )
        )
    )

    return (retobj)
}
m_capture_return_object <- memoise::memoise (capture_return_object)

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

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

    report_object (
        type = "dummy",
        test_name = "return_val_described",
        parameter = "(return object)",
        parameter_type = "(return object)",
        operation = "Check that description has return value"
    )
}

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

    ret <- test_return_is_described.NULL ()
    ret$fn_name <- x$fn

    if (!is.null (test_data)) {
        test_flag <- test_these_data (test_data, ret)
        if (length (test_flag) == 1L) {
            x$test <- test_flag
        }
        if (!x$test) {
            ret$type <- "no_test"
        }
    }

    if (x$test) {

        aliases <- m_fns_to_topics (package = x$package_loc)
        rdname <- gsub ("\\.Rd$", "", aliases$name [aliases$alias == x$fn])
        Rd_value <- get_Rd_value (package = x$package_loc, fn_name = rdname) # nolint

        if (is.null (Rd_value)) {
            ret$type <- "diagnostic"
            ret$content <- paste0 (
                "Function [",
                x$fn,
                "] does not specify a return value."
            )
        } else {
            ret <- NULL
        }
    }

    return (ret)
}

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

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

    op <- "Check whether description of return value specifies class"
    report_object (
        type = "dummy",
        test_name = "return_desc_includes_class",
        parameter = "(return object)",
        parameter_type = "(return object)",
        operation = op
    )
}

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

    ret <- test_return_has_class.NULL ()
    ret$fn_name <- x$fn

    if (!is.null (test_data)) {
        test_flag <- test_these_data (test_data, ret)
        if (length (test_flag) == 1L) {
            x$test <- test_flag
        }
        if (!x$test) {
            ret$type <- "no_test"
        }
    }

    if (x$test) {

        aliases <- m_fns_to_topics (package = x$package_loc)
        rdname <- gsub ("\\.Rd$", "", aliases$name [aliases$alias == x$fn])
        Rd_value <- get_Rd_value (package = x$package_loc, fn_name = rdname) # nolint

        if (is.null (Rd_value)) {

            ret$type <- "diagnostic"
            ret$content <- paste0 (
                "Function [",
                x$fn,
                "] does not describe return value"
            )
        } else {

            # pkgs with examples for internal fns have to have their namespace
            # (re-)loaded which prompts a warning via memoise
            retobj <- suppressWarnings (m_capture_return_object (x))

            cl <- attr (retobj, "class")
            okay <- TRUE
            if (!is.null (cl)) {
                okay <- vapply (
                    cl, function (i) {
                        any (grepl (i, Rd_value))
                    },
                    logical (1)
                )
            }

            if (any (okay)) { # one okay means all okay
                ret <- NULL
            } else {
                ret$type <- "diagnostic"
                ret$content <- paste0 (
                    "Function [",
                    x$fn,
                    "] returns a value of class [",
                    toString (attr (retobj, "class")),
                    "], which differs from the value ",
                    "provided in the description"
                )
            }
        }
    }

    return (ret)
}

test_return_primary_val_matches_desc <- function (x = NULL, ...) { # nolint
    UseMethod ("test_return_primary_val_matches_desc", x)
}

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

    op <- "Compare class of return value with description"
    report_object (
        type = "dummy",
        test_name = "return_class_matches_desc",
        parameter = "(return object)",
        parameter_type = "(return object)",
        operation = op
    )
}

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

    ret <- test_return_primary_val_matches_desc.NULL ()
    ret$fn_name <- x$fn

    if (!is.null (test_data)) {
        test_flag <- test_these_data (test_data, ret)
        if (length (test_flag) == 1L) {
            x$test <- test_flag
        }
        if (!x$test) {
            ret$type <- "no_test"
        }
    }

    if (x$test) {

        aliases <- m_fns_to_topics (package = x$package_loc)
        rdname <- gsub ("\\.Rd$", "", aliases$name [aliases$alias == x$fn])
        Rd_value <- get_Rd_value (package = x$package_loc, fn_name = rdname) # nolint

        if (is.null (Rd_value)) {

            ret$type <- "diagnostic"
            ret$content <- paste0 (
                "Function [",
                x$fn,
                "] does not describe return value"
            )
        } else {

            # pkgs with examples for internal fns have to have their namespace
            # (re-)loaded which prompts a warning via memoise
            retobj <- suppressWarnings (m_capture_return_object (x))

            chk <- TRUE
            if (!is.null (attr (retobj, "class"))) {
                chk <- vapply (
                    attr (retobj, "class"), function (i) {
                        any (grepl (i, Rd_value))
                    },
                    logical (1)
                )
            }

            if (any (chk)) {
                ret <- NULL
            } else {

                txt <- compare_return_classes (Rd_value, retobj)

                if (!is.null (txt)) {
                    ret$type <- "diagnostic"
                    ret_tmp <- NULL
                    for (i in txt) {
                        ret$content <- i
                        ret_tmp <- rbind (ret_tmp, ret)
                    }
                    ret <- ret_tmp
                } else {
                    ret <- NULL
                }
            }
        }
    } # end if x$test

    return (ret)
}

compare_return_classes <- function (Rd_value, retval) { # nolint

    txt <- NULL
    # Get class of returned object, along with matched value from man
    # entry
    retclasses <- attr (retval, "class")
    r <- gregexpr (paste (retclasses, collapse = "|"), Rd_value)
    i <- vapply (r, function (i) i [1] > 0, logical (1))

    if (any (i)) {

        # can be multiple return classes, so match the first one from
        # descr with the returned object
        r_i <- r [which (i)]
        rd_i <- Rd_value [which (i)]
        desc_classes <- lapply (seq_along (which (i)), function (j) {
            pos1 <- as.integer (r_i [[j]])
            pos2 <- as.integer (r_i [[j]] +
                attr (
                    r_i [[j]],
                    "match.length"
                ) - 1)
            substring (rd_i [j], pos1, pos2)     })
        desc_classes <- unique (unlist (desc_classes))

        actual_class <- retclasses [which (retclasses %in% desc_classes)]

        if (length (actual_class) > 0 & actual_class [1] != retclasses [1]) {
            txt <- paste0 (
                "Function returns an object of primary class [",
                retclasses [1],
                "] yet documentation says value is of class [",
                toString (desc_classes),
                "]"
            )
        }

    } else {

        retclasses_mod <- gsub ("\\_|\\.", "", retclasses)
        r <- gregexpr (paste (retclasses_mod, collapse = "|"), Rd_value)
        i <- vapply (r, function (i) i [1] > 0, logical (1))

        if (any (i)) {

            r_i <- r [[which (i)]]
            desc_class <- substring (Rd_value [i], r_i, nchar (Rd_value [i]))
            if (grepl ("\\s", desc_class)) {
                desc_class <- substring (
                    desc_class, 1,
                    regexpr ("\\s+", desc_class) - 1
                )
            }
            actual_class <- retclasses [which (retclasses_mod == desc_class)]

            txt <- paste0 (
                "Function returns an object of class [",
                actual_class,
                "] yet documentation describes class of value as [",
                desc_class,
                "]"
            )

            if (actual_class != retclasses [1]) {
                txt <- c (txt, paste0 (
                    "Function returns an object of ",
                    "primary class [",
                    retclasses [1],
                    "] yet documentation says value ",
                    "is of class [",
                    desc_class,
                    "]"
                ))
            }
        }
    }

    return (txt)
}