R/helpers.R

In mlysy/TMBtools: Tools for Developing R Packages Interfacing with 'TMB'

#--- helper functions ----------------------------------------------------------

# formats useDynLib
use_dynlib <- function(dynlibs) {
  out <- paste0("useDynLib(", dynlibs, ")")
  out <- paste0(out, collapse = "; ")
  out
}

# adds a file to the package
use_file <- function(fl, ...) {
  if(!file.exists(fl)) ui_stop("File {ui_path(fl)} doesn't exist.")
  path <- file.path(..., basename(fl))
  success <- file.copy(from = fl,
                       to = file.path(usethis::proj_get(), path))
  if(success) {
    ui_done("Writing {ui_path(path)}")
  }
}

# silently executes usethis commands
use_silent <- function(code) {
  if(!missing(code)) {
    withr::with_options(list(usethis.quiet = TRUE), code = code)
  }
}

# needs init if src has no files (except directories)
check_needs_init <- function(root) {
  src_files <- dir(path = file.path(root, "src"), full.names = TRUE)
  length(src_files) == 0 || all(dir.exists(src_files))
}

# check whether license is gpl (>=2) compatible
check_gpl <- function(root) {
  lic <- read.dcf(file = file.path(root, "DESCRIPTION"),
                  fields = "License")[1]
  if(is.na(lic)) {
    lic <- FALSE
  } else {
    # has a license, check compatibility
    lic <- toupper(gsub("[[:space:]]+", "", lic))
    lic <- gsub("(\\|LICENSE|\\|LICENCE)", "", lic)
    lic <- gsub("[^[:alnum:]]+", "", lic)
    lic <- lic %in% c("GPL2", "GPL3", "AGPL3")
  }
  if(!lic) {
    ui_todo("{ui_value(get_package(root))} legally requires GPL-2 compatible license to distribute {ui_value('TMB')} code.")
    ui_line("To enable this set the following in DESCRIPTION:")
    message("")
    ui_code_block("License: GPL (>= 2)")
    message("")
  }
}

# identical to usethis::use_template, except:
# 1. package defaults to TMBtools
# 2. never overwrites if file exists
use_template <- function(template, save_as = template,
                         data = list(), ignore = FALSE,
                         open = FALSE, package = "TMBtools") {
  usethis::local_project()
  if(file.exists(file.path(usethis::proj_get(), save_as))) {
    ui_line("File {ui_path(save_as)} already exists.  Not overwritten.")
  } else {
    usethis::use_template(template = template,
                          save_as = save_as,
                          data = data, ignore = ignore,
                          open = open, package = package)
  }
}

# get package name
get_package <- function(root) {
  read.dcf(file = file.path(root, "DESCRIPTION"), fields = "Package")[1]
}

# check if file was autogenerated by TMBtools
check_tmb_generated <- function(tmb_main) {
  tmb_str <- "// Generated by TMBtools: do not edit by hand"
  if(file.exists(tmb_main)) {
    if(readLines(tmb_main)[1] != tmb_str) {
      tmb_main <- paste0('src/TMB/', basename(tmb_main))
      ui_stop("{ui_path(tmb_main)} exists but not generated by TMBtools.  Not overwritten.")
    } else {
      file.remove(tmb_main)
    }
  }
}

# check if path is nested in another package
check_pkg_nested <- function(path) {
  usethis::local_project(path = path, force = TRUE, setwd = FALSE, quiet = TRUE)
  pkg <- tryCatch(rprojroot::find_root("DESCRIPTION", path),
                  error = function(e) NULL)
  ## currwd <- getwd()
  ## on.exit(setwd(currwd))
  ## setwd(path)
  ## proj <- usethis::proj_get()
  if(!is.null(pkg)) {
    ui_stop("{ui_value('usethis::create_package')} cannot create a package inside existing package {ui_value(pkg)}.")
  }
}


# add TMB specific instructions to NAMESPACE file
add_tmb_namespace <- function(root, pkg, dynlibs) {
  nsp <- file.path(root, "NAMESPACE")
  # check if the NAMESPACE has the correct dynlibs
  has_tmb_nsp <- rm_white(use_dynlib(dynlibs))
  has_tmb_nsp <- gsub("([.]|\\(|\\))", "\\\\\\1", has_tmb_nsp)
  has_tmb_nsp <- file.exists(nsp) &&
    any(grepl(pattern = paste0("^(", has_tmb_nsp, ")$"),
              x = rm_white(readLines(nsp))))
  # check if package uses roxygen
  has_roxy <- !all(is.na(read.dcf(file.path(root, "DESCRIPTION"),
                              fields = c("Roxygen", "RoxygenNote"))))
  if(!has_tmb_nsp) {
    has_nsp <- file.exists(nsp)
    if(!has_nsp) {
      # add Namespace file (probably only happens in tmb_create_package)
      use_template(template = "NAMESPACE", package = "TMBtools",
                   data = list(usedl = use_dynlib(dynlibs)))
    }
    if(has_roxy) {
      # check if package has "pkgname{-package}.R" file
      has_pkgdoc <- file.path(root, "R",
                              paste0(pkg, c(".R", "-package.R")))
      has_pkgdoc <- any(file.exists(has_pkgdoc))
      if(!has_pkgdoc) {
        # create a default usethis namespace
        use_template(template = "package.R", package = "TMBtools",
                     save_as = file.path("R", paste0(pkg, "-package.R")),
                     data = list(usedl = use_dynlib(dynlibs)))
        ui_done("Done!")
        if(has_nsp) {
          # probably only avoided with tmb_create_package
          ui_todo("Run roxygen on package to update NAMESPACE.")
        }
      } else {
        # user has to manually update namespace via roxygen
        ui_done("Done!")
        ui_todo("Add the following roxygen comment to update the NAMESPACE:")
        message()
        ui_code_block(paste0("#' @rawNamespace ", use_dynlib(dynlibs)))
        message("")
      }
    } else {
      # user has to manually update namespace by hand
      ui_done("Done!")
      ui_todo("Add the following line to the NAMESPACE file:\n")
      message("")
      ui_line(use_dynlib(dynlibs))
      message("")
    }
  } else {
    ui_done("Done!")
  }
}

# remove all whitespace from a character vector
rm_white <- function(x) gsub("[[:space:]]", "", x)

## # similar to usethis::create_package but with fewer options and no prompts
## create_package <- function(path, fields) {
##   path <- fs::path_expand(path)
##   name <- fs::path_file(path)
##   fs::dir_create(path)
##   old_project <- usethis::proj_set(path, force = TRUE)
##   on.exit(usethis::proj_set(old_project), add = TRUE)
##   use_directory("R")
##   usethis::use_description(fields)
##   invisible(usethis::proj_get())
## }