Related
I'm working in Rbookdown and I want to place a plot and a table in one figure, how can I achieve that? Below is the code i used so far. Can you help?
```{r echo=FALSE, message=FALSE, warning=FALSE, fig.height = 3.5, out.width = '70%', fig.align = "center"}
library(knitr)
library(kableExtra)
library(tidyverse)
library(latex2exp)
options(scipen=999)
mu = 0
sigma = 1
x = 1
# draw normal distribution
range = seq(mu - 4*sigma, mu + 4*sigma, 0.01)
y = dnorm(range, mu, sigma)
plot(range, y,
main = "Standard Normal Distribution", xlab = "Z-score", ylab = " ",
type = 'l', ylim = c(0, max(y) + 0.01), axes = FALSE)
axis(1, at = seq(mu - 4*sigma, mu + 4*sigma, sigma))
# Add area to the left of x
cord.a = c(0, seq(min(range), x, 0.01))
cord.b = c(dnorm(seq(min(range), x, 0.01), mu, sigma), 0)
polygon(cord.a, cord.b, col = "#61a5ff")
text(x = 1.1, y = -.06, TeX('$z = 1.00$'), cex = .8, xpd=NA)
text(x = 0, y = .15, TeX('$p = .8413$'), cex = .8, xpd=NA)
# Create standard normal table
options(digits = 4)
u=seq(0,3.09,by=0.01)
p=pnorm(u)
m=matrix(p,ncol=10,byrow=TRUE)
df.m = as.data.frame(m)
z.values = c("**0.0**", "**0.1**", "**0.2**", "**0.3**", "**0.4**", "**0.5**", "**0.6**",
"**0.7**", "**0.8**", "**0.9**", "**1.0**", "**1.1**", "**1.2**", "**1.3**",
"**1.4**", "**1.5**", "**1.6**", "**1.7**", "**1.8**", "**1.9**","**2.0**",
"**2.1**", "**2.2**", "**2.3**", "**2.4**", "**2.5**", "**2.6**", "**2.7**",
"**2.8**", "**2.9**", "**3.0**")
df.z.values = as.data.frame(z.values)
new.m = df.z.values %>%
bind_cols(df.m)
kable(new.m,
booktabs = TRUE,
col.names = c("$Z$", "0.00","0.01", "0.02", "0.03", "0.04",
"0.05", "0.06", "0.07", "0.08", "0.09"),
escape = FALSE,
caption = "Standaard Normaalverdeling",
linesep = "",
align = c('r')) %>%
kable_styling(font_size = 10)
Try this solution:
```{r echo=FALSE, message=FALSE, warning=FALSE, include = FALSE}
library(kableExtra)
#make and save our table into working directory
table1 <- head(mtcars[1:5]) %>%
kbl() %>%
kable_styling(full_width = F) %>%
save_kable("tab_kbl.png")
#make and save our plot into working directory
png('norm_pl.png')
plot(rnorm(10))
dev.off()
```
```{r,echo=FALSE, message=FALSE, warning=FALSE, fig.cap="My image", fig.align = "center"}
library(cowplot)
#combine our images in the one
img1 <- ggdraw() + draw_image("norm_pl.png", scale = 1)
img2 <- ggdraw() + draw_image("tab_kbl.png", scale = 1)
plot_grid(img1, img2)
```
An another variant
```{r, fig.align='center', fig.cap="My beautiful image"}
library(gridExtra)
library(grid)
library(cowplot)
t1 <- tableGrob(head(mtcars[1:5]), theme = ttheme_minimal())
p2 <- ggplot(mtcars, aes(cyl, mpg)) +
geom_point()
plot_grid(t1, p2, ncol = 2, rel_widths = c(2,1))
```
I'm using a datatable in a shiny app with custom coloring of the cells. This is done in html (each cell is a div) and by telling DT to not escape these specific columns.
It looks like this with DT :
screenshot
My issue is that I would like the coloring to take the entire height of each cell so that there is no margins. If I could have the different cell colors to touch each other that would be great.
I have try to add margin: 0px; padding: 0px; but it makes no difference.
I've also tried to use the formatstyle from DT to reduce the row height like so :
formatStyle( 0, target = 'row', lineHeight = '80%')
and the result looks like this :
screenshot 2
I'm currently trying with padding: 0px;margin-top:0px;margin-right:0px;margin-bottom:0px;margin-left:0px; but it does not work any better.
It looks to me that this is a margin from DT rather than my div since whatever I try in my div style, I've always the same margins between the colors and the row height limits. The only thing is I do not know how to control it.
Would anyone know how to achieve such a result ?
Thanks ahead of time for your help.
Code used :
for (c in colnames(ranking)[10:13]) {
ranking <- ranking %>%
filter(param %in% input$param) %>%
arrange_(.dots = c) %>%
mutate(!!paste0(c, "_rk") := 1:nrow(ranking %>% filter(param %in% input$param)))
tmp <- ranking %>%
arrange_(.dots = c) %>%
select_(.dots = c)
max <- tmp %>% tidyr::drop_na() %>% .[, 1] %>% max()
min <- tmp %>% tidyr::drop_na() %>% .[, 1] %>% min()
range <- max - min
brks <- vector(length = colors)
for (i in 1:colors) {
brks[i] <- i^pracma::bisect(function(x) range^(1/x) - (colors + 1), 1, 5)$root %>% round(2) + min - 2
}
tmp <- tmp %>%
mutate(brks = ifelse(is.na(tmp[, 1]),
NA,
cut(tmp %>% tidyr::drop_na() %>% .[, 1], brks)))
colfunc <- colorRampPalette(c("#c31432", "#ffc500", "#edde5d", "white"))
clrs <- colfunc(colors + 1)
tmp_nrow <- tmp %>% nrow()
for (i in 1:tmp_nrow) {
row <- which(tmp[i, 1] == ranking[,c])
r <- clrs[tmp[i, 2]] %>% col2rgb() %>% .[1]
g <- clrs[tmp[i, 2]] %>% col2rgb() %>% .[2]
b <- clrs[tmp[i, 2]] %>% col2rgb() %>% .[3]
tmp[i, 1] <- paste0("<center><div style='background: ", "radial-gradient(rgba(", r, ",", g, ",", b, ",", "0), rgba(", r, ",", g, ",", b, ",", "0.25), rgba(", r, ",", g, ",", b, ",", "1)", ")", "; border: solid 0px;font-family: \"Interstate Black\";font-weight: bolder;padding: 0;margin: 0;'>",
tmp[i, 1],
"</div></center>")
ranking[row,paste0(c, "_coloring")] <- tmp[i, 1]
}
}
ranking_m <- as.matrix(ranking %>%
filter(param %in% input$param) %>%
select(4, 47, 40, 38, 31, 32, 41, 42, 43, 44))
DT::datatable(ranking_m,
escape = c(TRUE, FALSE, rep(FALSE, 8)),
filter = 'top',
extensions = list('Responsive' = NULL),
options = list(pageLength = 25,
lengthMenu = c(10, 25, 50, 100),
columnDefs = list(list(width = '400px', targets = 0),
list(width = '25px', targets = 1),
list(className = 'dt-center', targets = 2:9)))) #%>%
# formatStyle( 0, target = 'row', lineHeight = '80%')
The background CSS must be set to the cells, not to the cells contents. This can be achieved with formatStyle. Here is an example with random colors:
library(DT)
dat <- iris[1:5,]
ncols <- ncol(dat)
# background for column 1
r <- sample.int(256, 5, replace = TRUE) - 1L
g <- sample.int(256, 5, replace = TRUE) - 1L
b <- sample.int(256, 5, replace = TRUE) - 1L
dat$RGB1 <- sprintf("radial-gradient(rgba(%s,%s,%s,0),rgba(%s,%s,%s,0.25),rgba(%s,%s,%s,1))",
r, g, b, r, g, b, r, g, b)
# background for column 2
r <- sample.int(256, 5, replace = TRUE) - 1L
g <- sample.int(256, 5, replace = TRUE) - 1L
b <- sample.int(256, 5, replace = TRUE) - 1L
dat$RGB2 <- sprintf("radial-gradient(rgba(%s,%s,%s,0),rgba(%s,%s,%s,0.25),rgba(%s,%s,%s,1))",
r, g, b, r, g, b, r, g, b)
# background for column 4
r <- sample.int(256, 5, replace = TRUE) - 1L
g <- sample.int(256, 5, replace = TRUE) - 1L
b <- sample.int(256, 5, replace = TRUE) - 1L
dat$RGB4 <- sprintf("radial-gradient(rgba(%s,%s,%s,0),rgba(%s,%s,%s,0.25),rgba(%s,%s,%s,1))",
r, g, b, r, g, b, r, g, b)
datatable(dat,
options =
list(
columnDefs =
list(
list(visible = FALSE, targets = ncols + 1:3),
list(className = "dt-center", targets = 1:ncols)
)
)) %>%
formatStyle(1, valueColumns = ncols+1, background = JS("value")) %>%
formatStyle(2, valueColumns = ncols+2, background = JS("value")) %>%
formatStyle(4, valueColumns = ncols+3, background = JS("value")) %>%
formatStyle(1:ncols, `font-family` = "Interstate Black") %>%
formatStyle(1:ncols, fontWeight = "bolder")
I am using R 3.5.1 on OS Windows 7 x64.
My package versions are:
flextable: 0.5.1
officer: 0.3.2
tidyverse: 1.2.1
tidyr: 0.8.2
I am trying to create and then print multiple flextables in a single chunk to Word. I also do not want the actual R code in the Word Doc, so I've set echo = FALSE. However, I've run into something strange.
If I use the following code (echo = T):
```{r, echo = F, warning=FALSE, message=FALSE}
library(tidyverse)
library(flextable)
library(officer)
```
```{r, echo = T}
iris_data <- head(iris, n = 10)
iris_data_ft <- iris_data %>% flextable() %>%
hline(part = 'header', border = fp_border(color = "black", width = 3)) %>%
align(align ='center', part = 'all') %>%
align(j = 1, align ='left', part = 'all') %>%
add_header_lines('this is a test')
iris_data_ft
iris_data2 <- tail(iris, n = 10)
iris_data2_ft <- iris_data2 %>% flextable() %>%
hline(part = 'header', border = fp_border(color = "black", width = 3)) %>%
align(align ='center', part = 'all') %>%
align(j = 1, align ='left', part = 'all') %>%
add_header_lines('this is a test')
iris_data2_ft
```
I get the following output of proper flextables in Word:
If I use the exact same code, but with echo = F:
```{r, echo = F}
iris_data <- head(iris, n = 10)
iris_data_ft <- iris_data %>% flextable() %>%
hline(part = 'header', border = fp_border(color = "black", width = 3)) %>%
align(align ='center', part = 'all') %>%
align(j = 1, align ='left', part = 'all') %>%
add_header_lines('this is a test')
iris_data_ft
iris_data2 <- tail(iris, n = 10)
iris_data2_ft <- iris_data2 %>% flextable() %>%
hline(part = 'header', border = fp_border(color = "black", width = 3)) %>%
align(align ='center', part = 'all') %>%
align(j = 1, align ='left', part = 'all') %>%
add_header_lines('this is a test')
iris_data2_ft
```
I get the following in Word (this goes on for 58 pages):
Finally, if I split the one chunk for the two flextables into two separate chunks and set echo = F:
```{r, echo = F}
iris_data <- head(iris, n = 10)
iris_data_ft <- iris_data %>% flextable() %>%
hline(part = 'header', border = fp_border(color = "black", width = 3)) %>%
align(align ='center', part = 'all') %>%
align(j = 1, align ='left', part = 'all') %>%
add_header_lines('this is a test')
iris_data_ft
```
```{r, echo = F}
iris_data2 <- tail(iris, n = 10)
iris_data2_ft <- iris_data2 %>% flextable() %>%
hline(part = 'header', border = fp_border(color = "black", width = 3)) %>%
align(align ='center', part = 'all') %>%
align(j = 1, align ='left', part = 'all') %>%
add_header_lines('this is a test')
iris_data2_ft
```
The tables render just fine:
While I don't mind separating the flextables into different chunks, I am wondering why this is happening. Any guidance would be greatly appreciated. Thanks!
Here is a workaround:
---
title: "Untitled"
output: word_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
library(flextable)
```
```{r echo=FALSE, results='asis'}
library(htmltools)
ft <- flextable(head(iris))
for(i in 1:3){
cat("```{=openxml}\n")
cat(format(ft, type = "wml"), "\n")
cat("```\n")
}
```
I guess this issue is solved with newer versions of flextable already. If I put the code following two chunks into a .Rmd document and knit to word it compiles without problems and shows tables, even if put into one chunk with echo = F. Just wanted to add: In some cases it might be helpful to add results='asis' - the 'as is'-option (raw Markdown parsing) - to your chunk header to prevent errors when parsing tables, check: bookdown.org/results-as-is.
```{r, echo = F, warning=FALSE, message=FALSE}
library(tidyverse)
library(flextable)
library(officer)
```
```{r, echo = F}
iris_data <- head(iris, n = 10)
iris_data_ft <- iris_data %>% flextable() %>%
hline(part = 'header', border = fp_border(color = "black", width = 3)) %>%
align(align ='center', part = 'all') %>%
align(j = 1, align ='left', part = 'all') %>%
add_header_lines('this is a test')
iris_data_ft
iris_data2 <- tail(iris, n = 10)
iris_data2_ft <- iris_data2 %>% flextable() %>%
hline(part = 'header', border = fp_border(color = "black", width = 3)) %>%
align(align ='center', part = 'all') %>%
align(j = 1, align ='left', part = 'all') %>%
add_header_lines('this is a test')
iris_data2_ft
```
With the following dataset...
Subj <- rep(1:10, each = 10)
Item <- rep(1:10, times = 10)
IV1 <- rep(1:5, times = 20)
DV <- rnorm(100)
library(data.table)
data <- as.data.table(cbind(Subj, Item, IV1, DV))
data$Subj <- as.factor(data$Subj)
data$Item <- as.factor(data$Item)
data$IV1 <- as.factor(data$IV1)
library(MASS)
contrasts(data$IV1) <- contr.sdif(5)
library(lme4)
m1 <- lmer(DV ~ IV1 + (1 + IV1|Subj) + (1|Item), data = data)
Now suppose that it turned out that there was only variance in the random subject slope for the contrast of IV1 level 2 vs. IV1 level1. Is it possible to fit a random slope only for this contrast?
I am new to the leaflet package.
I am trying to draw two types of polygons and let the user select them and see the borders. These polygons have labels and I want to display them by default. At the moment the labels are displayed only on mouse hover.
Basically what I want is to let the user search for the polygon label on the map.
Given below is my code.
shp <- readOGR(dsn = 'shapes'
,layer = 'SAB')
postcode <- readOGR(dsn = 'shapes'
,layer = 'Postcode')
CRS_WGS84 <- '+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0'
t_shp <- spTransform(shp, CRS(CRS_WGS84))
sab_shp <- raster::aggregate(t_shp, by='SMALL_AREA')
dat <- data.table(shp#data)
sabLabels <- sprintf('<strong>SAB: %s', t_shp$SMALL_AREA) %>% lapply(HTML)
postcode <- readOGR(dsn = 'shapes'
,layer = 'Postcode')
CRS_WGS84 <- '+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0'
t_shp2 <- spTransform(postcode, CRS(CRS_WGS84))
postcode_shp <- raster::aggregate(t_shp2, by='RoutingKey')
dat2 <- data.table(postcode#data)
postcodeLabels <- sprintf('<strong>SAB: %s', t_shp2$RoutingKey) %>% lapply(HTML)
leaflet() %>%
addTiles() %>% #using default does not allow html export to include the underlying
#OSM layer
addProviderTiles('OpenStreetMap.Mapnik') %>%
addPolygons( data = t_shp
,stroke = T
,fillColor = 'grey'
,fillOpacity = 0.2
,color = 'blue'
,weight = 0.5
,label = sabLabels
,group = 'SABS'
,highlightOptions = highlightOptions(color = "blue", weight = 7,
bringToFront = TRUE)
#,labelOptions = labelOptions(noHide = TRUE, textOnly = TRUE, opacity = 0.5 , textsize='15px')
) %>%
addPolygons( data = t_shp2
,stroke = T
,fillOpacity = 0
,color = 'black'
,weight = 1.5
,label = postcodeLabels
,group = 'PostCodes'
) %>%
addLayersControl(
overlayGroups = c(
'SABS'
,'PostCodes'
)
,options = layersControlOptions((collapsed = F))
)