R/namespace-processing.R

In autotest: Automatic Package Testing

get_package_name <- function (package) {
    pkg_name <- NULL

    if (pkg_is_source (package)) {
        desc <- fs::path (package, "DESCRIPTION")
        pkg_name <- as.character (read.dcf (desc, "Package"))
    } else {
        pkg_name <- fs::path_file (package)
    }

    return (pkg_name)
}

#' @param package Name of locally installed package or path to local source
#' @return List of all functions exported by nominated package excluding any
#' re-exports from other packages
#' @noRd
get_pkg_functions <- function (package) {

    pkg <- get_package_name (package)
    e <- as.environment (paste0 ("package:", get_package_name (pkg)))

    if (pkg_is_source (package)) {
        man_dir <- fs::dir_ls (fs::path (package, "man"),
            regexp = "\\.Rd$",
            fail = FALSE
        )
        fns <- suppressWarnings (
            lapply (man_dir, function (i) {
                get_Rd_metadata (tools::parse_Rd (i), "alias")
            })
        )
        fns <- unique (unlist (fns))
    } else {
        # package is dir to temp installed version in covr, so:
        package <- fs::path_file (package)
        fns <- ls (paste0 ("package:", package))
    }

    fn_classes <- vapply (
        fns, function (i) {

            out_obj <- tryCatch (get (i, envir = e),
                error = function (err) NA_character_
            )
            # fns in package namespace have 'srcref' as an attribute:
            if (is.null (attributes (out_obj))) {
                out_obj <- NULL
            } else {
                out_obj <- class (out_obj) [1]
            }

            out_fn <- tryCatch (class (utils::getFromNamespace (i, pkg)) [1],
                error = function (err) NA_character_
            )
            out <- unique (c (out_obj, out_fn))
            out <- out [which (!is.na (out))]
            if (length (out) > 1) {
                warning ("Object [", i, "] has multiple classes")
                out <- out [1]
            }
            if (length (out) == 0) {
                out <- NA_character_
            }
            return (out)   },
        character (1)
    )

    fns <- fns [grep ("[Ff]unction|standardGeneric", fn_classes)]

    other_fns <- fns_from_other_pkgs (package)

    return (fns [which (!fns %in% other_fns)])
}
m_get_pkg_functions <- memoise::memoise (get_pkg_functions)

#' @inheritParams get_pkg_functions
#' @note This function is really slow, but is only called one so no gain from
#' memoising.
#' @noRd
fns_without_examples <- function (package) {

    if (pkg_is_source (package)) {

        man_dir <- fs::dir_ls (fs::path (package, "man"),
            regexp = "\\.Rd$",
            fail = FALSE
        )
        ex_alias <- lapply (man_dir, function (i) {
            rd <- suppressWarnings (tools::parse_Rd (i))
            list (
                ex = get_Rd_metadata (rd, "examples"),
                aliases = get_Rd_metadata (rd, "alias")
            )
        })
    } else {

        if (fs::path_file (package) == package) {
            rd <- tools::Rd_db (package = package)
        } else {
            # packages installed into local tempdir via covr:
            rd <- tools::Rd_db (
                package = fs::path_file (package),
                dir = package
            )
        }
        ex_alias <- lapply (rd, function (i) {
            list (
                ex = get_Rd_metadata (i, "examples"),
                aliases = get_Rd_metadata (i, "alias")
            )
        })
    }

    # tools:::.Rd_get_metadata returned a character vector up to R4.0, with each
    # line as separate element; from R4.0 all lines are collapsed to a
    # single-value string.
    index <- which (vapply (
        ex_alias, function (i) {
            if (length (i$ex) > 1) {
                i$ex <- paste (i$ex, collapse = "\n")
            }
            res <- nchar (i$ex)
            if (length (res) == 0) {
                res <- 0L
            }
            return (res)    },
        integer (1)
    ) == 0)
    fns <- lapply (ex_alias [index], function (i) i$alias)
    fns <- unique (unlist (fns))

    fns <- fns [which (fns %in% m_get_pkg_functions (package))]

    return (fns)
}

fns_from_other_pkgs <- function (package) {

    if (pkg_is_source (package)) {

        fp <- fs::path (package)

    } else if (fs::path_file (package) != package) {

        fp <- package

    } else {

        fp <- pkg_lib_path (package, root = FALSE)

    }

    namespace_file <- fs::path (fp, "NAMESPACE")
    checkmate::assert_file_exists (namespace_file, .var.name = "NAMESPACE file")

    ns <- readLines (namespace_file)
    ns <- gsub (
        "importFrom\\(|\\)$", "",
        grep ("^importFrom", ns, value = TRUE)
    )
    fns <- vapply (
        ns, function (i) strsplit (i, split = ",", fixed = TRUE) [[1]] [2],
        character (1)
    )

    index <- grep ("\"", fns, fixed = TRUE)
    if (length (index) > 0) {
        fns_sub <- gsub ("\"", "", fns [index], fixed = TRUE)
        fns <- c (fns, fns_sub)
    }

    return (fns)
}

#' @param x A list of function aliases
#' @return `data.frame` of function aliases, official topics as defined in the
#' corresponding ".Rd" file, and associated names of the Rd files or database
#' entries.
#' @note If `is.null(x)`, the full list of topics and aliases are returned,
#' otherwise it is reduced to only topics assocaited with the aliases given in
#' `x`.
#' @noRd
fns_to_topics <- function (x = NULL, package) {
    if (pkg_is_source (package)) {
        man_dir <- fs::dir_ls (fs::path (package, "man"),
            regexp = "\\.Rd$",
            fail = FALSE
        )
        alias_topic <- lapply (man_dir, function (i) {
            rd <- suppressWarnings (tools::parse_Rd (i))
            alias <- get_Rd_metadata (rd, "alias")
            topic <- get_Rd_metadata (rd, "name")
            name <- fs::path_file (i)
            cbind (
                alias,
                rep (topic, length (alias)),
                rep (name, length (alias))
            )
        })
    } else {
        if (fs::path_file (package) == package) {
            rd <- tools::Rd_db (package = package)
        } else {
            # packages installed into local tempdir via covr:
            rd <- tools::Rd_db (
                package = fs::path_file (package),
                dir = package
            )
        }
        # installed packages can have different R
        alias_topic <- lapply (rd, function (i) {
            alias <- get_Rd_metadata (i, "alias")
            topic <- get_Rd_metadata (i, "name")
            name <- fs::path_file (attr (i, "Rdfile"))
            cbind (
                alias,
                rep (topic, length (alias)),
                rep (name, length (alias))
            )
        })
    }

    alias_topic <- do.call (rbind, alias_topic)
    index <- seq_len (nrow (alias_topic))
    if (!is.null (x)) {
        index <- match (x, alias_topic [, 1])
    }
    res <- data.frame (alias_topic [index, , drop = FALSE],
        stringsAsFactors = FALSE
    )
    names (res) <- c ("alias", "topic", "name")
    return (res)
}
m_fns_to_topics <- memoise::memoise (fns_to_topics)