按類型打印data.frame列和顏色

Question

在我的Knitted文檔中，我正在嘗試打印數據框的列。 為了幫助實現可視化，我想根據另一列的值更改輸出顏色。 我有一個簡單的例子如下。

date_vector <- rep(NA, 10)
type_vector <- rep(NA, 10)
types <- c("A", "B")
CDate <- Sys.Date()
date_vector[1] <- as.character(CDate)
type_vector[1] <- sample(types, size = 1)
for (i in 2:10) {
  CDate <- as.Date(CDate) + rexp(n = 1, rate = 1/5)
  date_vector[i] <- as.character(CDate)
  type_vector[i] <- sample(types, size = 1)
}

test_df <- data.frame(Date=date_vector, Type=type_vector)

當我打印test_df$Date ，我看到以下內容

date_vector
[1] "2016-01-06" "2016-01-07" "2016-01-22" "2016-01-28" "2016-01-29" "2016-02-01" "2016-02-04"
[8] "2016-02-12" "2016-02-13" "2016-02-15"

相反，希望看到以下內容

由於條目的類型如下

type_vector
[1] "A" "A" "B" "B" "A" "A" "B" "A" "B" "A"

因此藍色表示類型A日期，綠色表示類型B日期。

Answer 1

這個答案比問題更普遍。 該問題要求根據另一列為數據框的一列着色。 該答案解決了在向量中突出顯示元素的更一般情況，這取決於指示要突出顯示哪些元素的第二個邏輯向量。

---

原則上，這非常簡單：打印矢量，突出顯示由另一個邏輯矢量指示的元素。 突出顯示x可以像將其包裝在\\\\textcolor{blue}{x}或\\\\emph{x} 。

在實踐中，它並不那么簡單... print(x)做了很多有用的事情：它在列中很好地排列數據，在字符數據周圍添加引號，包裝輸出以尊重getOption("width) ，添加第一個的索引問題是，我們不能使用print來打印突出顯示的數據，因為print轉義\\\\textcolor的反斜杠。這個問題的標准解決方案是使用cat而不是print 。但是， cat不應用上面列出的任何好的格式。

因此，挑戰在於編寫一個能夠再現某些/所需print功能的功能。 這是一個非常復雜的任務，因此我將自己局限於以下主要功能：

• 總線寬<= getOption("width") 。
• 自動在非數字和非邏輯值周圍添加引號（如果未設置quote ）。
• 將第一個元素的索引添加到每行輸出（如果printIndex = TRUE ）。
• 將舍入應用於數字輸入（ digits ）。

另外，這兩個突出特點：

• 用“突出顯示模式”中的condition表示x元素包裹
• 計算線寬時，請勿考慮突出顯示模式。 這假設突出顯示僅添加標記但沒有可見輸出。

請注意，此功能缺少print重要功能，如處理缺失值。 此外，它將輸入x轉換為字符（通過as.character ）。 其結果可能與print不同，因為根本不使用與輸入類對應的S3方法（ print.* ）。

printHighlighted <- function(x, condition = rep(FALSE, length(x)), highlight = "\\emph{%s}", printIndex = TRUE, width = getOption("width"), digits = getOption("digits"), quote = NULL) {

  stopifnot(length(x) == length(condition))
  stopifnot(missing(digits) || (!missing(digits) && is.numeric(x))) # Raise error when input is non-numeric but "digits" supplied.

  if (missing(quote)) {
    if (is.numeric(x) || is.logical(x)) {
      quote <- FALSE
    } else {
      quote <- TRUE
    }
  }

  nquotes <- 0

  if (!printIndex) {
    currentLineIndex <- ""
  }

  if (is.numeric(x)) {
    x <- round(x, digits = digits)
  }

  fitsInLine <- function(x, elementsCurrentLine, currentLineIndex, nquotes, width) {
    return(sum(nchar(x[elementsCurrentLine])) + # total width of elements in current line
             nchar(currentLineIndex) + # width of the index of the first element (if shown)
             sum(elementsCurrentLine) - 1 + # width of spaces between elements
             nquotes <= # width of quotes added around elements
             width)
  }

  x <- as.character(x)
  elementsCurrentLine <- rep(FALSE, times = length(x))


  for (i in seq_along(x)) {

    if (!any(elementsCurrentLine) && printIndex) { # this is a new line AND show index
      currentLineIndex <- sprintf("[%s] ", i)
    }

    elementsCurrentLine[i] <- TRUE # Add element i to current line. Each line holds at least one element. Therefore, if i is the first element of this line, add it regardless of line width. If there already are elements in the line, the previous loop iteration checked that this element will fit.

    if (i < length(x)) { # not the last element

      # check whether next element will fit in this line
      elementsCurrentLineTest <- elementsCurrentLine
      elementsCurrentLineTest[i + 1] <- TRUE

      if (quote) {
        nquotes <- sum(elementsCurrentLineTest) * 2
      }

      if (fitsInLine(x, elementsCurrentLineTest, currentLineIndex, nquotes, width)) {
        next # Next element will fit; do not print yet.
      }
    }

    # Next element won't fit in current line. Print and start a new line.

    # print
    toPrint <- x[elementsCurrentLine]
    toMarkup <- condition[elementsCurrentLine]

    toPrint[toMarkup] <- sprintf(fmt = highlight, toPrint[toMarkup]) # add highlighting

    if (quote) {
      toPrint <- sprintf('"%s"', toPrint)
    }

    cat(currentLineIndex)
    cat(toPrint)
    cat("\n")

    # clear line
    elementsCurrentLine <- rep(FALSE, times = length(x))
  }
}

要在knitr使用此函數，必須使用塊選項 results = "asis" ，否則輸出將包含在verbatim環境中，其中顯示負責突出顯示的標記而不是使用 。

最后，為了重現普通塊的外觀，將整個塊包裹起來

\begin{knitrout}
\definecolor{shadecolor}{rgb}{0.969, 0.969, 0.969}\color{fgcolor}
\begin{kframe}
\begin{alltt}
<<your-chunk>>=
printHighlighted(...)
@
\end{alltt}
\end{kframe}
\end{knitrout}

例

為了節省一些空間，該示例假定printHighlighted的函數定義在文件printHighlighted.R可用。

\documentclass{article}
\begin{document}

Some text ....

\begin{knitrout}\definecolor{shadecolor}{rgb}{0.969, 0.969, 0.969}\color{fgcolor}\begin{kframe}\begin{alltt}
<<results = "asis", echo = FALSE>>=
source("printHighlighted.R")
data <- seq(from = as.Date("2015-01-15"), by = "day", length.out = 100)
cond <- rep(FALSE, 100)
cond[c(3, 55)] <- TRUE

printHighlighted(x = data, condition = cond, highlight = "\\textcolor{blue}{%s}", width = 60)
@
\end{alltt}\end{kframe}\end{knitrout}

Some text ....

\end{document}

---

事實證明這是相當長的......如果有人認為這對於這么簡單的問題來說太過分了，我很樂意看到更短的解決方案。