R/registerFunctions.R

In kevinushey/Kmisc: Kevin Miscellaneous

##' Automatically Register C/C++ Functions in a Package
##'
##' This function can be used to automatically register the native routines
##' in a package. It searches all of the \code{.c} and \code{.cpp} files in
##' \code{src}, excluding the file \code{<pkgname>_init.c}, finds functions
##' annotated with \code{// [[register]]}, and extracts the
##' required information needed to register routines in the package.
##' The necessary routines are written to a file called
##' \code{src/<pkgname>_init.c}.
##'
##' This function should be called from the base directory of an
##' \R package you are developing.
##'
##' Currently, the assumption is that all functions in a package use the
##' \code{.Call} interface; i.e., there are no functions using the \code{.C},
##' \code{.Fortran}, or \code{.External} interfaces -- this may be
##' added in a future version.
##'
##' After calling this function, ensure that you have
##' \code{useDynLib(<pkg>, .registration=TRUE)} in your \code{NAMESPACE}.
##' If you use \code{roxygen} to document your package, you can
##' use
##'
##' \describe{
##' \item{    }{\code{##' @@useDynLib <pkg>, .registration=TRUE}}
##' }
##'
##' somewhere in your \code{roxygen} documentation to achieve the same effect.
##'
##' @param prefix A prefix to append to the exported name, so that a function
##'   called \code{myfun} is registered as \code{<prefix>myfun}.
##' @importFrom Rcpp compileAttributes
##' @export
registerFunctions <- function(prefix = "C_") {

  ## Get the package name from the DESCRIPTION file
  if (!file.exists("DESCRIPTION")) {
    stop("No file 'DESCRIPTION' exists; are you within the base directory ",
      "of your package?")
  }
  pkg_name <- unname(read.dcf("DESCRIPTION")[, "Package"])

  ## make sure we're actually in a package directory
  if (!all(c("./R", "./src") %in% list.dirs())) {
    stop("There is no 'R' or 'src' directory; please ensure you are ",
      "in the base directory of an R package.")
  }

  header_msg <- "// This file was automatically generated by 'Kmisc::registerFunctions()'"
  init_file_path <- file.path("src", paste0(pkg_name, "_init.c"))

  ## make sure we're not overwriting a user-written file
  if (file.exists(init_file_path)) {
    tmp <- readLines(init_file_path, n = 1)
    if (tmp != header_msg) {
      stop("file '", init_file_path, "' already exists and was not ",
        "automatically generated by 'registerFunctions'.\nPlease move ",
        "that file to a new location and run 'registerFunctions' again.")
    }
  }

  ## read in the C files
  ## but not init.c; it's special
  files <-  list.files("src", pattern = "[cC]$", full.names = TRUE)

  c_file_paths <- files[files != init_file_path]
  c_files <- lapply(c_file_paths, readLines)

  ## Strip initial whitespace
  c_files <- lapply(c_files, function(x) {
    gsub("^[[:space:]]*", "", x, perl = TRUE)
  })

  cpp_file_paths <- list.files("src", pattern = "cpp$", full.names = TRUE)

  ## don't read in RcppExports
  cpp_file_paths <- cpp_file_paths[cpp_file_paths != "src/RcppExports.cpp"]
  cpp_files <- lapply(cpp_file_paths, readLines)

  cpp_files <- lapply(cpp_files, function(x) {
    gsub("^[[:space:]]*", "", x, perl = TRUE)
  })

  get_c_prototypes <- function(x) {
    export_lines <- grep("// [[register]]", x, fixed=TRUE)
    sapply(export_lines, function(line) {
      sub <- paste(x[(line+1):length(x)], collapse="\n")
      tmp <- gsub(" *\\{.*", ";", sub)
      tmp <- gsub("\n", "", tmp)
      tmp <- gsub(" +", " ", tmp)
      return(tmp)
    })
  }

  if (length(c_files)) {
    c_prototypes <- sapply(c_files, get_c_prototypes)
    c_prototypes <- c_prototypes[sapply(c_prototypes, function(x) {
      !identical(x, list())
    })]
  } else {
    c_prototypes <- NULL
  }

  ## easy registration for functions exported with // [[Rcpp::exports]]
  has_rcpp_exports <- any(sapply(cpp_files, function(x) {
    any(grep("Rcpp::export", x, fixed = TRUE))
  }))

  if (has_rcpp_exports) {
    Rcpp::compileAttributes()
  }

  if (file.exists("src/RcppExports.cpp")) {
    rcpp_exports <- readLines("src/RcppExports.cpp")
    fn_lines <- grep("^RcppExport", rcpp_exports, value = TRUE)
    Rcpp_export_prototypes <- sapply(fn_lines, USE.NAMES = FALSE, function(x) {
      gsub("RcppExport (.*) \\{", "\\1;", x)
    })
  } else {
    Rcpp_export_prototypes <- NULL
  }

  ## registration for files with the old Rcpp interface
  get_cpp_prototypes <- function(x) {
    x <- gsub("RcppExport ", "", x)
    get_c_prototypes(x)
  }

  if (length(cpp_files)) {
    cpp_prototypes <- sapply(cpp_files, get_cpp_prototypes)
    cpp_prototypes <- cpp_prototypes[ sapply(cpp_prototypes, function(x) {
      !identical(x, list())
    }) ]
  } else {
    cpp_prototypes <- NULL
  }

  all_prototypes <- unlist(c(c_prototypes, Rcpp_export_prototypes, cpp_prototypes))
  if (!length(all_prototypes)) {
    stop("No functions detected for registration.")
  }

  all_names <- sapply(all_prototypes, USE.NAMES = FALSE, function(x) {
    gsub("^.*\\s(.*?)\\s*\\(.*$", "\\1", x, perl = TRUE)
  })

  all_nargs <- sapply(all_prototypes, function(x) {
    defn <- gsub("^.*\\(\\s*(.*?)\\s*\\).*$", "\\1", x, perl = TRUE)
    if (defn == "") {
      return(0L)
    }
    m <- gregexpr(",", defn)
    if (identical( as.integer(m[[1]]), -1L )) {
      return(1L)
    } else {
      return(length(m[[1]]) + 1L)
    }
  })

  ## Separate into .Call

  Cnames <- paste0(prefix, all_names)

  cmd_lines <- paste0("{\"", Cnames, "\", (DL_FUNC) &", all_names, ", ", all_nargs, "},")

  R_CallMethodsDef <- c(
    "R_CallMethodDef callMethods[]  = {",
    paste0("  ", cmd_lines),
    "  {NULL, NULL, 0}",
    "};"
  )

  R_RegisterRoutines <- c(
    paste0("void R_init_", pkg_name, "(DllInfo *info) {"),
    "  R_registerRoutines(info, NULL, callMethods, NULL, NULL);",
    "  R_useDynamicSymbols(info, FALSE);",
    "}"
  )

  ## write it out to an init file
  init.c <- c(
    header_msg,
    "",
    "#include <R.h>",
    "#include <Rinternals.h>",
    "",
    "#include <R_ext/Rdynload.h>",
    "",
    all_prototypes,
    "",
    R_CallMethodsDef,
    "",
    R_RegisterRoutines,
    ""
  )

  cat(init.c, file=init_file_path, sep="\n")

  NAMESPACE <- readLines("NAMESPACE")
  if (!any(grepl("\\.registration *= *T", NAMESPACE))) {
    warning("It appears routines are not registered in your 'NAMESPACE'.\nPlease ",
      "add 'useDynLib(", pkg_name, ", .registration=TRUE)' (without quotes) to ",
      "your package's 'NAMESPACE' file.")
  }
  return(invisible(NULL))

}