From d55f7e0a2ae3ca8d1134303005480de7deb307c8 Mon Sep 17 00:00:00 2001
From: David Gohel <david.gohel@ardata.fr>
Date: Sun, 5 May 2024 14:10:53 +0200
Subject: [PATCH] Add body_comment

body_comment adds a comment on an existing paragraph at the cursor position

authored-by: trekonom <moogs@gmx.de>

fix #566
---
 NAMESPACE                      |  1 +
 R/docx_add.R                   | 65 ++++++++++++++++++++++++++++++++++
 man/body_comment.Rd            | 31 ++++++++++++++++
 tests/testthat/test-docx-add.R | 43 ++++++++++++++++++++++
 4 files changed, 140 insertions(+)
 create mode 100644 man/body_comment.Rd

diff --git a/NAMESPACE b/NAMESPACE
index d908fd51..a396657b 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -172,6 +172,7 @@ export(body_add_table)
 export(body_add_toc)
 export(body_add_xml)
 export(body_bookmark)
+export(body_comment)
 export(body_end_block_section)
 export(body_end_section_columns)
 export(body_end_section_columns_landscape)
diff --git a/R/docx_add.R b/R/docx_add.R
index 1b611512..0b041dd4 100644
--- a/R/docx_add.R
+++ b/R/docx_add.R
@@ -561,6 +561,71 @@ body_remove <- function(x) {
   x
 }
 
+#' @export
+#' @title Add comment in a 'Word' document
+#' @description Add a comment at the cursor location. The comment
+#' is added on the first run of text in the current paragraph.
+#' @param x an rdocx object
+#' @param cmt a set of blocks to be used as comment content returned by
+#'   function [block_list()].
+#' @param author comment author.
+#' @param date comment date
+#' @param initials comment initials
+#' @examples
+#' doc <- read_docx()
+#' doc <- body_add_par(doc, "Paragraph")
+#' doc <- body_comment(doc, block_list("This is a comment."))
+#' docx_file <- print(doc, target = tempfile(fileext = ".docx"))
+#' docx_comments(read_docx(docx_file))
+body_comment <- function(x,
+                         cmt = ftext(""),
+                         author = "",
+                         date = "",
+                         initials = "") {
+  cursor_elt <- docx_current_block_xml(x)
+  ns_ <- "xmlns:w=\"http://schemas.openxmlformats.org/wordprocessingml/2006/main\""
+
+  open_tag <- wr_ns_yes
+
+  blocks <- sapply(cmt, to_wml)
+  blocks <- paste(blocks, collapse = "")
+
+  id <- basename(tempfile(pattern = "comment"))
+
+  cmt_xml <- paste0(
+    sprintf(
+      "<w:comment %s  w:id=\"%s\" w:author=\"%s\" w:date=\"%s\" w:initials=\"%s\">",
+      ns_, id, author, date, initials
+    ),
+    blocks,
+    "</w:comment>"
+  )
+
+  cmt_start_str <- sprintf("<w:commentRangeStart w:id=\"%s\" %s/>", id, ns_)
+  cmt_start_end <- sprintf("<w:commentRangeEnd %s w:id=\"%s\"/>", ns_, id)
+
+  path_ <- paste0(xml_path(cursor_elt), "//w:r")
+
+  cmt_ref_xml <- paste0(
+    open_tag,
+    if (!is.null(x$pr)) rpr_wml(x$pr),
+    "<w:commentReference w:id=\"",
+    id,
+    "\">",
+    cmt_xml,
+    "</w:commentReference>",
+    "</w:r>"
+  )
+
+  path_ <- paste0(xml_path(cursor_elt), "//w:r")
+
+  node <- xml_find_first(x$doc_obj$get(), path_)
+  xml_add_sibling(node, as_xml_document(cmt_start_str), .where = "before")
+  xml_add_sibling(node, as_xml_document(cmt_start_end), .where = "after")
+  xml_add_sibling(node, as_xml_document(cmt_ref_xml), .where = "after")
+
+  x
+}
 
 # body_add and methods -----
 #' @export
diff --git a/man/body_comment.Rd b/man/body_comment.Rd
new file mode 100644
index 00000000..1146d8dd
--- /dev/null
+++ b/man/body_comment.Rd
@@ -0,0 +1,31 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/docx_add.R
+\name{body_comment}
+\alias{body_comment}
+\title{Add comment in a 'Word' document}
+\usage{
+body_comment(x, cmt = ftext(""), author = "", date = "", initials = "")
+}
+\arguments{
+\item{x}{an rdocx object}
+
+\item{cmt}{a set of blocks to be used as comment content returned by
+function \code{\link[=block_list]{block_list()}}.}
+
+\item{author}{comment author.}
+
+\item{date}{comment date}
+
+\item{initials}{comment initials}
+}
+\description{
+Add a comment at the cursor location. The comment
+is added on the first run of text in the current paragraph.
+}
+\examples{
+doc <- read_docx()
+doc <- body_add_par(doc, "Paragraph")
+doc <- body_comment(doc, block_list("This is a comment."))
+docx_file <- print(doc, target = tempfile(fileext = ".docx"))
+docx_comments(read_docx(docx_file))
+}
diff --git a/tests/testthat/test-docx-add.R b/tests/testthat/test-docx-add.R
index fdf40e5d..2313aa81 100644
--- a/tests/testthat/test-docx-add.R
+++ b/tests/testthat/test-docx-add.R
@@ -198,3 +198,46 @@ test_that("add docx into docx", {
   expect_equal(doc_parts[grepl("\\.docx$", doc_parts)],
                list.files(file.path(new_dir, "word"), pattern = "\\.docx$") )
 })
+
+test_that("Add comment at cursor position", {
+  fp_bold <- fp_text_lite(bold = TRUE)
+  fp_red <- fp_text_lite(color = "red")
+
+  doc <- read_docx()
+  doc <- body_add_par(doc, "This is a first Paragraph.")
+  doc <- body_comment(doc,
+                      cmt = block_list("Comment on first par."),
+                      author = "Proofreader",
+                      date = Sys.Date()
+  )
+  doc <- body_add_fpar(
+    doc,
+    fpar("This is a second Paragraph. ", "This is a third Paragraph."),
+    style = "Normal"
+  )
+
+  doc <- body_comment(doc,
+                      cmt = block_list(
+                        fpar(ftext("Comment on second par ...", fp_bold)),
+                        fpar(
+                          ftext("... with a second line.", fp_red)
+                        )
+                      ),
+                      author = "Proofreader 2",
+                      date = Sys.Date()
+  )
+
+  docx_file <- print(doc, target = tempfile(fileext = ".docx"))
+  docx_dir <- tempfile()
+  unpack_folder(docx_file, docx_dir)
+
+  doc <- read_xml(file.path(docx_dir, "word/comments.xml"))
+  comment1 <- xml_find_first(doc, "w:comment[@w:id='0']")
+  comment2 <- xml_find_first(doc, "w:comment[@w:id='1']")
+
+  expect_false(inherits(comment1, "xml_missing"))
+  expect_false(inherits(comment2, "xml_missing"))
+
+  expect_length(xml_children(comment1), 1)
+  expect_length(xml_children(comment2), 2)
+})