Related
Is it possible to choose your own color for a cell when creating a table using kable.
In the folowing code from the kable documentation, it shows how you can choose a spectrum (from a couple of options) of colors for a row or column, but I want 1 color for 1 cell. That I can export to a PDF, using knitr.
vs_dt <- iris[1:10, ]
vs_dt[5] <- cell_spec(vs_dt[[5]], color = "white", bold = T,
background = spec_color(1:10, end = 0.9, option = "D", direction = -1))
15
kbl(vs_dt, booktabs = T, escape = F, align = "c")
Thank you
If you would only need 1 color for 1 cell, you can specify the row and column of that cell to be modified.
vs_dt <- iris[1:10, ]
#needed as they are factors
vs_dt$Species <- as.character(vs_dt$Species)
#only the first entry of the Species column
vs_dt[1,5] <- cell_spec(vs_dt[1,5], color = "white", bold = T,
background = "red")
# you can also change some of them excluding the cell.
vs_dt[2:10,5] <- cell_spec(vs_dt[2:10,5], bold = T)
kbl(vs_dt, booktabs = T, escape = F, align = "c")
I am trying to generate a heatmap as the following figure. I have already tried pheatmap and the code is as follows:
breaks_2 <- seq(min(0), max(2), by = 0.1)
pheatmap::pheatmap(
mat = data,
cluster_cols = F,
cluster_rows = F,
scale = "column",
border_color = "white",
color = inferno(20),
show_colnames = TRUE,
show_rownames = FALSE,
breaks = breaks_2
)
But this does not seem to work. So far I am understanding I am mistaking with defining break or have to use another package than pheatmap. Any suggestion will be really helpful.
The color scale in pheatmap adjusts to the range of the input data. If you want anything above a certain value to be coloured daffodil, then simply send pheatmap a copy of your data with the highest values rounded to 2.
Suppose you have a data frame like this, with values anywhere between 0 and 3:
set.seed(1)
data <- as.data.frame(matrix(runif(64, 0, 3), nrow = 8))
names(data) <- LETTERS[1:8]
data
#> A B C D E F G H
#> 1 0.7965260 1.8873421 2.1528555 0.801662 1.4806239 2.46283888 2.1969412 0.9488151
#> 2 1.1163717 0.1853588 2.9757183 1.158342 0.5586528 1.94118058 2.0781947 1.5559028
#> 3 1.7185601 0.6179237 1.1401055 0.040171 2.4821200 2.34879829 1.4328589 1.9860152
#> 4 2.7246234 0.5296703 2.3323357 1.147164 2.0054002 1.65910893 2.5836284 1.2204906
#> 5 0.6050458 2.0610685 2.8041157 2.609073 2.3827196 1.58915874 1.3142913 2.7386278
#> 6 2.6951691 1.1523112 0.6364276 1.021047 0.3238309 2.36806870 0.7343918 0.8808101
#> 7 2.8340258 2.3095243 1.9550213 1.446240 2.1711328 0.06999361 0.2120371 1.3771972
#> 8 1.9823934 1.4930977 0.3766653 1.798697 1.2338233 1.43169020 0.2983985 0.9971840
Some of the values are greater than two. We want all of these to appear the same colour on our heatmap, so we create a copy of our data for plotting, and round down all of the values that were greater than 2 to be exactly 2:
data_2 <- data
data_2[] <- lapply(data_2, function(x) { x[x > 2] <- 2; x })
So now if we run pheatmap on data_2, we see that all the values that were greater than 2 in our original data frame are coloured daffodil.
library(viridis)
library(pheatmap)
breaks_2 <- seq(0, 2, by = 0.1)
pheatmap(
mat = data_2,
cluster_cols = F,
cluster_rows = F,
border_color = "white",
scale = 'none',
color = inferno(22),
show_colnames = TRUE,
show_rownames = FALSE,
legend_breaks = breaks_2
)
I have an R list that contains 2500 lists in it. Each of 2500 lists contain 1 vector and 2 values. For the sake of reproducibility, I subset a tiny version of the data so it looks something like this:
head(models, 1)
>$model_1
>$model_1$m
> [1] 0.01335775 0.01336487 0.01336805 0.01338025 0.01340532 0.01343117 0.01346120 0.01349530 0.01353788 > 0.01357654 0.01360668
>$model_1$Cab
>[1] 59.6774
>$model_1$LAI
>[1] 4.01739
>$model_2
>$model_2$m
> [1] 0.02367338 0.02360433 0.02352800 0.02346125 0.02339469 0.02333403 0.02325861 0.02317945 0.02310961 >0.02303802 0.02295710
>$model_2$Cab
>[1] 59.6774
>$model_2$LAI
>[1] 0.5523946
Now, I want to make a line plot (using ggplot2) whose x axis is values from 400 to 410 and y axis is the vector in each lists (models$model_1$m, models$model_2$m and so on.) Therefore, there will be a lot of lines in the plot. I also want to color (continuous coloring) each line with their respective models$model_2$Cab values and have a continuous legend showing each models$model_2$Cab value and its color.
For reproducibility (Please note that this is greatly simplified version of the original data):
> dput(head(models, 10))
list(model_1 = list(m = c(0.0133577497667816, 0.0133648693063468,
0.0133680481888036, 0.01338024983382, 0.0134053218864944, 0.0134311717034271,
0.0134612003419723, 0.0134953017438241, 0.0135378825635721, 0.0135765418166368,
0.0136066826886183), Cab = 59.6773970406502, LAI = 4.01739045299768),
model_2 = list(m = c(0.023673375903171, 0.0236043348551818,
0.0235280045196734, 0.0234612496831449, 0.0233946873132861,
0.0233340349230324, 0.0232586128971129, 0.0231794538902946,
0.0231096074536893, 0.023038021285693, 0.0229570982021948
), Cab = 59.6773970406502, LAI = 0.552394618641403), model_3 = list(
m = c(0.0138277418755234, 0.0138310132688916, 0.0138301891768216,
0.0138383905159343, 0.0138587906203227, 0.0138802253169266,
0.0139048786261519, 0.0139332011615252, 0.0139700189737812,
0.0140030367215791, 0.0140275202380309), Cab = 59.6773970406502,
LAI = 3.01987725977579), model_4 = list(m = c(0.017483089696901,
0.0174591709902523, 0.017429967081058, 0.0174099884420304,
0.0173976896061841, 0.0173882607103241, 0.0173752969257632,
0.0173632160871019, 0.0173599236031355, 0.0173536114293099,
0.0173384748063733), Cab = 59.6773970406502, LAI = 1.37503600459533),
model_5 = list(m = c(0.0182499047037402, 0.0182203724940146,
0.0181853063358603, 0.0181595102703982, 0.0181404648083386,
0.0181246681180869, 0.0181039409709977, 0.01808352264341,
0.0180719579429791, 0.018057532687598, 0.0180342187796566
), Cab = 59.6773970406502, LAI = 1.22529135635182), model_6 = list(
m = c(0.0158200567917405, 0.0158083674745268, 0.0157919331298277,
0.0157846269346119, 0.0157870246965916, 0.0157914665730281,
0.0157954117645301, 0.0158014906653224, 0.0158162176575737,
0.0158275775312257, 0.0158302513933357), Cab = 59.6773970406502,
LAI = 1.81571552453658), model_7 = list(m = c(0.0133628950691214,
0.0133699680411211, 0.0133730986417069, 0.0133852517083498,
0.0134102666346747, 0.0134360623898904, 0.0134660252680654,
0.0135000559061319, 0.0135425658393117, 0.013581155812944,
0.013611227528355), Cab = 59.6773970406502, LAI = 3.99643688124574),
model_8 = list(m = c(0.0183501671255408, 0.0183199017377111,
0.0182840698901064, 0.0182575139774255, 0.0182375872739662,
0.0182209588085648, 0.0181992175650369, 0.0181777101462036,
0.0181650648958527, 0.0181495798700031, 0.0181251977995322
), Cab = 59.6773970406502, LAI = 1.20735517669905), model_9 = list(
m = c(0.0143687162679524, 0.0143678440890305, 0.0143626995592654,
0.0143666036037224, 0.0143820089259476, 0.0143987279254991,
0.0144176359711743, 0.0144397860850458, 0.0144704682720878,
0.0144974726755733, 0.0145159061770205), Cab = 59.6773970406502,
LAI = 2.51320168699674), model_10 = list(m = c(0.0138736072820698,
0.0138765215672426, 0.0138753253418108, 0.0138831561248062,
0.0139031250366076, 0.0139241525443688, 0.0139483098566198,
0.0139760994306543, 0.0140123870383231, 0.0140448852992375,
0.0140688465774421), Cab = 59.6773970406502, LAI = 2.96397596054064))
What I want to achieve is something like this (but with a better-looking ggplot2):
This could be achieved like so:
Convert your list of lists to a list of dataframes.
Add a variable with your x-axis variable to each df
Bind the list of data frames by row
Plot, where I make use of scale_colour_gradientn(colors = rainbow(20)) to mimic your rainbow color scale.
library(dplyr)
library(ggplot2)
models <- lapply(models, as.data.frame) %>%
lapply(function(x) { x$x <- 400:410; x}) %>%
bind_rows(.id = "id")
ggplot(models, aes(x = x, y = m, color = LAI, group = id)) +
geom_line() +
scale_x_continuous(breaks = scales::pretty_breaks()) +
scale_colour_gradientn(colors = rainbow(20))
I have this code in R to tabulate a frequency table:
TablaFrecs = function(x,k,A,p){
options(scipen=999)
L = min(x)-p/2+A*(0:k)
x_cut = cut(x, breaks = L, right=FALSE)
intervals = levels(x_cut)
mc = (L[1]+L[2])/2+A*(0:(k-1))
Fr.abs = as.vector(table(x_cut))
Fr.rel = round(Fr.abs/length(x),4)
Fr.cum.abs = cumsum(Fr.abs)
Fr.cum.rel = cumsum(Fr.rel)
tabla = data.frame(intervals, mc, Fr.abs, Fr.cum.abs, Fr.rel, Fr.cum.rel)
tabla
}
but it shows the intervals in scientific notation
The ej 9 it's this:
I'm usingthe OFF.COURSE Variable
I've tried options(scipen=999) and format(scientific = F) but is doesn´t solves it.
PD: I also want to make an hist() of my TablaFrecs function, how can I do it?
You could use mapply and format to create the labels:
TablaFrecs = function(x,k,A,p){
options(scipen=999)
L = min(x)-p/2+A*(0:k)
labels = mapply(function(x,y){paste0("[",format(x),",",format(y),")")},L[-length(L)],L[-1])
x_cut = cut(x,
breaks = L ,
labels = labels,
right=FALSE)
intervals = levels(x_cut)
mc = (L[1]+L[2])/2+A*(0:(k-1))
Fr.abs = as.vector(table(x_cut))
Fr.rel = round(Fr.abs/length(x),4)
Fr.cum.abs = cumsum(Fr.abs)
Fr.cum.rel = cumsum(Fr.rel)
tabla = data.frame(intervals, mc, Fr.abs, Fr.cum.abs, Fr.rel, Fr.cum.rel)
tabla
}
TablaFrecs(1e6, k= 27, A = 3646296, p= 0.1)
intervals mc Fr.abs Fr.cum.abs Fr.rel Fr.cum.rel
1 [999999.9,4646296) 2823148 1 1 1 1
2 [4646296,8292592) 6469444 0 1 0 1
3 [8292592,11938888) 10115740 0 1 0 1
...
Is it possible to generate a table in R with multiple rows correspondng to a single row? And write the resultant table to a pdf. The sample table is as below.
Is it possible to join two seperate tables in the way showed in the image.
Sample code for the two tables are given below
tab1="Test Description
1 test1 description
2 test2 description"
table1 <-read.table(text = tab1,header = TRUE)
tab21="Cause Probability Feedback
1 cause1 .5 positive
2 Cause2 .2 negative
3 Cause3 .1 negative
4 Cause4 .2 negative"
table2 <-read.table(text = tab21,header = TRUE)
tab22="Cause Probability Feedback
1 cause1 .7 positive
2 Cause2 .2 negative
3 Cause3 .1 negative"
table3 <-read.table(text = tab22,header = TRUE)
It is a little bit tricky, but I'd take advantage of the fact that cells with NAs are printed as empty by the print.xtable-function. The cells are not truly 'merged', but it looks like it when the contents are aligned to the top.
Basically the steps are:
Generate a suitable data.frame in R
Print this as a .tex compatible table using print.xtable from the package 'xtable'
Use Sweave/knitr/etc to generate a suitable .tex
tools::texi2pdf will then convert your .tex to a suitable .pdf
Here are the files, you need to only source the RunSweave.R in your R terminal (and make sure you have LaTeX installed along with the required packages, i.e. 'xtable and have the files in a single folder; this was run in Windows).
File StackExampleCode.R:
# StackExampleCode.R
library(xtable)
# A work-around by setting rows in the multi-row to NA after the initial top-justified line
header <- data.frame(test = "Tests", det = "Details", cause = "Cause", prob = "Probability", fb = "Feedback")
# Filling the fields for these is something you'd probably want to do in R in a more sophisticated manner
test1 <- data.frame(
test = c("Test 1", NA, NA, NA, NA),
det = c("Description", NA, NA, NA, NA),
cause = c("Cause 1", NA, paste("Cause", 2:4)),
prob = c(".5", NA, ".2", ".1", ".2"),
fb = c("positive", NA, "negative", "negative", "negative")
)
test2 <- data.frame(
test = c("Test 2", NA, NA, NA),
det = c("Description", NA, NA, NA),
cause = c(paste("Cause", 1:3), NA),
prob = c(".7", ".1", ".2", NA),
fb = c("positive", "negative", "negative", NA)
)
# Bind it all together, you probably want something similar if it's automatic data you're generating
tab <- rbind(header, test1, test2)
File StackExampleRnw.Rnw:
% StackExampleRnw.Rnw
% Note the different comment char, writing .tex here
\documentclass{article}
\begin{document}
<<echo=FALSE, results=tex>>=
# Printing the table
print(
xtable(tab,
align = "|l|l|l|l|l|l|" # Create the desired vertical lines and text alignments ala LaTeX; left align with vertical lines in-between each column)
),
add.to.row = list( # Add horizontal lines to correct spots, should be adjusted according to the desired data
pos = list(-1, 1, 6, nrow(tab)),
command = c("\\hline \n", "\\hline \n", "\\hline \n", "\\hline \n") # Horizontal lines and a neater formatting of output using a linechange
),
include.rownames = FALSE, # Don't include the rownames (which would be just numbers)
include.colnames = FALSE, # Don't include the rownames, these were already included as if it was an ordinary table row
hline.after = NULL # Suppress the empty horizontal line that is intended for an automated caption
)
#
\end{document}
File RunSweave.R:
# RunSweave.R
# Run the code
source("StackExampleCode.R")
# Bundle R code with LaTeX
Sweave("StackExampleRnw.Rnw")
# .tex -> .pdf
tools::texi2pdf("StackExampleRnw.tex")
Here's what it looks like for me in StackExampleRnw.pdf:
Alternatively, you can directly access the table in .tex in the file StackExampleRnw.tex and do some additional formatting if you're comfortable with it. Above doesn't require any additional tinkering in .tex, but you need to make sure you put the horizontal lines and NAs to correct places.
If you're not comfortable with .tex, the print.xtable-function has plenty of parameters available for further formatting. If the partial horizontal lines are really important for you in the three columns to the right, I'd probably split this into two tables and then just glue them together horizontally and have the right one with a horizontal line in each row.
I would have liked to accomplish this in pixiedust by merging some cells, but it appears I have a flaw in pixiedust that doesn't allow for vertical borders on merged rows. The workaround uses Teemu's approach of setting the cells we don't wish to view to NA and directing them to be printed as empty characters.
library(dplyr)
library(pixiedust)
table2$Test <- "test1"
table3$Test <- "test2"
bind_rows(
right_join(table1, table2),
right_join(table1, table3)
) %>%
mutate(Description = as.character(Description)) %>%
group_by(Test) %>%
mutate(Description = ifelse(duplicated(Description), NA, Description)) %>%
ungroup() %>%
mutate(Test = ifelse(duplicated(Test), NA, Test))%>%
dust(float = FALSE) %>%
sprinkle(cols = 1:2,
rows = c(4, 7),
border = "bottom") %>%
sprinkle(cols = 1:2,
rows = 1,
border = "top") %>%
sprinkle(cols = 1:2,
border = "left",
na.string = "") %>%
medley_all_borders(cols = 3:5) %>%
medley_all_borders(part = "head") %>%
sprinkle_print_method("latex")
A full, working RMD file would be:
---
title: "Untitled"
output: pdf_document
header-includes:
- \usepackage{amssymb}
- \usepackage{arydshln}
- \usepackage{caption}
- \usepackage{graphicx}
- \usepackage{hhline}
- \usepackage{longtable}
- \usepackage{multirow}
- \usepackage[dvipsnames,table]{xcolor}
---
```{r, echo = FALSE, message = FALSE, warning = FALSE}
library(dplyr)
library(pixiedust)
tab1="Test Description
1 test1 description
2 test2 description"
table1 <-read.table(text = tab1,header = TRUE)
tab21="Cause Probability Feedback
1 cause1 .5 positive
2 Cause2 .2 negative
3 Cause3 .1 negative
4 Cause4 .2 negative"
table2 <-read.table(text = tab21,header = TRUE)
tab22="Cause Probability Feedback
1 cause1 .7 positive
2 Cause2 .2 negative
3 Cause3 .1 negative"
table3 <-read.table(text = tab22,header = TRUE)
```
```{r, echo = FALSE, message = FALSE, warning = FALSE}
table2$Test <- "test1"
table3$Test <- "test2"
bind_rows(
right_join(table1, table2),
right_join(table1, table3)
) %>%
mutate(Description = as.character(Description)) %>%
group_by(Test) %>%
mutate(Description = ifelse(duplicated(Description), NA, Description)) %>%
ungroup() %>%
mutate(Test = ifelse(duplicated(Test), NA, Test))%>%
dust(float = FALSE) %>%
sprinkle(cols = 1:2,
rows = c(4, 7),
border = "bottom") %>%
sprinkle(cols = 1:2,
rows = 1,
border = "top") %>%
sprinkle(cols = 1:2,
border = "left",
na.string = "") %>%
medley_all_borders(cols = 3:5) %>%
medley_all_borders(part = "head")
```