Merge pull request #272 from Merck/feature/issue-256-simsun-font

Feature/issue 256 simsun font

Author: wangben718

.gitignore

@@ -9,3 +9,4 @@ sync_bitbucket.R
 r2rtf.Rcheck/
 r2rtf*.tar.gz
 r2rtf*.tgz
+revdep/

R/as_rtf_paragraph.R

@@ -34,13 +34,17 @@
 as_rtf_paragraph <- function(text, combine = TRUE) {
   attr_text <- attributes(text)
 
+  # Get use_i18n from text attributes (will be set by obj_rtf_text)
+  use_i18n <- attr_text$use_i18n %||% FALSE
+
   text_rtftext <- rtf_text(text,
     font = attr_text$text_font,
     font_size = attr_text$text_font_size,
     format = attr_text$text_format,
     color = attr_text$text_color,
     background_color = attr_text$text_background_color,
-    text_convert = attr_text$text_convert
+    text_convert = attr_text$text_convert,
+    use_i18n = use_i18n
   )
 
   if (combine) {

R/content_create.R

@@ -36,6 +36,8 @@ as_rtf_init <- function() {
 
 #' Create RTF Font Encode
 #'
+#' @param tbl A data frame with potential page attributes containing use_i18n flag.
+#'
 #' @section Specification:
 #' \if{latex}{
 #'  \itemize{
@@ -46,8 +48,14 @@ as_rtf_init <- function() {
 #' \if{html}{The contents of this section are shown in PDF user manual only.}
 #'
 #' @noRd
-as_rtf_font <- function() {
-  font_type <- font_type()
+as_rtf_font <- function(tbl = NULL) {
+  # Get use_i18n flag from table attributes if available
+  use_i18n <- FALSE
+  if (!is.null(tbl) && !is.null(attr(tbl, "page"))) {
+    use_i18n <- attr(tbl, "page")$use_i18n %||% FALSE
+  }
+
+  font_type <- font_type(use_i18n = use_i18n)
   font_rtf <- factor(seq_along(font_type$type), levels = font_type$type, labels = font_type$rtf_code)
   font_style <- factor(seq_along(font_type$type), levels = font_type$type, labels = font_type$style)
   font_name <- factor(seq_along(font_type$type), levels = font_type$type, labels = font_type$name)
@@ -317,7 +325,9 @@ as_rtf_footnote <- function(tbl, attr_name = "rtf_footnote") {
       )
     } else {
       if (any(attr(text, "text_convert"))) {
-        text_matrix <- convert(text)
+        # Get use_i18n from text attributes
+        use_i18n <- attr(text, "use_i18n") %||% FALSE
+        text_matrix <- convert(text, use_i18n = use_i18n)
       } else {
         text_matrix <- text
       }

R/conversion.R

@@ -70,43 +70,55 @@ cell_size <- function(col_rel_width, col_total_width) {
 #'
 #' @noRd
 convert <- function(text,
+                    use_i18n = FALSE,
                     load_stringi = requireNamespace("stringi", quietly = TRUE)) {
   # grepl(">|<|=|_|\\^|(\\\\)|(\\n)", c(">", "<", "=", "_", "\n", "\\line", "abc"))
   index <- grepl(">|<|=|_|\\^|(\\\\)|(\\n)", text)
 
-  if (!any(index)) {
-    return(text)
-  }
+  # Process special characters if they exist
+  if (any(index)) {
+    char_rtf <- c(
+      "^" = "\\super ",
+      "_" = "\\sub ",
+      ">=" = "\\geq ",
+      "<=" = "\\leq ",
+      "\n" = "\\line ",
+      "\\pagenumber" = "\\chpgn ",
+      "\\totalpage" = "\\totalpage ",
+      "\\pagefield" = "{\\field{\\*\\fldinst NUMPAGES }} "
+    )
 
-  char_rtf <- c(
-    "^" = "\\super ",
-    "_" = "\\sub ",
-    ">=" = "\\geq ",
-    "<=" = "\\leq ",
-    "\n" = "\\line ",
-    "\\pagenumber" = "\\chpgn ",
-    "\\totalpage" = "\\totalpage ",
-    "\\pagefield" = "{\\field{\\*\\fldinst NUMPAGES }} "
-  )
+    # Define Pattern for latex code
+    unicode_int <- as.integer(as.hexmode(unicode_latex$unicode))
+    char_latex <- ifelse(unicode_int <= 255 & unicode_int != 177, unicode_latex$chr,
+      sprintf("\\uc1\\u%d*", unicode_int - ifelse(unicode_int < 32768, 0, 65536))
+    )
 
-  # Define Pattern for latex code
+    names(char_latex) <- unicode_latex$latex
 
-  unicode_int <- as.integer(as.hexmode(unicode_latex$unicode))
-  char_latex <- ifelse(unicode_int <= 255 & unicode_int != 177, unicode_latex$chr,
-    sprintf("\\uc1\\u%d*", unicode_int - ifelse(unicode_int < 32768, 0, 65536))
-  )
+    char_latex <- rev(c(char_latex, char_rtf))
 
-  names(char_latex) <- unicode_latex$latex
-
-  char_latex <- rev(c(char_latex, char_rtf))
+    if (load_stringi) {
+      text[index] <- stringi::stri_replace_all_fixed(text[index], names(char_latex), char_latex,
+        vectorize_all = FALSE, opts_fixed = list(case_insensitive = FALSE)
+      )
+    } else {
+      for (i in seq_along(char_latex)) {
+        text[index] <- gsub(names(char_latex[i]), char_latex[i], text[index], fixed = TRUE)
+      }
+    }
+  }
 
-  if (load_stringi) {
-    text[index] <- stringi::stri_replace_all_fixed(text[index], names(char_latex), char_latex,
-      vectorize_all = FALSE, opts_fixed = list(case_insensitive = FALSE)
-    )
-  } else {
-    for (i in seq_along(char_latex)) {
-      text[index] <- gsub(names(char_latex[i]), char_latex[i], text[index], fixed = TRUE)
+  # Apply UTF-8 to RTF conversion for non-ASCII characters when use_i18n is TRUE
+  if (use_i18n) {
+    # Check for non-ASCII characters
+    has_non_ascii <- grepl("[^\x01-\x7F]", text)
+    if (any(has_non_ascii)) {
+      text[has_non_ascii] <- vapply(text[has_non_ascii],
+        utf8Tortf,
+        character(1),
+        USE.NAMES = FALSE
+      )
     }
   }
 
@@ -148,3 +160,22 @@ utf8Tortf <- function(text) {
 
   paste0(x_rtf, collapse = "")
 }
+
+#' Apply UTF-8 to RTF Conversion for Character Vectors
+#'
+#' @param text Character vector to convert
+#' @param use_i18n Logical indicating whether to apply UTF-8 conversion
+#'
+#' @noRd
+apply_utf8_conversion <- function(text, use_i18n = FALSE) {
+  if (!use_i18n || is.null(text)) {
+    return(text)
+  }
+
+  # Apply utf8Tortf to each element in the character vector
+  if (is.character(text)) {
+    vapply(text, utf8Tortf, character(1), USE.NAMES = FALSE)
+  } else {
+    text
+  }
+}

R/dictionary.R

@@ -18,48 +18,56 @@
 
 #' RTF Text Font Dictionary
 #'
+#' @param use_i18n Logical. If TRUE, includes SimSun font for CJK support.
+#'
 #' @section Specification:
 #' \if{latex}{
 #'  \itemize{
 #'    \item Collect most commonly used fonts (Times New Roman, Times New Roman Greek, and Arial Greek, etc.).
-#'    \item Define font types from 1 to 10.
+#'    \item Define font types from 1 to 10 (or 11 with SimSun when use_i18n is TRUE).
 #'    \item Define font styles.
 #'    \item Create a mapping between font types and their RTF code.
 #'  }
 #'  }
 #' \if{html}{The contents of this section are shown in PDF user manual only.}
 #'
 #' @noRd
-font_type <- function() {
-  data.frame(
-    type = 1:10,
+font_type <- function(use_i18n = TRUE) {
+  all_fonts <- data.frame(
+    type = 1:11,
     name = c(
       "Times New Roman", "Times New Roman Greek", "Arial Greek",
       "Arial", "Helvetica", "Calibri", "Georgia",
-      "Cambria", "Courier New", "Symbol"
+      "Cambria", "Courier New", "Symbol", "SimSun"
     ),
     style = c(
       "\\froman", "\\froman", "\\fswiss",
       "\\fswiss", "\\fswiss", "\\fswiss", "\\froman",
-      "\\ffroman", "\\fmodern", "\\ftech"
+      "\\ffroman", "\\fmodern", "\\ftech", "\\fnil"
     ),
     rtf_code = c(
       "\\f0", "\\f1", "\\f2",
       "\\f3", "\\f4", "\\f5", "\\f6",
-      "\\f7", "\\f8", "\\f9"
+      "\\f7", "\\f8", "\\f9", "\\f10"
     ),
     family = c(
       "Times", "Times", "ArialMT", "ArialMT", "Helvetica",
-      "Calibri", "Georgia", "Cambria", "Courier", "Times"
+      "Calibri", "Georgia", "Cambria", "Courier", "Times", "SimSun"
     ),
     charset = c(
       "\\fcharset1", "\\fcharset161", "\\fcharset161", "\\fcharset0",
       "\\fcharset1", "\\fcharset1", "\\fcharset1", "\\fcharset1",
-      "\\fcharset0", "\\fcharset2"
+      "\\fcharset0", "\\fcharset2", "\\fcharset134"
     ),
-    width_group = c(1, 1, 4, 4, 4, 1, 9, 4, 9, 9),
+    width_group = c(1, 1, 4, 4, 4, 1, 9, 4, 9, 9, 1),
     stringsAsFactors = FALSE
   )
+
+  if (use_i18n) {
+    all_fonts
+  } else {
+    all_fonts[1:10, ]
+  }
 }
 
 

R/obj_rtf_text.R

@@ -52,7 +52,8 @@ obj_rtf_text <- function(text,
                          text_space_after = 15,
                          text_new_page = FALSE,
                          text_hyphenation = TRUE,
-                         text_convert = TRUE) {
+                         text_convert = TRUE,
+                         use_i18n = FALSE) {
   # Check argument type
   check_args(text, type = c("character", "data.frame"))
 
@@ -143,6 +144,7 @@ obj_rtf_text <- function(text,
   attr(text, "text_new_page") <- text_new_page
   attr(text, "text_hyphenation") <- text_hyphenation
   attr(text, "text_convert") <- text_convert
+  attr(text, "use_i18n") <- use_i18n
   attr(text, "strwidth") <- rtf_strwidth(text)
 
   # Register Color Use

R/rtf_colheader.R

@@ -105,6 +105,9 @@ rtf_colheader <- function(tbl,
   # Split input by "|".
   colheader <- data.frame(t(trimws(unlist(strsplit(colheader, "|", fixed = TRUE)))))
 
+  # Get use_i18n from page attributes
+  use_i18n <- attr(tbl, "page")$use_i18n %||% FALSE
+
   # Define text attributes
   colheader <- obj_rtf_text(colheader,
     text_font,
@@ -121,7 +124,8 @@ rtf_colheader <- function(tbl,
     text_space_after,
     text_new_page = FALSE,
     text_hyphenation = text_hyphenation,
-    text_convert = text_convert
+    text_convert = text_convert,
+    use_i18n = use_i18n
   )
   if (attr(colheader, "use_color")) attr(tbl, "page")$use_color <- TRUE
 

R/rtf_encode_figure.R

@@ -70,7 +70,7 @@ rtf_encode_figure <- function(tbl) {
 
   start_rtf <- paste(
     as_rtf_init(),
-    as_rtf_font(),
+    as_rtf_font(tbl),
     as_rtf_color(tbl),
     sep = "\n"
   )

R/rtf_encode_table.R

@@ -50,7 +50,7 @@ rtf_encode_table <- function(tbl, verbose = FALSE) {
   start_rtf <- paste(
 
     as_rtf_init(),
-    as_rtf_font(),
+    as_rtf_font(tbl),
     as_rtf_color(tbl),
     sep = "\n"
   )

R/rtf_footnote.R

@@ -162,6 +162,9 @@ rtf_footnote <- function(tbl,
     tbl <- rtf_page(tbl)
   }
 
+  # Get use_i18n from page attributes
+  use_i18n <- attr(tbl, "page")$use_i18n %||% FALSE
+
   # Define text object
   footnote <- obj_rtf_text(footnote,
     text_font,
@@ -178,7 +181,8 @@ rtf_footnote <- function(tbl,
     text_space_after,
     text_new_page = FALSE,
     text_hyphenation = TRUE,
-    text_convert = text_convert
+    text_convert = text_convert,
+    use_i18n = use_i18n
   )
 
   if (attr(footnote, "use_color")) attr(tbl, "page")$use_color <- TRUE