【Rmarkdown】kableのfootnote_marker_alphabet()の順番をzからaに変更する

Rmarkdown

R Markdownで表を作成するときに便利なのが、kablekableExtraパッケージです。これらを使うと、見やすい表にフットノートを簡単に追加できます。

その際、footnote_marker_〇〇()関数を使うと、脚注マーカーとして数字・記号・アルファベットを指定できます。

しかし、アルファベットマーカーは通常「a → z」方向に付与されるため、「z → aの逆順でマーカーを付けたい」と思った方もいるかもしれません。

今回は、footnote_marker_alphabet()footnote()関数を改造してPDF出力時にフットノートマーカーを z から a の順で表示する方法を紹介します。

ソースコードを確認

まずは、footnote_marker_alphabet()footnote()関数の内部処理を理解するために、kableExtraのソースコードを確認します。

kableExtra source: R/footnote.R
R/footnote.R defines the following functions: latex_tfoot_maker_tpt_ latex_tfoot_maker_ latex_tfoot_maker footnote_latex...
kableExtra source: R/footnote_marker.R
R/footnote_marker.R defines the following functions: footnote_marker_symbol footnote_marker_alphabet footnote_marker_num...

footnote_marker_alphabet()footnote_table_maker()関数では、アルファベットマーカーを付与する際にletters を参照しています。

footnote_marker_alphabet <- function(x, format, double_escape = FALSE) {
  if (missing(format) || is.null(format)) {
    if (knitr::is_latex_output()) {
      format <- "latex"
    } else {
      format <- "html"
    }
  }
  if (is.numeric(x)) x <- letters[x]
  if (format == "html") {
    return(paste0("<sup>", x, "</sup>"))
  } else if (!double_escape) {
    return(paste0("\\textsuperscript{", x, "}"))
  } else {
    return(paste0("\\\\textsuperscript{", x, "}"))
  }
}
footnote_table_maker <- function(format, footnote_titles, footnote_contents,
                                 symbol_manual) {
  if (is.null(symbol_manual)) {
    number_index <- read.csv(system.file("symbol_index.csv",
                                         package = "kableExtra"))
    if (format == "latex") {
      symbol_index <- number_index$symbol.latex
    } else {
      symbol_index <- number_index$symbol.html
    }
  } else {
    symbol_index <- symbol_manual
  }
  
  
  if (!is.null(footnote_contents$general)) {
    footnote_contents$general <- data.frame(
      index = "",
      footnote = footnote_contents$general
    )
  }
  if (!is.null(footnote_contents$number)) {
    footnote_contents$number <- data.frame(
      index = as.character(1:length(footnote_contents$number)),
      footnote = footnote_contents$number
    )
  }
  if (!is.null(footnote_contents$alphabet)) {
    footnote_contents$alphabet <- data.frame(
      index = letters[1:length(footnote_contents$alphabet)],
      footnote = footnote_contents$alphabet
    )
  }
  if (!is.null(footnote_contents$symbol)) {
    footnote_contents$symbol <- data.frame(
      index = symbol_index[1:length(footnote_contents$symbol)],
      footnote = footnote_contents$symbol
    )
  }
  
  out <- list()
  out$contents <- footnote_contents
  out$titles <- footnote_titles
  return(out)
}

このベクトルを単純に rev() 関数で反転させることでz → a 方向へのマーカー付与が可能になりそうです。

書き換え

新しいスクリプトを用意して、kableExtraの内部関数を.GlobalEnvにロード

# 全内部関数をグローバル環境にロード
invisible(
  lapply(
    ls(namespace <- getNamespace("kableExtra"),
       all.names = TRUE),
    function(f) assign(f,
                       get(f, envir = namespace),
                       envir = .GlobalEnv)
    )
  )

次に、元関数と競合を避けるためにfootnote_marker_alphabet_revとして関数を定義し、lettersをrev(letters)に変更

# 
footnote_marker_alphabet_rev <- function(x, format, double_escape = FALSE) {
  if (missing(format) || is.null(format)) {
    if (knitr::is_latex_output()) {
      format <- "latex"
    } else {
      format <- "html"
    }
  }
  if (is.numeric(x)) x <- rev(letters)[x]
  if (format == "html") {
    return(paste0("<sup>", x, "</sup>"))
  } else if (!double_escape) {
    return(paste0("\\textsuperscript{", x, "}"))
  } else {
    return(paste0("\\\\textsuperscript{", x, "}"))
  }
}

同じように、footnote_revを定義して、footnote_table_makerrev(letters)をセットしたfootnote_table_maker_revに入れ替え

footnote_rev <- function(kable_input,
                     general = NULL,
                     number = NULL,
                     alphabet = NULL,
                     symbol = NULL,
                     footnote_order = c("general", "number",
                                        "alphabet", "symbol"),
                     footnote_as_chunk = FALSE,
                     escape = TRUE,
                     threeparttable = FALSE,
                     fixed_small_size = FALSE,
                     general_title = "Note: ",
                     number_title = "",
                     alphabet_title = "",
                     symbol_title = "",
                     title_format = "italic",
                     symbol_manual = NULL
) {
  kable_format <- attr(kable_input, "format")
  if (kable_format %in% c("pipe", "markdown")) {
    kable_input <- md_table_parser(kable_input)
    kable_format <- attr(kable_input, "format")
  }
  if (!kable_format %in% c("html", "latex")) {
    warning("Please specify format in kable. kableExtra can customize either ",
            "HTML or LaTeX outputs. See https://haozhu233.github.io/kableExtra/ ",
            "for details.")
    return(kable_input)
  }
  if (length(alphabet) > 26) {
    alphabet <- alphabet[1:26]
    warning("Please don't use more than 26 footnotes in table_footnote ",
            "alphabet. Use number instead.")
  }
  if (length(symbol) > 20) {
    symbol <- symbol[1:20]
    warning("Please don't use more than 20 footnotes in table_footnote ",
            "symbol. Use number instead.")
  }
  footnote_titles <- list(
    general = general_title, number = number_title,
    alphabet = alphabet_title, symbol = symbol_title
  )
  footnote_contents <- list(
    general = general, number = number, alphabet = alphabet, symbol = symbol
  )
  notnull <- names(footnote_contents)[!sapply(footnote_contents, is.null)]
  if (length(notnull) == 0) {return(kable_input)}
  footnote_order <- footnote_order[footnote_order %in% notnull]
  footnote_titles <- footnote_titles[footnote_order]
  footnote_contents <- footnote_contents[footnote_order]
  if (escape) {
    if (kable_format == "html") {
      footnote_contents <- lapply(footnote_contents, escape_html)
      footnote_titles <- lapply(footnote_titles, escape_html)
    } else {
      footnote_contents <- lapply(footnote_contents, escape_latex2)
      footnote_contents <- lapply(footnote_contents, linebreak)
      footnote_titles <- lapply(footnote_titles, escape_latex2)
      footnote_titles <- lapply(footnote_titles, linebreak)
    }
  }
  title_format <- match.arg(title_format, c("italic", "bold", "underline"),
                            several.ok = TRUE)
  footnote_titles <- lapply(footnote_titles, footnote_title_format,
                            kable_format, title_format)
  footnote_table <- footnote_table_maker_rev(
    kable_format, footnote_titles, footnote_contents, symbol_manual
  )
  if (kable_format == "html") {
    return(footnote_html(kable_input, footnote_table, footnote_as_chunk))
  }
  if (kable_format == "latex") {
    return(footnote_latex(kable_input, footnote_table, footnote_as_chunk,
                          threeparttable, fixed_small_size))
  }
}

footnote_title_format <- function(x, format, title_format) {
  if (x == "") return(x)
  if (format == "html") {
    title_style <- ""
    if ("italic" %in% title_format) {
      title_style <- paste0(title_style, "font-style: italic;")
    }
    if ("bold" %in% title_format) {
      title_style <- paste0(title_style, "font-weight: bold;")
    }
    if ("underline" %in% title_format) {
      title_style <- paste0(title_style, "text-decoration: underline;")
    }
    return(paste0(
      '<span style="', title_style, '">', x, '</span>'
    ))
  } else {
    if ("italic" %in% title_format) {
      x <- paste0("\\\\textit\\{", x, "\\}")
    }
    if ("bold" %in% title_format) {
      x <- paste0("\\\\textbf\\{", x, "\\}")
    }
    if ("underline" %in% title_format) {
      x <- paste0("\\\\underline\\{", x, "\\}")
    }
    return(x)
  }
}

footnote_table_maker_rev <- function(format, footnote_titles, footnote_contents,
                                 symbol_manual) {
  if (is.null(symbol_manual)) {
    number_index <- read.csv(system.file("symbol_index.csv",
                                         package = "kableExtra"))
    if (format == "latex") {
      symbol_index <- number_index$symbol.latex
    } else {
      symbol_index <- number_index$symbol.html
    }
  } else {
    symbol_index <- symbol_manual
  }
  
  
  if (!is.null(footnote_contents$general)) {
    footnote_contents$general <- data.frame(
      index = "",
      footnote = footnote_contents$general
    )
  }
  if (!is.null(footnote_contents$number)) {
    footnote_contents$number <- data.frame(
      index = as.character(1:length(footnote_contents$number)),
      footnote = footnote_contents$number
    )
  }
  if (!is.null(footnote_contents$alphabet)) {
    # 逆順のアルファベット (z to a) を使用
    footnote_contents$alphabet <- data.frame(
      index = rev(letters)[1:length(footnote_contents$alphabet)],
      footnote = footnote_contents$alphabet
    )
  }
  if (!is.null(footnote_contents$symbol)) {
    footnote_contents$symbol <- data.frame(
      index = symbol_index[1:length(footnote_contents$symbol)],
      footnote = footnote_contents$symbol
    )
  }
  
  out <- list()
  out$contents <- footnote_contents
  out$titles <- footnote_titles
  return(out)
}

# HTML
footnote_html <- function(kable_input, footnote_table, footnote_as_chunk) {
  kable_attrs <- attributes(kable_input)
  important_nodes <- read_kable_as_xml(kable_input)
  body_node <- important_nodes$body
  kable_xml <- important_nodes$table
  
  new_html_footnote <- html_tfoot_maker(footnote_table, footnote_as_chunk)
  xml_add_child(kable_xml, new_html_footnote)
  xml2::xml_set_attr(kable_xml, "style",
                     paste0(xml2::xml_attr(kable_xml, "style"),
                            "border-bottom: 0;"))
  out <- as_kable_xml(body_node)
  attributes(out) <- kable_attrs
  if (!"kableExtra" %in% class(out)) class(out) <- c("kableExtra", class(out))
  return(out)
}

html_tfoot_maker <- function(footnote_table, footnote_as_chunk) {
  footnote_types <- names(footnote_table$contents)
  footnote_text <- c()
  for (i in footnote_types) {
    footnote_text <- c(footnote_text, html_tfoot_maker_(
      footnote_table$contents[[i]], footnote_table$titles[[i]], i,
      footnote_as_chunk))
  }
  footnote_text <- paste0(
    "<tfoot>", paste0(footnote_text, collapse = ""), "</tfoot>"
  )
  footnote_node <- read_html(footnote_text, options = c("RECOVER", "NOERROR"))
  return(xml_child(xml_child(footnote_node, 1), 1))
}

html_tfoot_maker_ <- function(ft_contents, ft_title, ft_type, ft_chunk) {
  footnote_text <- apply(ft_contents, 1, function(x) {
    paste0('<sup>', x[1], '</sup> ', x[2])
  })
  if (ft_title != "") {
    title_text <- ft_title
    footnote_text <- c(title_text, footnote_text)
  }
  if (!ft_chunk) {
    footnote_text <- paste0(
      '<tr><td style="padding: 0; " colspan="100%">',
      footnote_text, '</td></tr>'
    )
  } else {
    footnote_text <- paste0(
      '<tr><td style="padding: 0; " colspan="100%">',
      paste0(footnote_text, collapse = " "),
      '</td></tr>'
    )
  }
  return(footnote_text)
}

# LaTeX
footnote_latex <- function(kable_input, footnote_table, footnote_as_chunk,
                           threeparttable, fixed_small_size) {
  table_info <- magic_mirror(kable_input)
  out <- solve_enc(kable_input)
  
  footnote_text <- latex_tfoot_maker(footnote_table, footnote_as_chunk,
                                     table_info$ncol, threeparttable)
  if (threeparttable) {
    if (table_info$tabular %in% c("longtable", "longtabu") ) {
      out <- sub(paste0("\\\\begin\\{", table_info$tabular, "\\}"),
                 paste0("\\\\begin{ThreePartTable}\n\\\\begin{TableNotes}",
                        ifelse(footnote_as_chunk, "[para]", ""),
                        ifelse(fixed_small_size,"\n\\\\small\n","\n"), footnote_text,
                        "\n\\\\end{TableNotes}\n\\\\begin{",
                        table_info$tabular, "}"),
                 out)
      out <- sub(paste0("\\\\end\\{",table_info$tabular, "\\}"),
                 paste0("\\\\end{", table_info$tabular,
                        "}\n\\\\end{ThreePartTable}"),
                 out)
      if (table_info$booktabs) {
        out <- sub(bottomrule_regexp, "\\1\n\\\\insertTableNotes", out)
      } else {
        out <- sub("\\\\hline\n\\\\end\\{longtable\\}",
                   "\\\\hline\n\\\\insertTableNotes\n\\\\end\\{longtable\\}",
                   out)
      }
    } else {
      if (table_info$tabular == "tabu") {
        stop("Please use `longtable = T` in your kable function. ",
             "Full width threeparttable only works with longtable.")
      }
      out <- sub(paste0("\\\\begin\\{", table_info$tabular, "\\}"),
                 paste0("\\\\begin{threeparttable}\n\\\\begin{",
                        table_info$tabular, "}"),
                 out)
      out <- sub(table_info$end_tabular,
                 paste0("\\\\end{", table_info$tabular,
                        "}\n\\\\begin{tablenotes}",
                        ifelse(footnote_as_chunk, "[para]", ""),
                        ifelse(fixed_small_size,"\n\\\\small\n","\n"), footnote_text,
                        "\n\\\\end{tablenotes}\n\\\\end{threeparttable}"),
                 out)
    }
  } else {
    if (table_info$booktabs) {
      out <- sub(bottomrule_regexp,
                 paste0("\\1\n", footnote_text), out)
    } else {
      out <- sub(table_info$end_tabular,
                 paste0(footnote_text, "\n\\\\end{", table_info$tabular, "}"),
                 out)
    }
  }
  
  out <- structure(out, format = "latex", class = "knitr_kable")
  attr(out, "kable_meta") <- table_info
  return(out)
}

latex_tfoot_maker <- function(footnote_table, footnote_as_chunk, ncol,
                              threeparttable) {
  footnote_types <- names(footnote_table$contents)
  footnote_text <- c()
  if (threeparttable) {
    for (i in footnote_types) {
      footnote_text <- c(footnote_text, latex_tfoot_maker_tpt_(
        footnote_table$contents[[i]], footnote_table$titles[[i]],
        footnote_as_chunk, ncol))
    }
  } else {
    for (i in footnote_types) {
      footnote_text <- c(footnote_text, latex_tfoot_maker_(
        footnote_table$contents[[i]], footnote_table$titles[[i]],
        footnote_as_chunk, ncol))
    }
  }
  footnote_text <- paste0(footnote_text, collapse = "\n")
  return(footnote_text)
}

latex_tfoot_maker_ <- function(ft_contents, ft_title, ft_chunk, ncol) {
  footnote_text <- apply(ft_contents, 1, function(x) {
    if (x[1] == "") {
      x[2]
    } else {
      paste0('\\\\textsuperscript{', x[1], '} ', x[2])
    }
  })
  if (ft_title != "") {
    title_text <- ft_title
    footnote_text <- c(title_text, footnote_text)
  }
  if (!ft_chunk) {
    footnote_text <- paste0(
      '\\\\multicolumn{', ncol, '}{l}{\\\\rule{0pt}{1em}', footnote_text, '}\\\\\\\\'
    )
  } else {
    footnote_text <- paste0(
      '\\\\multicolumn{', ncol, '}{l}{\\\\rule{0pt}{1em}',
      paste0(footnote_text, collapse = " "),
      '}\\\\\\\\'
    )
  }
  return(footnote_text)
}

latex_tfoot_maker_tpt_ <- function(ft_contents, ft_title, ft_chunk, ncol) {
  footnote_text <- apply(ft_contents, 1, function(x) {
    if (x[1] == "") {
      paste0('\\\\item ', x[2])
    } else {
      paste0('\\\\item[', x[1], '] ', x[2])
    }
  })
  if (ft_title != "") {
    title_text <- paste0('\\\\item ', ft_title, ' ')
    footnote_text <- c(title_text, footnote_text)
  }
  footnote_text <- paste0(footnote_text, collapse = "\n")
  # if (!ft_chunk) {
  #   footnote_text <- paste0(footnote_text, collapse = "\n")
  # } else {
  #   footnote_text <- paste0(footnote_text, collapse = " ")
  # }
  return(footnote_text)
}

作成したスクリプトは保存して、Rmarkdownファイルのsetupチャンクで読み込みます

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
source("~footnote_rev.R")
```

表出力の確認

```{r labelname1, echo=FALSE, warning=FALSE, message=FALSE, results='asis'}
#Input data
data <- data.frame(col1 = c(letters[1:4]),
                   col2 = c(1:4))
colnames(data)[1] <- paste0(colnames(data)[1], footnote_marker_alphabet_rev(1))
colnames(data)[2] <- paste0(colnames(data)[2], footnote_marker_alphabet_rev(2))
                   
#Table output
data %>% 
  kable(
    format = "latex",
    escape = FALSE,
    caption = "\\label{labelname1}タイトルをここに入れてください.",
    booktabs = TRUE,
    align = "c",
    linesep = ""
    ) %>%
  kable_styling(
    latex_options = "hold_position",
    position = "left",
    full_width = FALSE
    ) %>% 
  column_spec(
    1:length(data),
    width = c("7.5cm","7.5cm"),
    latex_valign = "m"
    ) %>% 
  footnote_rev(
    general_title = "",
    general = c(
      "フットノート1をここに入力",
      "フットノート2をここに入力."),
    alphabet = c("zから始まる","yから始まる")
    ) %>% 
  print()
```

PDF出力では正常に動作し、脚注マーカーがz, y, x…と逆順に表示されました。

なお、HTML出力での挙動は未確認です。


この記事が、どなたかの研究や制作の一助になれば幸いです。

広告

Amazonアフィリエイトでブログ運営しています。
応援いただけると嬉しいです。


ネスカフェ 香味焙煎 ひとときの贅沢 スティック ブラック 20P,箱,レギュラー ソリュブル コーヒー,個包装


AHMAD TEA(アーマッドティー) クラシックセレクション ティーバッグ 20袋

タイトルとURLをコピーしました