r - 如何使这个 XML 代码生成粗体文本？

Question

这是一个代表。

dt <- data.frame(a = 1:3, b = c("a", "b", ""))

dt$sup <- paste0(dt$a, "_[", dt$b, "]") # create superscript col, enclosed in '_[]'

wb <- openxlsx::createWorkbook() # create workbook

openxlsx::addWorksheet(wb, sheetName = "data") # add sheet

openxlsx::writeData(wb, sheet=1, x=dt, xy=c(1, 1)) # write data on workbook

for(i in grep("\\_\\[([A-z0-9\\s]*)\\]", wb$sharedStrings)){
  # if empty string in superscript notation, then just remove the superscript notation
  if(grepl("\\_\\[\\]", wb$sharedStrings[[i]])){
   wb$sharedStrings[[i]] <- gsub("\\_\\[\\]", "", wb$sharedStrings[[i]])
   next # skip to next iteration
  }

  # insert additioanl formating in shared string
  wb$sharedStrings[[i]] <- gsub("<si>", "<si><r>", gsub("</si>", "</r></si>", wb$sharedStrings[[i]]))

  # find the "_[...]" pattern, remove brackets and udnerline and enclose the text with superscript format
  wb$sharedStrings[[i]] <- gsub("\\_\\[([A-z0-9\\s]*)\\]", "</t></r><r><rPr><vertAlign val=\"superscript\"/></rPr><t xml:space=\"preserve\">\\1</t></r><r><t xml:space=\"preserve\">", wb$sharedStrings[[i]])
}

openxlsx::saveWorkbook(wb, file="test.xlsx", overwrite = TRUE)

这是上面代码的输出：

我需要更改 xml 代码的某些部分以生成粗体文本，如下所示：

我尝试使用openxlsx包中的格式，但我得到：

这是来自openxlsx格式化的代码，但它并没有像您在上面看到的那样将上标部分加粗。所以我认为这样做的路径是修改xml代码以获得它，这就是我需要的帮助。

openxlsx::addStyle(wb, "text.xlsx", 
         style = openxlsx::createStyle(textDecoration = "bold"),
         rows = 2:3, cols = 3, gridExpand = TRUE)

标签： rexcelxml

Answer 1

我用这个函数解决了这个问题，只有一个输入：

您的输入texto应采用以下格式：

text: "普通文本[上标]~下标~"（避免~之间有空格）

addSuperSubScriptToCell_general <- function(wb,
                                 sheet,
                                 row,
                                 col,
                                 texto,
                                 size = '10',
                                 colour = '000000',
                                 font = 'Arial',
                                 family = '2',
                                 bold = FALSE,
                                 italic = FALSE,
                                 underlined = FALSE) {
  
  placeholderText <- 'This is placeholder text that should not appear anywhere in your document.'
  
  openxlsx::writeData(wb = wb,
                      sheet = sheet,
                      x = placeholderText,
                      startRow = row,
                      startCol = col)
  
  #finds the string that you want to update
  stringToUpdate <- which(sapply(wb$sharedStrings,
                                 function(x){
                                   grep(pattern = placeholderText,
                                        x)
                                 }
  )
  == 1)
  
  #splits the text into normal text, superscript and subcript
  
  normal_text <- str_split(texto, "\\[.*\\]|~.*~") %>% pluck(1) %>% purrr::discard(~ . == "")
  
  sub_sup_text <- str_extract_all(texto, "\\[.*\\]|~.*~") %>% pluck(1)
  
  if (length(normal_text) > length(sub_sup_text)) {
    sub_sup_text <- c(sub_sup_text, "")
  } else if (length(sub_sup_text) > length(normal_text)) {
    normal_text <- c(normal_text, "")
  }
# this is the separated text which will be used next
texto_separado <- map2(normal_text, sub_sup_text, ~ c(.x, .y)) %>% 
    reduce(c) %>% 
    purrr::discard(~ . == "")
  
#formatting instructions
  
  sz    <- paste('<sz val =\"',size,'\"/>',
                 sep = '')
  col   <- paste('<color rgb =\"',colour,'\"/>',
                 sep = '')
  rFont <- paste('<rFont val =\"',font,'\"/>',
                 sep = '')
  fam   <- paste('<family val =\"',family,'\"/>',
                 sep = '')

#if its sub or sup adds the corresponding xml code
sub_sup_no <- function(texto) {
  
  if(str_detect(texto, "\\[.*\\]")){
    return('<vertAlign val=\"superscript\"/>')
  } else if (str_detect(texto, "~.*~")) {
    return('<vertAlign val=\"subscript\"/>')
  } else {
    return('')
  }
}

#get text from normal text, sub and sup
get_text_sub_sup <- function(texto) {
  str_remove_all(texto, "\\[|\\]|~")
}

#formating
  if(bold){
    bld <- '<b/>'
  } else{bld <- ''}
  
  if(italic){
    itl <- '<i/>'
  } else{itl <- ''}
  
  if(underlined){
    uld <- '<u/>'
  } else{uld <- ''}
  
#get all properties from one element of texto_separado

get_all_properties <- function(texto) {
  
  paste0('<r><rPr>',
    sub_sup_no(texto),
        sz,
        col,
        rFont,
        fam,
        bld,
        itl,
        uld,
        '</rPr><t xml:space="preserve">',
        get_text_sub_sup(texto),
        '</t></r>')
}


# use above function in texto_separado
newString <- map(texto_separado, ~ get_all_properties(.)) %>% 
  reduce(paste, sep = "") %>% 
  {c("<si>", ., "</si>")} %>% 
  reduce(paste, sep = "")

# replace initial text
  wb$sharedStrings[stringToUpdate] <- newString
}