Merge pull request #22 from KWB-R/dev

Prepare next release

Author: hsonne

.gitignore

@@ -4,3 +4,4 @@
 .Ruserdata
 docs
 inst/doc
+inst/extdata/config_tmp.xml

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: kwb.abimo
 Title: R Package with Functions for Working with Water Balance
     Model ABIMO
-Version: 0.3.0
+Version: 0.4.0
 Authors@R: 
     c(person(given = "Andreas",
              family = "Matzinger",
@@ -45,7 +45,7 @@ Remotes:
 Encoding: UTF-8
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.1
 Depends: 
     R (>= 2.10)
 VignetteBuilder: knitr

NAMESPACE

@@ -17,6 +17,7 @@ export(extdata_file)
 export(get_bagrov_curves_from_abimo)
 export(get_xpaths)
 export(install_abimo)
+export(read_config)
 export(replace_value)
 export(run_abimo)
 export(run_abimo_command_line)

NEWS.md

@@ -1,5 +1,14 @@
 # Latest developments
 
+# kwb.abimo 0.4.0 (2024-02-09)
+
+* export read_config()
+* deprecate private function default_config_file(), use default_config() instead
+* add private function github_pat()
+* document and export install_abimo()
+* add argument "token" to private functions download_assets(), get_asset_info()
+* add arguments "tag", "read_intermediates" to run_abimo()
+
 # kwb.abimo 0.3.0 (2023-10-26)
 
 * Fix GitHub Actions workflow files (master -> v2)

R/configure.R

@@ -9,7 +9,7 @@
 #' @export
 create_configurator <- function(xml_file = NULL)
 {
-  xml_file <- kwb.utils::defaultIfNULL(xml_file, default_config_file())
+  xml_file <- kwb.utils::defaultIfNULL(xml_file, default_config())
 
   x <- xml2::read_xml(xml_file)
 
@@ -74,7 +74,22 @@ create_configurator <- function(xml_file = NULL)
 # default_config_file ----------------------------------------------------------
 default_config_file <- function()
 {
-  system.file("extdata/config.xml", package = "kwb.abimo")
+  kwb.utils::warningDeprecated(
+    "default_config_file",
+    "default_config"
+  )
+}
+
+# default_config ---------------------------------------------------------------
+
+#' Default ABIMO config.xml path
+#'
+#' @export
+#' @examples
+#' kwb.abimo::default_config()
+default_config <- function()
+{
+  extdata_file("config.xml")
 }
 
 # get_xpaths -------------------------------------------------------------------

R/configure_2.R

@@ -1,5 +1,11 @@
 # read_config ------------------------------------------------------------------
-read_config <- function(file = default_config_file())
+
+#' Read Abimo Configuration from XML File
+#'
+#' @param file path to XML file
+#' @importFrom xml2 read_xml
+#' @export
+read_config <- function(file = default_config())
 {
   dive_into(x = xml2::read_xml(file), file)
 }

R/helpers.R

@@ -71,18 +71,6 @@ check_abimo_binary <- function(tag = latest_abimo_version())
   file
 }
 
-# default_config -----------------------------------------------------------------
-
-#' Default ABIMO config.xml path
-#'
-#' @export
-#' @examples
-#' kwb.abimo::default_config()
-default_config <- function()
-{
-  extdata_file("config.xml")
-}
-
 # get_bagrov_curves_from_abimo -------------------------------------------------
 
 #' Get Bagrov curves from Abimo software
@@ -109,6 +97,11 @@ get_bagrov_curves_from_abimo <- function()
   ))
 }
 
+# github_pat -------------------------------------------------------------------
+# Provide non-exported function github_pat() from package remotes
+#' @importFrom utils getFromNamespace
+github_pat <- utils::getFromNamespace("github_pat", "remotes")
+
 # latest_abimo_version ---------------------------------------------------------
 latest_abimo_version <- function()
 {

R/install_abimo.R

@@ -1,7 +1,13 @@
 # install_abimo ----------------------------------------------------------------
 
+#' Install ABIMO
+#'
+#' @param tag tag of ABIMO version to be installed, e.g. "v3.2.2"
+#' @param arch target system architecture, one of "windows", "linux", "macos"
+#' @param \dots further arguments passed to \code{kwb.abimo:::download_assets}
 #' @importFrom archive archive_extract
-#' @importFrom kwb.utils catAndRun createDirectory
+#' @importFrom kwb.utils catAndRun createDirectory stringList
+#' @export
 install_abimo <- function(
     tag = latest_abimo_version(),
     arch = get_architecture_suffix(),
@@ -16,7 +22,6 @@ install_abimo <- function(
       "'architectures': ",
       kwb.utils::stringList(expected_architectures),
       call. = FALSE
-
     )
   }
 
@@ -48,40 +53,35 @@ install_abimo <- function(
 
 # download_assets --------------------------------------------------------------
 
-#' @importFrom utils download.file getFromNamespace
+#' @importFrom utils download.file
 download_assets <- function(
     repo,
     tag,
     destdir = tempdir(),
     pattern = NULL,
     accept = "application/octet-stream",
-    timeout = getOption("timeout")
+    timeout = getOption("timeout"),
+    token = github_pat()
 )
 {
   old_options <- options(timeout = timeout)
   on.exit(options(old_options))
 
-  asset_info <- get_asset_info(repo, tag)
+  asset_info <- get_asset_info(repo, tag, token = token)
 
   if (!is.null(pattern)) {
     asset_info <- asset_info[grepl(pattern, asset_info$name), ]
   }
 
-  # Provide non-exported function github_pat() from package remotes
-  token <- utils::getFromNamespace("github_pat", "remotes")()
-
-  # Compose HTTP header (with or without token)
-  headers <- c(
-    if (!is.null(token)) c(Authorization = paste("token", token)),
-    Accept = accept
-  )
-
   for (i in seq_len(nrow(asset_info))) {
 
     utils::download.file(
       url = asset_info$url[i],
       destfile = file.path(destdir, asset_info$name[i]),
-      headers = headers,
+      headers = c(
+        Authorization = paste("token", token),
+        Accept = accept
+      ),
       mode = "wb"
     )
   }
@@ -93,11 +93,11 @@ download_assets <- function(
 
 #' @importFrom gh gh
 #' @importFrom kwb.utils asNoFactorDataFrame selectElements
-get_asset_info <- function(repo, tag)
+get_asset_info <- function(repo, tag, token = github_pat())
 {
   url_releases <- sprintf("https://api.github.com/repos/%s/releases", repo)
 
-  release_info <- gh::gh(url_releases)
+  release_info <- gh::gh(url_releases, .token = token)
 
   tag_names <- sapply(release_info, kwb.utils::selectElements, "tag_name")
 
@@ -109,7 +109,7 @@ get_asset_info <- function(repo, tag)
   )
 
   if (!length(assets)) {
-    stop("There are no assets for release ", tag)
+    stop("There are no assets for release ", tag, call. = FALSE)
   }
 
   do.call(rbind, lapply(assets, function(asset) {

R/read_abimo_intermediate_results_from_log.R

@@ -0,0 +1,72 @@
+# read_intermediate_results_from_log -------------------------------------------
+
+#' Read Intermediate Results from Log File
+#'
+#' @param file path to log file
+#' @param pattern_remove regular expression matching lines to remove from the
+#'   log file before looking for "variable=expression" assignments
+read_intermediate_results_from_log <- function(
+    file = file.path(tempdir(), "abimo_input_result.log"),
+    pattern_remove = "Start|unknown|angenommen|nicht definiert|std::"
+)
+{
+  #file <- file.path(tempdir(), "abimo_input_result.log")
+  raw_text <- readLines(file)
+
+  # Remove irrelevant lines
+  text <- grep(pattern_remove, raw_text, value = TRUE, invert = TRUE)
+
+  # Pattern matching lines with code
+  pattern_code <- "^\\*\\*\\* Code: "
+
+  # Keep only lines with code or with equal sign (variable=value)
+  text <- grep(paste0(pattern_code, "|="), text, value = TRUE)
+
+  if (length(text) == 0L) {
+    message("No intermediates found in log file. Returning NULL.")
+    return(NULL)
+  }
+
+  textblocks <- kwb.utils::extractRowRanges(
+    text,
+    pattern = pattern_code,
+    startOffset = 0L
+  )
+
+  # Function to get the number of elements matching a pattern
+  n_matching <- function(x, pattern) length(grep(pattern, x))
+
+  # In each block all but the first line must contain the equal sign
+  stopifnot(all(
+    lengths(textblocks) - 1L == sapply(textblocks, n_matching, "=")
+  ))
+
+  # Read the codes from the first lines of the text blocks
+  code_lines <- sapply(textblocks, "[", 1L)
+
+  # Name the list elements according to the codes
+  names(textblocks) <- gsub(pattern_code, "", code_lines)
+
+  # Convert the text blocks with first (= code) line excluded to matrices
+  matrices <- lapply(textblocks, function(x) {
+    matrix(
+      data = unlist(strsplit(x[-1L], "=")),
+      ncol = 2,
+      byrow = TRUE,
+      dimnames = list(NULL, c("variable", "value"))
+    )
+  })
+
+  result <- kwb.utils::rbindAll(
+    x = matrices,
+    nameColumn = "code",
+    namesAsFactor = FALSE
+  )
+
+  # Convert usage string to numeric (number of letter in alphabet)
+  is_usage <- result$variable == "ut.usage"
+  result$value[is_usage] <- match(result$value[is_usage], LETTERS)
+
+  # Let "code" be the first column
+  kwb.utils::moveColumnsToFront(result, "code")
+}