R Markdown pdf Partially color cell background (da

问题:

Excel has this function called "data bar" that allow conditional formatting based on the cell value with respective length. This function can be done with "formattable" in R using the formatter and color_bar. however, the result of this is a html widget which cannot be shown in pdf.

Here's some options I have tried:

1. webshot: takes a screenshot of the widget and then I can import into pdf as an image. Not very efficient also formattable is not the best option as it doesn't allow for nested tables

2. xtable/pander - doesn't allow me to add conditional formatting

3. kable + kableExtra:

this one I had the most success with. From this code (how can xtable do cell coloring), I could do a conditional formatting but it's not the color bar option and also doesn't allow me to change the width of the column or make any changes as it becomes a hybrid between html and latex in a pdf doc.

HOWEVER, What I really want to do is this: https://tex.stackexchange.com/questions/81994/partially-coloring-cell-background-with-histograms

Essentially I want to be able to have a pdf doc that will show a table that will allow nested table functionality + data bar where it's based on the cell value, and the table can be adjusted for column width or the table can be shrink to fit on one page.

This is what I have right now based on the answers from other code: I want to know how to insert latex code into the lapply function so that it would look like the answer in the second link~

library(knitr)
library(tidyr)
library(kableExtra)
#options(knitr.table.format="latex")
data(mtcars)
tab =mtcars
tab$mpg<-tab$mpg/100

f <- function(x) cut(x, c(0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7,0.8,0.9,1.0), labels=c( "white","green!10", "green!20", "green!30", "green!40", "green!50", "green!60", "green!70","green!80","green!90"),
                  include.lowest = FALSE, right = TRUE)

 tab["mpg"] <- lapply(tab["mpg"], function(x)
                                        paste0("\\cellcolor{", f(x), "}", x))
kable(tab)

回答1:

Thank you for posting such a nice and detailed question. The get_databar function is used to replace one of your columns with new values, for instance

> get_databar(1:5)
[1] "\\databar[white]{1}"    "\\databar[green!30]{2}" "\\databar[green!50]{3}"
[4] "\\databar[green!70]{4}" "\\databar[green!90]{5}"

Simply following your comments, I have adapted the databar https://tex.stackexchange.com/questions/81994/partially-coloring-cell-background-with-histograms, as it is just great, and a bit beyond my latex coding ability.

I have produced two examples of the use of the databar function

The standalone sweave / knitr script is here

\documentclass{article}
\usepackage[table,dvipsnames]{xcolor}% http://ctan.org/pkg/xcolor
\usepackage[nomessages]{fp}% http://ctan.org/pkg/
\begin{document}
<<load_libraries, echo = FALSE, eval = TRUE, results ="hide">>=
library(knitr) 
library(xtable)
@
<<get_databar, echo = FALSE, eval = TRUE, results ="hide">>=
#' @title get_databar creates labels for xtable
#' @description colors labels and assigns max_value to .GlobalEnv
#' @param values the vector of values to cut
#' @param color one color that is interpretable by the xcolor dvips
#' one of 68 standard colors known to dvips  \link{https://en.wikibooks.org/wiki/LaTeX/Colors}, Default: 'green'
#' @param min_value min value in the vector, Default: NULL
#' @param max_value max value in the vector, Default: NULL
#' @param column_width the with of the colum to produce
#' @param transparent, do you want transparent labels for low values, Default: TRUE
#' @return A vector to replace orignial column
get_databar <- function(values,
    color = "green",
    min_value=NULL,
    max_value=NULL,
    column_width=10,
    transparent=TRUE)
{
  if (!is.numeric(values)) stop("values should be a numeric")
  if (is.null(min_value)) min_value <- min(values,na.rm=TRUE)-diff(range(values, na.rm=TRUE))/10
  if (is.null(max_value)) max_value <- max(values,na.rm=TRUE)
  # assign max_value in .GlobalEnv
  maxnum <<- max_value
  # sequence of breaks
  mybreaks <- seq(min_value, max_value, length.out=10)
  if (transparent){
      cols <- c(paste0(color,"!",seq(10, 90, by=10)))
      color_cut_factor <- cut(x=values, 
              breaks = mybreaks,
              labels = cols,
              include.lowest = FALSE,
              right = TRUE)
      color_cut <- as.character(color_cut_factor)
  } else {
      color_cut=rep(color, length(values))
  }
  edited_values <- paste0("\\databar[", color_cut,"]{", values,"}")
  return(as.character(edited_values))
} 
@
<<test, echo = FALSE, eval = TRUE, results ="hide">>=
data(mtcars) 
tab = mtcars 
tab0<-tab[1:10,1:3]
tab2<-tab[1:10,1:3]
tab0[,1]<-get_databar(tab0[,1])
tab2[,1]<-get_databar(tab2[,1],
    color="BlueViolet",
    min_value=0, 
    max_value=max(tab2[,1]),
    transparent = FALSE)
print(xtable(tab0, 
        align = c("l","l","l","l"),
        caption = "standard example"), 
    sanitize.text.function = identity, 
    file="table0_with_bar_colors.tex")
print(xtable(tab2, 
        align = c("l","l","l","l"),
        caption = "example with dvips color BlueViolet and transparent = FALSE"),
    sanitize.text.function = identity,
    file="table2_with_bar_colors.tex")
@
%--------------------------------
% This is the new commands blocks
% The first \maxnum will read from R to get the maximum number in the table
% The second creates the databar command, with two parameters, the first default
% parameter is the color, set to green!25
%--------------------------------------
\newcommand{\maxnum}
{%
    \Sexpr{maxnum}
}
\newlength{\maxlen}
% databar[color]{value}
\newcommand{\databar}[2][green!25]
{%
    \settowidth{\maxlen}{\maxnum}%
    \addtolength{\maxlen}{\tabcolsep}%
     \FPeval\result{round(#2/\maxnum:4)}% 
     \rlap{\color{#1}\hspace*{-.5\tabcolsep}\rule[-.05\ht\strutbox]{\result\maxlen}{.95\ht\strutbox}}%
     \makebox[\dimexpr\maxlen-\tabcolsep][r]{#2}%
}
%--------------------------------------
\input{table0_with_bar_colors.tex}
\input{table2_with_bar_colors.tex}
\end{document}

Should you need to put two tables, then I would be necessary to add, after the next chunk and before the \input for the table the following command (\renewcommand instead of \newcommand)

\renewcommand{\maxnum}
{%
    \Sexpr{maxnum}
}