R/get_path_to_protocol.R

In inbo/protocolshelper: Helper Functions to Manage Protocols

#' @title Function to get (or set) the full path to a protocol
#'
#' @description
#' A function that is used by other functions and should normally not be used
#' directly.
#'
#' For existing protocol codes, arguments `theme` and `project_name` are
#' always ignored.
#' The function will return the absolute path for that protocol.
#'
#' For new `sfp` or `spp` protocols, also either the `theme` or the
#' `project_name` argument and `short_title` are required apart from the
#' `protocol_code`.
#' The function will construct the absolute path where the source code for that
#' new protocol will be written.
#'
#' @param protocol_code Character string giving the protocol code
#' @param theme A character string equal to one of `"generic"`,
#' `"water"`, `"air"`, `"soil"`, `"vegetation"` or `"species"`.
#' Defaults to NULL.
#' Only needed if no folder with the name of the protocol code exists and
#' the request is for a `sfp` protocol.
#' @param project_name Character string giving the name of the project folder.
#' Defaults to NULL.
#' Only needed if no folder with the name of the protocol code exists and
#' the request is for a `spp` protocol.
#' @param short_title A character string of less than 20 characters to use in
#' folder and filenames.
#' Defaults to NULL.
#' Only needed if no folder with the name of the protocol code exists.
#'
#' @return A character vector containing the full path to the protocol.
#'
#' @importFrom rprojroot find_root is_git_root
#' @importFrom assertthat assert_that is.string
#' @importFrom stringr str_subset
#'
#' @export
#' @family utility
#' @examples
#' \dontrun{
#' get_path_to_protocol(protocol_code = "sfp-401-nl")
#' }
get_path_to_protocol <- function(protocol_code,
                                 theme = NULL,
                                 project_name = NULL,
                                 short_title = NULL) {
  assert_that(is.string(protocol_code))
  protocol_type <- regmatches(
    protocol_code,
    regexpr("^s[f|p|i|o|a]p", protocol_code)
  )
  assert_that(protocol_type %in% c("sfp", "spp", "sip", "sap", "sop"))

  # first case: the path exists already
  project_root <- find_root(is_git_root)
  ld <- list.dirs(
    path = file.path(project_root, "source"),
    full.names = TRUE,
    recursive = TRUE
  )
  ld <- str_subset(
    string = ld,
    pattern = str_replace_all(protocol_code, "-", "_")
  )
  if (!identical(ld, character(0))) {
    path_to_protocol <- ld[[1]]
    return(path_to_protocol)
  }

  # second case: the path does not yet exist
  if (is.null(short_title)) {
    stop(sprintf("Do you want to get the path?
                 If so, check if the protocol code is correct.
                 If you want to set a path for a new protocol,
                 you need to provide a short title"))
  } else {
    protocol_folder_name <- paste(
      str_replace_all(protocol_code, "-", "_"), short_title,
      sep = "_"
    )
  }

  if (protocol_type == "sfp") {
    assert_that(
      is.string(theme),
      theme %in% themes_df$theme
    )
    protocol_leading_number <- themes_df[
      themes_df$theme == theme,
      "theme_number"
    ]
    theme <- paste0(protocol_leading_number, "_", theme)
  }

  if (protocol_type == "spp") {
    assert_that(is.string(project_name))
  }

  path_to_protocol <- switch(protocol_type,
    "sfp" = file.path(
      project_root,
      "source",
      "sfp",
      theme,
      protocol_folder_name
    ),
    "spp" = file.path(
      project_root,
      "source",
      "spp",
      project_name,
      protocol_folder_name
    ),
    "sap" = file.path(
      project_root,
      "source",
      "sap",
      protocol_folder_name
    ),
    "sip" = file.path(
      project_root,
      "source",
      "sip",
      protocol_folder_name
    ),
    "sop" = file.path(
      project_root,
      "source",
      "sop",
      protocol_folder_name
    )
  )
  return(path_to_protocol)
}