I would like to use a conditional to add specific tooltips to certain cells in Kable. I have tried the following in an example below:
col1 <- c("A", "A*","B**")
col2 <- c("A**", "B", "C")
col3 <- c("A*", "B*", "C*")
Test <- data.frame(col1,col2,col3)
Test
Test %>%
mutate_at(vars("col1":"col3"), ~ cell_spec(
., "html",
tooltip = ifelse(. =="A*"|.=="B*"|.=="C*"|.=="D*", "Satisfactory to 22\u00B0C",
ifelse(. == "A**"|.=="B**"|.=="C**"|.=="D**","Satisfactory to 48\u00B0C", )))) %>%
kable(format = "html", escape = FALSE) %>%
kable_styling(full_width = FALSE,
bootstrap_options = c("striped","responsive", "hover"))
I would like to add a the tooltip "Satisfactory to 22\u00B0C" to every observation with one asterisk (e.g. A*, B*, C*), and "Satisfactory to 48\u00B0C" to every observation with two asterisks (A**, B**, C**). I would also like to leave the other data alone. Currently, I can only get this to work if I include a tooltip for all of the FALSE observations at the end of the ifelse statement. I tried setting the "else" arguement to NULL, but this did not work. Any help would be greatly appreciated, as I am very rusty when it comes to conditionals.
Sure, you can just use an empty string ""
library(kableExtra, include.only = NULL)
library(dplyr, include.only = "%>%")
col1 <- c("A", "A*","B**")
col2 <- c("A**", "B", "C")
col3 <- c("A*", "B*", "C*")
Test <- data.frame(col1,col2,col3)
Test
#> col1 col2 col3
#> 1 A A** A*
#> 2 A* B B*
#> 3 B** C C*
Test %>%
dplyr::mutate_at(
.vars = dplyr::vars("col1":"col3"),
.funs = ~kableExtra::cell_spec(
x = .,
format = "html",
tooltip = ifelse(test = . =="A*"|.=="B*"|.=="C*"|.=="D*",
yes = "Satisfactory to 22\u00B0C",
no = ifelse(test = . == "A**"|.=="B**"|.=="C**"|.=="D**",
yes = "Satisfactory to 48\u00B0C",
no = "")))) %>%
kableExtra::kable(format = "html", escape = FALSE) %>%
kableExtra::kable_styling(full_width = FALSE,
bootstrap_options = c("striped","responsive", "hover"))
Related
I have been enjoying the gtsummary library quite a bit but I can't find a clean way to display checkbox style questions (select all that apply) gtsummary::tbl_summary. Here is an example:
example_df = tibble::tibble(
CHOICE1 = sample(c(1, NA), size = 10, replace = TRUE),
CHOICE2 = sample(c(1, NA), size = 10, replace = TRUE),
CHOICE3 = sample(c(1, NA), size = 10, replace = TRUE)
)
for(i in 1:3){
expss::val_lab(example_df[[i]]) = set_names(1, letters[i])
expss::var_lab(example_df[[i]]) = 'Question 1'
}
example_df %>%
gtsummary::tbl_summary(
type = list(
CHOICE1 ~ "categorical",
CHOICE2 ~ "categorical",
CHOICE3 ~ "categorical"
)
)
Ideally, we would just have one header that says 'Question 1' and then each of the columns would be summarized below it. Any suggestions on how to do this properly or gerry rig it?
Thank you!
Great question. Below is an, admittedly, not great solution to your question. But it does get the job done. If you file an GH issue on the gtsummary page, requesting better support for these types of data, we can work together a more concise solution. Happy Programming!
library(gtsummary)
library(tidyverse)
example_df = tibble::tibble(
CHOICE1 = sample(c(1, NA), size = 10, replace = TRUE),
CHOICE2 = sample(c(1, NA), size = 10, replace = TRUE),
CHOICE3 = sample(c(1, NA), size = 10, replace = TRUE)
)
for(i in 1:3){
expss::val_lab(example_df[[i]]) = setNames(1, letters[i])
expss::var_lab(example_df[[i]]) = 'Question 1'
}
example_df %>%
mutate(across(everything(), ~replace_na(., 0L))) %>%
gtsummary::tbl_summary(
type = list(
CHOICE1 ~ "categorical",
CHOICE2 ~ "categorical",
CHOICE3 ~ "categorical"
)
) %>%
remove_row_type(variables = c(CHOICE2, CHOICE3), type = "header") %>%
modify_table_body(
~.x %>%
filter(label != "0")
) %>%
as_kable() # converting to kable to display on SO
Characteristic
N = 10
Question 1
a
4 (40%)
b
3 (30%)
c
4 (40%)
Created on 2022-01-12 by the reprex package (v2.0.1)
Lets say i have the following data:
> data.frame(value = 1:2, name = c("a", "b"))
value name
1 1 a
2 2 b
Goal:
Can i give it as Input to the pipe Operator and "send" it to setNames (or magrittr::set_names)?
What i have tried:
library(magrittr)
data.frame(value = 1:2, name = c("a", "b")) %>%
setNames(object = .$value, nm = .$name)
That doesnt work i guess, because the pipe wants to Hand over the whole data.frame and use it as a first Argument. That got me interested if i can skip this behaviour and use two subsets instead.
(So that data.frame(value = 1:2, name = c("a", "b")) %>% is fixed and not replaced by a variable).
Desired Output:
How it would look like without the pipe Operator:
> a <- data.frame(value = 1:2, name = c("a", "b"))
> setNames(object = a$value, nm = a$name)
a b
1 2
For this case, we can simply wrap it inside {}
library(dplyr)
data.frame(value = 1:2, name = c("a", "b")) %>%
{ setNames(object = .$value, nm = .$name)}
With tidyverse, there is also a deframe which will give a named vector
library(tibble)
data.frame(value = 1:2, name = c("a", "b")) %>%
select(2:1) %>%
deframe
#a b
#1 2
I am writing a report using Rmarkdown, I have a data frame like this:
I want to check all cells and change the markup so the values that are smaller than "0.05" are highlighted in red. I managed to do that in a simpler data frame with only 2 rows and a specific cell, so it was easy and it's working. But in this case, I need to check all cells and I have no idea how to do it. I have tried with mutate_if, mutate_all and got nowhere.
This line was all that I needed to make it work on the other data frame:
mutate(p.value = cell_spec(p.value, "html", color = ifelse(p.value[1] < 0.05, "red", "black")))
Edit: as requested..
I am using Kable and KableExtra to do some of the printing on the report. Here is a code example that I used to do the highlighting on a more basic data frame:
aov.formiga <- aov(as.formula(sprintf("%s ~ Local", v)), formigas)
d <- tidy(aov.formiga)
print(
d %>%
replace(is.na(.),"") %>%
mutate(p.value = cell_spec(p.value, "html", color = ifelse(p.value[1] < 0.05, "red", "black"))) %>%
kable(format = "html", escape = F, col.names = c("Source", "DF","Anova SS", "Mean Square", "F Value", "Pr > F")) %>%
kable_styling(bootstrap_options = c("striped", "hover"), full_width = F)
)
That is the result of this print:
I can provide any data, but I can try to simplify the idea:
DF
... A B C
1 1 2 1
2 2 1 2
3 3 4 1
Let's say I want to loop this DF and replace all 1 for "One" and leave the other values intact. If I can manage to do that with Dplyr I think I can work the other parts. Thank you!
With your example data, if you want to turn all the cells greater than or equal to 2 to red:
x = c(A = 1, B = 2, C = 1)
y = c(A = 2, B = 1, C = 2)
z = c(A = 3, B = 4, C = 1)
data=data.frame(rbind(x,y,z))
library(knitr)
library(kableExtra)
library(tidyverse)
data %>%
mutate_all(~cell_spec(.x, color = ifelse(.x >= 2, "red"," black"))) %>%
kable(escape = F) %>%
kable_styling()
Response to comment
The ifelse() breaks with NA values, so we can use case_when():
data %>%
mutate_all(~cell_spec(.x, color = case_when(.x >= 2 ~ "red",
TRUE ~ "black"))) %>%
kable(escape = F) %>%
kable_styling()
I'm trying to count instances where a certain string appears in a dataframe (this will be a sub-string, i.e. "blue" will appear within a larger block of text), and then summarize those counts by another field. Here's the code:
totals_by_county <- county_data %>%
group_by(county_data$county)%>%
summarise(number_occurences = count(grepl('blue', county_data$color,ignore.case = TRUE)))
totals_by_county
And I get this error:
no applicable method for 'summarise_' applied to an object of class "logical"
Is there a way to do this in the method I'm trying to use above? Thanks in advance!
With grepl:
totals_by_county <- county_data %>%
group_by(county) %>%
summarise(number_occurences = sum(grepl('blue', color, ignore.case = TRUE)))
or, with count_if from expss:
totals_by_county <- county_data %>%
group_by(county) %>%
summarise(number_occurences = count_if(perl('blue', ignore.case = TRUE), color))
UPDATE with reproducible example:
library(dplyr)
library(expss)
county_data = data.frame(
county = c("A", "A", "A", "B", "B"),
color = c("blue-blue", "red", "orange-blue", "yellow", "green"),
stringsAsFactors = FALSE)
county_data %>%
group_by(county) %>%
summarise(number_occurences = count_if(perl('blue', ignore.case = TRUE), color))
# A tibble: 2 x 2
# county number_occurences
# <chr> <int>
# 1 A 2
# 2 B 0
I have a table with multiple records for each individual (ID1) and would like the row shading (i.e. kable_styling(c("striped")) to alternate by group (ID1) rather than by every other row. I was hoping I could add group_by(ID1) to the code below... Alas I am still in search of a solution. While there are lots of helpful tips are shown here, I have not been able to find a solution.
I am also wondering how to make a single outside border to the table rather than border every cell.
Below is a reproducible data set.
Many thanks in advance.
```{r echo=F, warning=F, message = FALSE}
library(tidyverse)
library(kableExtra)
set.seed(121)
Dat <- data.frame(
ID1 = sample(c("AAA", "BBB", "CCC","DDD"), 100, replace = T),
ID2 = sample(c("Cat", "Dog", "Bird"), 100, replace = T),
First = rnorm(100),
Two = sample.int(100))
ExTbl <- Dat %>%
group_by(ID1, ID2) %>%
summarize(One = mean(First),
Max = max(Two)) %>%
arrange(ID1)
kable(ExTbl) %>%
kable_styling(c("striped", "bordered"), full_width = F)
```
> head(as.data.frame(ExTbl) )
ID1 ID2 One Max
1 AAA Bird 0.15324169 86
2 AAA Cat -0.02726006 83
3 AAA Dog -0.19618126 78
4 BBB Bird 0.62176633 100
5 BBB Cat -0.35502912 77
6 BBB Dog -0.29977145 87
>
Right now there is no direct approach in kableExtra but this is the method I used last time. Maybe I should pack this into this package.
library(tidyverse)
library(kableExtra)
set.seed(121)
Dat <- data.frame(
ID1 = sample(c("AAA", "BBB", "CCC","DDD"), 100, replace = T),
ID2 = sample(c("Cat", "Dog", "Bird"), 100, replace = T),
First = rnorm(100),
Two = sample.int(100))
ExTbl <- Dat %>%
group_by(ID1, ID2) %>%
summarize(One = mean(First),
Max = max(Two)) %>%
arrange(ID1)
ind_end <- cumsum(rle(as.character(ExTbl$ID1))$lengths)
ind_start <- c(1, ind_end[-length(ind_end)] + 1)
pos <- purrr::map2(ind_start, ind_end, seq)
pos <- unlist(pos[1:length(pos) %% 2 != 0])
kable(ExTbl) %>%
kable_styling(c("bordered"), full_width = F) %>%
row_spec(pos, background = "#EEEEEE")