R/rcpp.R

Defines functions rcpp_exports generate_function_regex parse_symbol_map.rcpp parse_source.rcpp fetch_symbol_map.rcpp_local fetch_symbol_map.rcpp_github fetch_symbol_map.rcpp_cran fetch_symbol_map.rcpp_bioc source_files.rcpp_local fetch_source.local source_url.local source_files.rcpp_github source_files.rcpp_cran source_files.rcpp_bioc fetch_source.github source_url.github source_url.cran source_url.bioc source_url.base fetch_source.cran fetch_source.bioc fetch_source.base

rcpp_exports <- function(package) {
  s <- as.source_type(package, "rcpp")
  tryCatch(names(parse_symbol_map(fetch_symbol_map(s))$map), "github_error" = function(e) character())
}

# -- Applicable to all Rcpp types --
generate_function_regex <- function(name) { }
parse_symbol_map.rcpp <- function(s) {

  lines <- s$map_lines

  comment_lines <- grep("// [[:alpha:]]+", lines[3:length(lines)]) + 2

  # remove // from comments
  comments <- sub("^// ", "", lines[comment_lines])

  # remove ; from declarations
  declarations <- sub(";$", "", lines[comment_lines + 1])

  # convert all spaces to match multiple spaces
  declarations <- gsub("[[:space:]]+", "[[:space:]]+", regex_escape(declarations))

  # allow spaces before and after ), (
  declarations <- gsub("(\\\\[)(])", "[[:space:]]*\\1[[:space:]]*", declarations)

  # add wildcards before , and ) to handle default arguments
  declarations <- gsub("(\\\\?[,)])", "[^,)]*\\1", declarations)

  s$map <- setNames(declarations, comments)
  s$regex <- s$map[s$name]
  s$search <- s$name
  s
}

parse_source.rcpp <- function(s, regex = s$regex) {
  s$fun_start <- s$fun_end <- s$fun_lines <- NULL

  new_lines <- cumsum(nchar(s$src_lines) + 1)
  lines <- paste(s$src_lines, collapse = "\n")

  start <- regexpr(regex, lines)
  if (length(start) > 0) {
    end <- find_function_end(lines, start)
    if (!is.na(end)) {
      s$fun_start <- tail(which(new_lines <= start), n = 1L) + 1L
      s$fun_end <- head(which(new_lines >= end), n = 1L)
      s$fun_lines <- s$src_lines[seq(s$fun_start, s$fun_end)]
      return(s)
    }
  }
  s
}

# -- local repository methods --
fetch_symbol_map.rcpp_local <- function(s) {
  path <- s$description$RemoteUrl

  name <- basename(path)

  rcpp_exports <- paths(path, "src", "RcppExports.cpp")

  if (!file.exists(rcpp_exports)) {
    s$map_lines <- NULL
  } else {
    s$map_lines <- readLines(rcpp_exports)
  }

  s
}

fetch_symbol_map.rcpp_github <- function(s) {
  s$map_lines <- github_content(
    path = paths(s$description$RemoteSubdir, "src/RcppExports.cpp"),
    owner = s$description$RemoteUsername,
    repo = s$description$RemoteRepo,
    ref = s$description$RemoteRef,
    api_url = s$description$RemoteHost)
  s
}

fetch_symbol_map.rcpp_cran <- function(s) {
  s$map_lines <- github_content(
    path = "src/RcppExports.cpp",
    owner = "cran",
    repo = s$description$Package,
    ref = s$description$Version)
  s
}

fetch_symbol_map.rcpp_bioc <- function(s) {
  s$map_lines <- github_content(
    path = "src/RcppExports.cpp",
    owner = "Bioconductor-mirror",
    repo = s$description$Package,
    ref = bioc_branch())
  s
}

source_files.rcpp_local <- function(s, ...) {
  path <- s$description$RemoteUrl
  s$src_files <- list.files(paths(path, "src"),
    pattern = "[.]((c(c|pp))|(h(pp)?))$",
    ignore.case = TRUE,
    recursive = TRUE)

  # Ignore the RcppExports file, not what we want
  s$src_files <- paths("src", s$src_files[basename(s$src_files) != "RcppExports.cpp"])
  s
}

fetch_source.local <- function(s, path) {
  s$src_path <- paths(s$description$RemoteUrl, path)
  s$src_lines <- readLines(s$src_path)
  s
}

source_url.local <- function(s, path = s$src_path[[1]], ...) {
  paths(s$description$RemoteUrl, path)
}

# -- Github --
source_files.rcpp_github <- function(s, name = s$search, ...) {
  s$src_files <- github_code_search(
    name = name,
    path = paths(s$description$RemoteSubdir, "src"),
    owner = s$description$RemoteUsername,
    repo = s$description$RemoteRepo,
    api_url = s$description$RemoteHost)

  # Ignore the RcppExports file, not what we want
  s$src_files <- s$src_files[basename(s$src_files) != "RcppExports.cpp"]
  s
}

source_files.rcpp_cran <- function(s, name = s$search, ...) {
  s$src_files <- github_code_search(
    name = name,
    path = "src/",
    owner = "cran",
    repo = s$description$Package)

  # Ignore the RcppExports file, not what we want
  s$src_files <- s$src_files[basename(s$src_files) != "RcppExports.cpp"]
  s
}

source_files.rcpp_bioc <- function(s, name = s$search, ...) {
  s$src_files <- github_code_search(
    name = name,
    path = "src/",
    owner = "Bioconductor-mirror",
    repo = s$description$Package)

  # Ignore the RcppExports file, not what we want
  s$src_files <- s$src_files[basename(s$src_files) != "RcppExports.cpp"]
  s
}

fetch_source.github <- function(s, path) {
  s$src_lines <- github_content(
    path = path,
    owner = s$description$RemoteUsername,
    repo = s$description$RemoteRepo,
    ref = s$description$RemoteRef)

  s$src_path <- path
  s
}

source_url.github <- function(s, path = s$src_path[[1]], ...) {
  github_content_url(
    path = path,
    owner = s$description$RemoteUsername,
    repo = s$description$RemoteRepo,
    ref = s$description$RemoteRef)
}

source_url.cran <- function(s, path = s$src_path[[1]], ...) {
  github_content_url(
    path,
    owner = "cran",
    repo = s$description$Package,
    ref = s$description$Version)
}

source_url.bioc <- function(s, path = s$src_path[[1]], ...) {
  github_content_url(
    path,
    owner = "Bioconductor-mirror",
    repo = s$description$Package,
    ref = bioc_branch())
}

source_url.base <- function(s, path = s$src_path[[1]], ...) {
  github_content_url(
    path,
    owner = "wch",
    repo = "r-source")
}

fetch_source.cran <- function(s, path) {
  s$src_lines <- github_content(
    path,
    owner = "cran",
    repo = s$description$Package,
    ref = s$description$Version)

  s$src_path <- path
  s
}

fetch_source.bioc <- function(s, path) {
  s$src_lines <- github_content(
    path,
    owner = "Bioconductor-mirror",
    repo = s$description$Package,
    ref = bioc_branch())

  s$src_path <- path
  s
}

fetch_source.base <- function(s, path) {
  s$src_lines <- github_content(
    path,
    owner = "wch",
    repo = "r-source")

  s$src_path <- path
  s
}
jimhester/lookup documentation built on Dec. 18, 2019, 11:54 p.m.