development function wb_add_threaded_comment()

NAMESPACE

@@ -64,6 +64,7 @@ export(wb_add_named_region)
 export(wb_add_named_style)
 export(wb_add_numfmt)
 export(wb_add_page_break)
+export(wb_add_person)
 export(wb_add_pivot_table)
 export(wb_add_plot)
 export(wb_add_sparklines)
@@ -84,6 +85,7 @@ export(wb_get_cell_style)
 export(wb_get_creators)
 export(wb_get_named_regions)
 export(wb_get_order)
+export(wb_get_person)
 export(wb_get_selected)
 export(wb_get_sheet_name)
 export(wb_get_sheet_names)

R/class-comment.R

@@ -179,7 +179,6 @@ create_comment <- function(text,
 #' @param comment A Comment object. See [create_comment()].
 #' @param dims worksheet cell "A1"
 #' @rdname comment
-#' @keywords internal
 #' @export
 write_comment <- function(
     wb,
@@ -388,3 +387,123 @@ remove_comment <- function(
 wb_comment <- function(text = character(), author = character(), style = character()) {
   wbComment$new(text = text, author = author, style = style)
 }
+
+#' Add person to use for threaded comment
+#'
+#' If a threaded comment is added, it needs a person attached with it. The default is to create a person with provider id `"None"`. Other providers are possible with specific values for `id` and `user_id`. If you require the following, create a workbook via spreadsheet software load it and get the values with `wb_get_person()`
+#' @param wb a workbook
+#' @param name the name to display
+#' @param id (optional) the display id
+#' @param user_id (optional) the user id
+#' @param provider_id (optional) the provider id
+#' @keywords comments
+#' @export
+wb_add_person <- function(
+    wb,
+    name        = NULL,
+    id          = NULL,
+    user_id     = NULL,
+    provider_id = "None"
+) {
+  assert_workbook(wb)
+  wb$clone()$add_person(
+    name        = name,
+    id          = id,
+    user_id     = user_id,
+    provider_id = provider_id
+  )
+}
+
+#' Get Person list from workbook
+#'
+#' Persons are required for threaded comments
+#' @param wb a workbook
+#' @param name a specific name
+#' @export
+wb_get_person <- function(wb, name = NULL) {
+  assert_workbook(wb)
+  wb$get_person(name)
+}
+
+as_fmt_txt <- function(x) {
+  vapply(x, function(y) {
+    ifelse(is_xml(y), si_to_txt(xml_node_create("si", xml_children = y)), y)
+  },
+  NA_character_
+  )
+}
+
+wb_get_comment <- function(wb, sheet = current_sheet(), dims = "A1") {
+  sheet_id <- wb$validate_sheet(sheet)
+  cmts <- as.data.frame(do.call("rbind", wb$comments[[sheet_id]]))
+  if (!is.null(dims)) cmts <- cmts[cmts$ref == dims,]
+  cmts <- cmts[c("ref", "author", "comment")]
+  cmts$comment <- as_fmt_txt(cmts$comment)
+  cmts
+}
+
+wb_add_threaded_comment <- function(wb, sheet = current_sheet(), dims = "A1", comment, person_id) {
+
+  assert_workbook(wb)
+
+  sheet <- wb$validate_sheet(sheet)
+
+  if (length(cmt <- wb_get_comment(wb, dims)$comment)) {
+    # TODO not sure yet what to do
+  } else {
+    cmt <- create_comment(text = comment, author = "")
+    wb$add_comment(sheet = sheet, dims = dims, comment = c1)
+  }
+
+  if (!length(wb$worksheets[[sheet]]$relships$threadedComment)) {
+
+    # TODO the sheet id is correct ... ?
+    wb$worksheets[[sheet]]$relships$threadedComment <- sheet
+
+    wb$append(
+      "Content_Types",
+      # "<Default Extension=\"vml\" ContentType=\"application/vnd.openxmlformats-officedocument.vmlDrawing\"/>",
+      sprintf("<Override PartName=\"/xl/threadedComments/threadedComment%s.xml\" ContentType=\"application/vnd.ms-excel.threadedcomments+xml\"/>", sheet)
+    )
+
+    wb$worksheets_rels[[sheet]] <- append(
+      wb$worksheets_rels[[sheet]],
+      c(
+        sprintf("<Relationship Id=\"rId%s\" Type=\"http://schemas.microsoft.com/office/2017/10/relationships/threadedComment\" Target=\"../threadedComments/threadedComment%s.xml\"/>", length(wb$worksheets_rels[[1]]) + 1L, sheet)
+      )
+    )
+
+    wb$threadComments <- "<ThreadedComments xmlns=\"http://schemas.microsoft.com/office/spreadsheetml/2018/threadedcomments\" xmlns:x=\"http://schemas.openxmlformats.org/spreadsheetml/2006/main\"></ThreadedComments>"
+
+  }
+
+
+  tc <- xml_node_create(
+    "threadedComment",
+    xml_attributes = c(
+      ref = dims,
+      dT = as_POSIXct_utc(Sys.time()),
+      personId = person_id,
+      id = st_guid()
+    ),
+    xml_children = xml_node_create("text", xml_children = comment)
+  )
+
+  wb$threadComments <- xml_add_child(
+    wb$threadComments,
+    xml_child = tc
+  )
+
+
+  # wb$threadComments <-
+  #   xml_add_child(
+  #     wb$threadComments,
+  #     xml_child = c(
+  #       sprintf("<threadedComment ref=\"A1\" dT=\"2023-07-01T19:19:30.08\" personId=\"%s\" id=\"%s\"><text>Remember when I added threaded comments? Would be cool if we can have these in {openxlsx2}!</text></threadedComment>", wb_get_person()$id[2], c1_id),
+  #       sprintf("<threadedComment ref=\"A1\" dT=\"2023-07-02T19:19:30.08\" personId=\"%s\" id=\"%s\" parentId=\"%s\"><text>Yes, I do remember! Let's check this out.</text></threadedComment>", wb_get_person()$id[1], c2_id, c1_id),
+  #       sprintf("<threadedComment ref=\"A1\" dT=\"2023-07-02T19:19:30.08\" personId=\"%s\" id=\"%s\" parentId=\"%s\"><text>Yes, I do remember! Let's check this out.</text></threadedComment>", wb_get_person()$id[1], st_guid(), c1_id)
+  #     )
+  #   )
+
+  wb
+}

R/class-workbook.R

@@ -6714,6 +6714,65 @@ wbWorkbook <- R6::R6Class(
         ...                          = ...
       )
       invisible(self)
+    },
+
+    #' @description add person to workook
+    #' @param name name
+    #' @param id id
+    #' @param user_id user_id
+    #' @param provider_id provider_id
+    add_person = function (
+      name        = NULL,
+      id          = NULL,
+      user_id     = NULL,
+      provider_id = "None"
+    ) {
+
+      if (is.null(name))    name    <- Sys.getenv("USERNAME", Sys.getenv("USER"))
+      if (is.null(id))      id      <- st_guid()
+      if (is.null(user_id)) user_id <- st_userid()
+
+      xml_person <- xml_node_create(
+        "person",
+        xml_attributes = c(
+          displayName = name,
+          id          = id,
+          userId      = user_id,
+          providerId  = "None"
+        )
+      )
+
+      if (is.null(self$persons)) {
+        self$persons <- xml_node_create(
+          "personList",
+          xml_attributes = c(
+            `xmlns`   = "http://schemas.microsoft.com/office/spreadsheetml/2018/threadedcomments",
+            `xmlns:x` = "http://schemas.openxmlformats.org/spreadsheetml/2006/main"
+          )
+        )
+
+        self$append(
+          "workbook.xml.rels",
+          "<Relationship Id=\"rId5\" Type=\"http://schemas.microsoft.com/office/2017/10/relationships/person\" Target=\"persons/person.xml\"/>"
+        )
+
+        wb$append(
+          "Content_Types",
+          "<Override PartName=\"/xl/persons/person.xml\" ContentType=\"application/vnd.ms-excel.person+xml\"/>"
+        )
+      }
+
+      self$persons <- xml_add_child(self$persons, xml_person)
+
+      invisible(self)
+    },
+
+    #' description get person
+    #' @param name name
+    get_person = function(name = NULL) {
+      persons <- rbindlist(xml_attr(self$persons, "personList", "person"))
+      if (!is.null(name)) persons <- persons[persons$displayName == name, ]
+      persons
     }
 
   ),

R/helperFunctions.R

@@ -112,9 +112,6 @@ create_hyperlink <- function(sheet, row = 1, col = 1, text = NULL, file = NULL)
   return(str)
 }
 
-
-getRId <- function(x) reg_match0(x, '(?<= r:id=")[0-9A-Za-z]+')
-
 getId <- function(x) reg_match0(x, '(?<= Id=")[0-9A-Za-z]+')
 
 # `validateColor()` ------------------------------------------------------------
@@ -225,6 +222,7 @@ pxml <- function(x) {
   # paste(unique(unlist(x)), collapse = "")
   paste(unlist(x), collapse = "")
 }
+
 # `amp_split()` ----------------------------------------------------------------
 #' split headerFooter xml into left, center, and right.
 #' @param x xml string
@@ -246,6 +244,7 @@ amp_split <- function(x) {
   # return the string vector
   unname(res)
 }
+
 # Header footer ---------------------------------------------------------------
 #' get headerFooter from xml into list with left, center, and right.
 #' @param x xml string
@@ -1182,3 +1181,25 @@ to_string <- function(x) {
   }
   chr
 }
+
+#' create a guid string
+#' @keywords internal
+#' @noRd
+st_guid <- function() {
+  paste0(
+    "{",
+    random_string(length = 8, pattern = "[A-F0-9]"), "-",
+    random_string(length = 4, pattern = "[A-F0-9]"), "-",
+    random_string(length = 4, pattern = "[A-F0-9]"), "-",
+    random_string(length = 4, pattern = "[A-F0-9]"), "-",
+    random_string(length = 12, pattern = "[A-F0-9]"),
+    "}"
+  )
+}
+
+#' create a userid
+#' @keywords internal
+#' @noRd
+st_userid <- function() {
+  random_string(length = 16, pattern = "[a-z0-9]")
+}