data-raw/1a-helper_functions.R

In dynverse/dynmethods: A collection of trajectory inference methods

generate_file_from_container <- function(definition, version) {
  file_text <- paste0(
    # header
    "######################################### DO NOT EDIT! #########################################\n",
    "#### This file is automatically generated from data-raw/2-generate_r_code_from_containers.R ####\n",
    "################################################################################################\n",
    "\n",

    # documentation
    generate_documentation_from_definition(definition, version), "\n",

    # function
    generate_function_from_definition(definition, version), "\n"
  )

  path <- paste0("R/ti_", definition$method$id, ".R")

  readr::write_file(file_text, path)
}


generate_documentation_from_definition <- function(definition, version) {
  # url within name
  c(
    paste0("@title ", definition$method$name),
    "",
    "@description ", format_description(definition),
    "",
    format_container_url(definition),
    format_code_url(definition),
    "",
    format_citation(definition),
    "",
    format_parameter_documentation(definition),
    "",
    "@keywords method",
    "",
    "@return A TI method wrapper to be used together with \\code{\\link[dynwrap:infer_trajectories]{infer_trajectory}}",
    "@export"
  ) %>%
    strwrap(width = 80) %>%
    paste0("#' ", ., collapse = "\n")
}

generate_function_from_definition <- function(definition, version) {
  parameter_ids <-
    names(definition$parameters$parameters)

  # collect default parameters
  parameters <- map_chr(parameter_ids, function (pid) {
    paste0(
      pid,
      " = ",
      deparse(definition$parameters$parameters[[pid]]$default, width.cutoff = 500)
    )
  }) %>%
    paste0("    ", ., collapse = ",\n")

  # generate code for passing the default parameters to create_ti_method
  args <- map_chr(parameter_ids, ~ paste0(., " = ", .)) %>%
    paste0("    ", ., collapse = ",\n")

  # switch between a pure container wrapper or a hybrid R - container wrapper
  if (is.null(definition$package) || !is.character(definition$package$remote)) {
    package_repository <- "NULL"
    package_name <- "NULL"
    function_name <- "NULL"
    package_version <- "NULL"
  } else {
    package_repository <- paste0("\"", definition$package$remote, "\"")
    package_name <- paste0("\"", definition$package$name, "\"")
    function_name <- paste0("\"", definition$package$function_name, "\"")
    repo_spec <- parse_github_repo_spec(definition$package$remote)
    desc_url <- paste0(
      "https://raw.githubusercontent.com/",
      repo_spec$username, "/",
      repo_spec$repo, "/",
      ifelse(repo_spec$ref == "", "master", repo_spec$ref), "/",
      repo_spec$subdir, "/",
      "DESCRIPTION"
    )
    fil <- tempfile()
    on.exit(file.remove(fil))
    download.file(desc_url, fil)
    package_version <- paste0("\"", desc::desc_get_version(file = fil), "\"")
  }

  if (is.null(definition$container) || !is.character(definition$container$docker)) {
    container_id <- "NULL"
  } else {
    container_id <- paste0("\"", definition$container$docker, ":v", version, "\"")
  }

  # return code for function
  paste0(
    "ti_", definition$method$id, " <- function(\n",
    parameters, "\n",
    ") {\n",
    "  method_choose_backend(\n",
    "    package_repository = ", package_repository, ",\n",
    "    package_name = ", package_name, ",\n",
    "    function_name = ", function_name, ",\n",
    "    package_version = ", package_version, ",\n",
    "    container_id = ", container_id, "\n",
    "  )(\n",
    args, "\n",
    "  )\n",
    "}\n"
  )
}

format_description <- function(definition) {
  paste0("Will generate a trajectory using ", format_url_name(definition), ". ", definition$method$description)
}

format_code_url <- function(definition) {
  if (!is.null(definition$method$url)) {
    paste0("The original code of this method is available [here](", definition$method$url, ").")
  } else {
    ""
  }
}

format_container_url <- function(definition) {
  if (!is.null(definition$container$url)) {
    paste0("This method was wrapped inside a [container](", definition$container$url, ").")
  } else {
    ""
  }
}

#' @importFrom rcrossref cr_cn
format_citation <- function(definition) {
  if (!is.null(definition$manuscript$doi)) {
    paste0(
      "@references ",
      rcrossref::cr_cn(dois = definition$manuscript$doi[[1]], format = "text", style = "elsevier-harvard")
    )
  } else {
    ""
  }
}

format_url_name <- function(definition) {
  if (!is.null(definition$manuscript$doi)) {
    paste0("[", definition$method$name, "](https://doi.org/", definition$manuscript$doi[[1]], ")")
  } else if (!is.null(definition$method$url)) {
    paste0("[", definition$method$name, "](", definition$method$url, ")")
  } else {
    definition$method$name
  }
}

#' @importFrom Hmisc capitalize
format_parameter_documentation <- function(definition) {
  parameter_ids <-
    names(definition$parameters$parameters)

  # generate documentation per parameter separately
  map_chr(
    parameter_ids,
    function(parameter_id) {
      parameter <- definition$parameters$parameters[[parameter_id]]

      paste0("@param ", parameter$id, " ", dynparam::get_description(parameter, sep = ". "), ".")
    }
  )
}