feat: support for hyperlink_base (see doc_properties and set_doc_properties)

fix #630

Author: davidgohel

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: officer
 Title: Manipulation of Microsoft Word and PowerPoint Documents
-Version: 0.7.3.006
+Version: 0.7.3.007
 Authors@R: c(
     person("David", "Gohel", , "david.gohel@ardata.fr", role = c("aut", "cre")),
     person("Stefan", "Moog", , "moogs@gmx.de", role = "aut"),

NAMESPACE

@@ -1,7 +1,9 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method("[",app_properties)
 S3method("[",core_properties)
 S3method("[",custom_properties)
+S3method("[<-",app_properties)
 S3method("[<-",core_properties)
 S3method("[<-",custom_properties)
 S3method(as.character,fp_tab)
@@ -410,6 +412,7 @@ importFrom(xml2,xml_remove)
 importFrom(xml2,xml_replace)
 importFrom(xml2,xml_set_attr)
 importFrom(xml2,xml_set_attrs)
+importFrom(xml2,xml_set_text)
 importFrom(xml2,xml_text)
 importFrom(zip,unzip)
 importFrom(zip,zip)

NEWS.md

@@ -4,8 +4,11 @@
 
 - function `remove_slide()` now supports deletion of multiple slides
 thanks to Wahiduzzaman Khan (#691).
-- add `cursor_reach_index()` to set the cursor at a specific index position in 
+- add `cursor_reach_index()` to set the cursor at a specific index position in
 the document (#574).
+- `set_doc_properties()` gains a new argument `hyperlink_base` to set the base
+URL for relative hyperlinks in Word documents. `doc_properties()` now returns
+the `HyperlinkBase` property when available (#630).
 
 ## Issues
 

R/core_properties.R

@@ -144,3 +144,99 @@ drop_templatenode_from_app <- function(package_dir) {
     write_xml(doc, file)
   }
 }
+
+
+# app.xml properties ----
+
+read_app_properties <- function(package_dir) {
+  file <- file.path(package_dir, "docProps", "app.xml")
+  if (!file.exists(file)) {
+    return(NULL)
+  }
+  doc <- read_xml(file)
+  ns <- xml_ns(doc)
+
+  hyperlink_base_node <- xml_find_first(doc, "//d1:HyperlinkBase", ns = ns)
+  hyperlink_base <- if (inherits(hyperlink_base_node, "xml_missing")) {
+    NA_character_
+  } else {
+    xml_text(hyperlink_base_node)
+  }
+
+  company_node <- xml_find_first(doc, "//d1:Company", ns = ns)
+  company <- if (inherits(company_node, "xml_missing")) {
+    NA_character_
+  } else {
+    xml_text(company_node)
+  }
+
+  z <- list(
+    data = data.frame(
+      name = c("HyperlinkBase", "Company"),
+      value = c(hyperlink_base, company),
+      stringsAsFactors = FALSE
+    ),
+    file = file
+  )
+  class(z) <- "app_properties"
+  z
+}
+
+
+#' @export
+`[<-.app_properties` <- function(x, i, j, value) {
+  if (!i %in% x$data$name) {
+    new_row <- data.frame(name = i, value = value, stringsAsFactors = FALSE)
+    x$data <- rbind(x$data, new_row)
+  } else {
+    x$data[x$data$name == i, j] <- value
+  }
+  x
+}
+
+
+#' @export
+`[.app_properties` <- function(x, i, j) {
+  x$data[x$data$name == i, j]
+}
+
+#' @importFrom xml2 xml_set_text
+write_app_properties <- function(app_props, package_dir) {
+  if (is.null(app_props)) {
+    return(invisible())
+  }
+
+  file <- file.path(package_dir, "docProps", "app.xml")
+  if (!file.exists(file)) {
+    return(invisible())
+  }
+
+  doc <- read_xml(file)
+  ns <- xml_ns(doc)
+
+  for (i in seq_len(nrow(app_props$data))) {
+    prop_name <- app_props$data$name[i]
+    prop_value <- app_props$data$value[i]
+
+    if (is.na(prop_value) || prop_value == "") {
+      next
+    }
+
+    xpath <- paste0("//d1:", prop_name)
+    node <- xml_find_first(doc, xpath, ns = ns)
+    if (inherits(node, "xml_missing")) {
+      new_node <- read_xml(sprintf(
+        "<%s>%s</%s>",
+        prop_name,
+        htmlEscapeCopy(prop_value),
+        prop_name
+      ))
+      xml_add_child(doc, new_node)
+    } else {
+      xml_set_text(node, prop_value)
+    }
+  }
+
+  write_xml(doc, file)
+  invisible()
+}

R/docx_utils_funs.R

@@ -55,6 +55,21 @@ doc_properties <- function(x) {
     stringsAsFactors = FALSE
   )
   out <- rbind(out, out_custom)
+
+  # Add app properties for rdocx
+  if (inherits(x, "rdocx") && !is.null(x$app_properties)) {
+    app_props <- x$app_properties$data
+    app_props <- app_props[!is.na(app_props$value), , drop = FALSE]
+    if (nrow(app_props) > 0) {
+      out_app <- data.frame(
+        tag = app_props$name,
+        value = app_props$value,
+        stringsAsFactors = FALSE
+      )
+      out <- rbind(out, out_app)
+    }
+  }
+
   row.names(out) <- NULL
   out
 }
@@ -75,6 +90,8 @@ doc_properties <- function(x) {
 #' @param x an rdocx or rpptx object
 #' @param title,subject,creator,description text fields
 #' @param created a date object
+#' @param hyperlink_base a string specifying the base URL for relative hyperlinks
+#' in the document (only for rdocx).
 #' @param ... named arguments (names are field names), each element is a single
 #' character value specifying value associated with the corresponding field name.
 #' These pairs of *key-value* are added as custom properties. If a value is
@@ -99,6 +116,7 @@ set_doc_properties <- function(
   creator = NULL,
   description = NULL,
   created = NULL,
+  hyperlink_base = NULL,
   ...,
   values = NULL
 ) {
@@ -175,6 +193,35 @@ set_doc_properties <- function(
     }
   }
 
+  if (!is.null(hyperlink_base)) {
+    if (!inherits(x, "rdocx")) {
+      cli::cli_warn(
+        c(
+          "!" = "{.arg hyperlink_base} is only supported for Word documents.",
+          "i" = "It will be ignored."
+        )
+      )
+    } else if (!is_string(hyperlink_base)) {
+      cli::cli_warn(
+        c(
+          "!" = "The value for property {.val hyperlink_base} is not a string.",
+          "i" = "It will not be set in the document properties."
+        )
+      )
+    } else {
+      if (is.null(x$app_properties)) {
+        cli::cli_warn(
+          c(
+            "!" = "No app.xml file found in the document.",
+            "i" = "{.arg hyperlink_base} will not be set."
+          )
+        )
+      } else {
+        x$app_properties["HyperlinkBase", "value"] <- hyperlink_base
+      }
+    }
+  }
+
   if (is.null(values)) {
     values <- list(...)
   }

R/docx_write.R

@@ -254,6 +254,9 @@ print.rdocx <- function(
   if (nrow(x$doc_properties_custom$data) > 0) {
     write_custom_properties(x$doc_properties_custom, x$package_dir)
   }
+  if (!is.null(x$app_properties)) {
+    write_app_properties(x$app_properties, x$package_dir)
+  }
   x <- sanitize_images(x, warn_user = FALSE)
   invisible(pack_folder(folder = x$package_dir, target = target))
 }

R/read_docx.R

@@ -89,6 +89,7 @@ read_docx <- function(path = NULL) {
 
   obj$doc_properties_custom <- read_custom_properties(package_dir)
   obj$doc_properties <- read_core_properties(package_dir)
+  obj$app_properties <- read_app_properties(package_dir)
   obj$content_type <- content_type$new(package_dir)
   obj$doc_obj <- body_part$new(
     package_dir,