Is it possible to instruct Rmarkdown to default all tables to my styled output? Here is my attempt:
---
title: 'Test Kable Global Styling'
output:
html_document:
df_print: kable
---
```{r}
library(knitr)
library(kableExtra)
kable <- function(data) {
message("YES, IT BITES! (not sortable, but styled.)\n")
knitr::kable(data, digits=3) %>% kable_styling(bootstrap_options = "striped", full_width = F, position = "center")
}
```
## Testing
```{r}
d <- data.frame( x=1:3, y=rnorm(3) )
```
### Explicit Invokation
```{r}
kable(d)
```
### Implicit Invokation Fails
```{r}
d
```
The output looks like this:
[possibly related to How to set knitr::kable() global options in markdown for reuse, but defining my own kable function is not enough for Rmarkdown to select it.
thanks, mystery user for the complete solved update to the above problem. alas, could it generalize to :
```{r}
library(knitr)
library(DT); p <- function(...) DT::datatable(...)
knit_print.data.frame <- function(x, ...) asis_output( paste( c("",p(x)) , collapse="\n" ) )
registerS3method("knit_print", "data.frame", knit_print.data.frame)
```
# Test Code
```{r}
d <- data.frame( x=1:3, y=rnorm(3) )
```
## Print
```{r}
p(d)
d
```
done
As you saw, How to set knitr::kable() global options in markdown for reuse describes how to do this with an explicit call to kable, but doesn't handle implicit displays. The way to do that is described in the ?knitr::knit_print help page. You need code like this early in your document:
kable <- function(data, ...) {
message("YES, IT BITES! (not sortable, but styled.)\n")
knitr::kable(data, digits=3, ...) %>% kable_styling(bootstrap_options = "striped", full_width = F, position = "center")
}
knit_print.data.frame <- function(x, ...) {
res <- paste(c("", "", kable(x)), collapse = "\n")
asis_output(res)
}
registerS3method("knit_print", "data.frame", knit_print.data.frame)
Related
I am creating a quarto powerpoint presentation and want to use a dataset to iterate over all the classes in a variable and do a plot for each class on a new slide. However, my plot doesn't seem to show up
---
title: "test_quarto_presentation"
format: pptx
editor: visual
---
## Quarto
Trying to iterate over each species and print the distributions on slides
```{r}
library(tidyverse)
```
```{r, results='asis'}
for (species in unique(iris$Species)){
cat(paste0('## ', species))
print("test")
print(iris %>%
filter(Species == "virginica") %>%
ggplot(aes(x = Petal.Length)) +
geom_histogram())}
```
Here is an option by producing the plots beforehand using purrr based on this discussion:
---
title: "test_quarto_presentation"
format: pptx
---
```{r, include=FALSE}
library(tidyverse)
spec_name <- unique(iris$Species)
make_hist <- function(spec) {
iris |>
filter(Species == spec) |>
ggplot(aes(x = Petal.Length)) +
geom_histogram()
}
list_hist <- map(spec_name, make_hist)
df <- tibble(spec = spec_name, plots = list_hist)
```
```{r}
#| output: asis
res <- pmap_chr(df, \(spec, plots) {
knitr::knit_child(text = c(
"## `r spec`",
"```{r}",
"#| echo: false",
"plots",
"```",
""), envir = environment(), quiet = TRUE)
})
cat(res, sep = '\n')
```
Output:
I'm trying to generate a Word document with figures. I use {officedown} and {officer} packages. I need to do it dynamically, in a loop since I don't know how many figures there will be. This is my Rmarkdown code:
---
output:
officedown::rdocx_document:
plots:
caption:
style: Table Caption
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = FALSE, message = FALSE, warning = FALSE)
```
```{r}
library(dplyr)
library(flextable)
library(officer)
```
```{r}
block_toc(seq_id = "fig")
```
```{r results='asis'}
ttp <- c(3, 7)
test_items <- c("item A", "item B", "item C")
fpars <- lapply(test_items, function(ti) {
fpar(
ftext("Application of "),
ftext(ti),
ftext(" Variable text - describe any test item-related effects"),
ftext(" (see "),
run_reference("fig:results1"),
ftext(")."),
fp_p = fp_par(padding.bottom = 12)
)
})
do.call(block_list, fpars)
```
```{r}
titles <- lapply(seq_len(length(ttp)), function(i) {
sprintf(
"My custom figure caption with %s, having %s side effects",
paste(test_items, collapse = ", "),
ttp[i]
)
})
```
```{r}
tmps <- lapply(seq_len(length(ttp)), function(i) {
tmp <- tempfile(fileext = ".png")
png(tmp, width = 6, height = 5, units = "in", res = 120)
plot(iris[sample(1:150, 30), i + 1:2])
dev.off()
return(tmp)
})
```
```{r}
fpars <- lapply(seq_len(length(ttp)), function(i) {
fpar(
run_autonum(
seq_id = "fig",
pre_label = "Figure ",
bkm = paste0("fig:results", i),
bkm_all = TRUE,
prop = fp_text(bold = TRUE, font.size = 12)
),
titles[[i]],
external_img(src = tmps[[i]], width = 6, height = 5)
)
})
do.call(block_list, fpars)
```
The problem is when I generate the table of figures in the rendered document. It looks like this:
An entry is kept together with the image itself, I don't know why.
I save temporary png files to be able to use them inside fpar function. Using plot function directly inside fpar causes bad effects. Maybe there's another/better way?
I found this construction useful, but unfortunately it puts captions under the figures by default. My goal is figure captions behave more like table captions, i.e. a caption is above a figure.
```{r fig.cap=unlist(titles)}
plot(iris[1:10, 1:2])
```
How can I generate the plots with captions dynamically with {officedown} or {officer} packages?
The only issue is about the last lapply, you need to put the image in a separate paragraph, so a for loop will be easier to stack 2 paragraphs into a list instead of 1 for each iteration.
---
output:
officedown::rdocx_document:
plots:
caption:
style: Table Caption
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = FALSE, message = FALSE, warning = FALSE)
```
```{r}
library(dplyr)
library(flextable)
library(officer)
library(officedown)
```
```{r}
block_toc(seq_id = "fig")
```
```{r}
ttp <- c(3, 7)
test_items <- c("item A", "item B", "item C")
fpars <- lapply(test_items, function(ti) {
fpar(
ftext("Application of "),
ftext(ti),
ftext(" Variable text - describe any test item-related effects"),
ftext(" (see "),
run_reference("fig:results1"),
ftext(")."),
fp_p = fp_par(padding.bottom = 12)
)
})
do.call(block_list, fpars)
```
```{r}
titles <- lapply(seq_len(length(ttp)), function(i) {
sprintf(
"My custom figure caption with %s, having %s side effects",
paste(test_items, collapse = ", "),
ttp[i]
)
})
```
```{r}
tmps <- lapply(seq_len(length(ttp)), function(i) {
tmp <- tempfile(fileext = ".png")
png(tmp, width = 6, height = 5, units = "in", res = 120)
plot(iris[sample(1:150, 30), i + 1:2])
dev.off()
return(tmp)
})
```
```{r}
fpars <- list()
for (i in seq_along(ttp)) {
fpars[[length(fpars)+1]] <- fpar(
run_autonum(
seq_id = "fig",
pre_label = "Figure ",
bkm = paste0("fig:results", i),
bkm_all = TRUE,
prop = fp_text(bold = TRUE, font.size = 12)
),
titles[[i]]
)
fpars[[length(fpars)+1]] <- fpar(
external_img(src = tmps[[i]], width = 6, height = 5)
)
}
do.call(block_list, fpars)
```
This is an answer for "how to do it with officer" from scratch.
But the following is much more simple. There is an option fig.topcaption that do the same thing.
---
output:
officedown::rdocx_document:
plots:
caption:
style: Table Caption
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = FALSE, message = FALSE, warning = FALSE)
```
```{r}
library(dplyr)
library(flextable)
library(officer)
library(officedown)
```
```{r}
block_toc(seq_id = "fig")
```
```{r fig.cap = "miaou", fig.topcaption=TRUE}
plot(cars)
```
```{r fig.cap = "ouaf", fig.topcaption=TRUE}
plot(cars)
```
I'm trying to filter a data frame and then do some simple ggplots off of the data. I've tried to leverage the R studio example on Shiny documents along with the following SO post on the subject:
Reactively filtering/subsetting a data frame in shiny
Here is my code.
---
title: "Shiny Filter Test"
author: "Novice"
date: "12/13/2019"
output: html_document
runtime: shiny
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
```
```{r}
library(tidyverse)
library(shiny)
inputPanel(
selectInput("n_break", label = "Number of bins:",
choices = c(10, 20, 35, 50), selected = 10)
)
cdat <- reactive({
data <- tibble(x = c(10,20,35), y = c("a","b","c"))
data %>%
filter(x %in% input$n_break)
output$table <- DT::renderDT({
cdat()
}, options = list(scrollX = TRUE))
})
```
Can anyone point out where I'm going wrong? When I run the code I get my dropdown box, but that is all. No errors. Just no filtered datatable.
Thanks.
The closing brackets of your reactive are at the wrong place. They should close once you have filtered the data.
---
title: "Shiny Filter Test"
author: "Novice"
date: "12/13/2019"
output: html_document
runtime: shiny
---
```{r setup}
knitr::opts_chunk$set(
echo = FALSE
)
```
```{r}
library(tidyverse)
library(shiny)
inputPanel(
selectInput("n_break", label = "Number of bins:",
choices = c(10, 20, 35, 50), selected = 10)
)
cdat <- reactive({
data <- tibble(x = c(10,20,35), y = c("a","b","c"))
data %>% filter(x %in% input$n_break)
})
DT::renderDT({
cdat()
}, options = list(scrollX = is ))
```
A remark on the reactive: if you plan to extend this futher, such that the filtered data is used elsewhere, it makes sense to do the filtering in a reactive function. However, if this is not the case I would just do the filtering inside the renderDT:
---
title: "Shiny Filter Test"
author: "Novice"
date: "12/13/2019"
output: html_document
runtime: shiny
---
```{r setup}
knitr::opts_chunk$set(
echo = FALSE
)
```
```{r}
library(tidyverse)
library(shiny)
data <- tibble(x = c(10,20,35), y = c("a","b","c"))
inputPanel(
selectInput("n_break", label = "Number of bins:",
choices = c(10, 20, 35, 50), selected = 10)
)
DT::renderDT({
data %>% filter(x %in% input$n_break)
}, options = list(scrollX = TRUE))
```
Because of this issue want to put 6 highcharter graphs in one row like do they over here. It seems to work fine outside of flexdashboard
data(diamonds, package = "ggplot2")
diamonds <- diamonds[-6]
map(names(diamonds), function(x){
diamonds[[x]] %>%
hchart(showInLegend = FALSE) %>%
hc_add_theme(hc_theme_smpl()) %>%
hc_title(text = x) %>%
hc_yAxis(title = list(text = ""))
}) %>%
hw_grid(rowheight = 225, ncol = 3) %>% browsable()
please find a simple example here how it's not working within flexdashboard :
---
title: "test"
runtime: shiny
output:
flexdashboard::flex_dashboard:
orientation: rows
vertical_layout: fill
---
```{r}
library(highcharter)
library(data.table)
library(ggplot2)
library(htmltools)
```
### trying to render with hw_grid
```{r}
sliderInput('ncol','ncol',min = 1,max=4,value = 2)
```
```{r}
renderHighchart({
x <- hchart(data.table(a=c(1:5),b=c(1:5)), type='column', hcaes(x=a,y=b))
lst <- list(
x,
x,
x,
x
)
hw_grid(lst, rowheight = 300,ncol = input$ncol) %>% browsable()
})
```
### hw_grid example without rendering
```{r}
x <- hchart(data.table(a=c(1:5),b=c(1:5)), type='column', hcaes(x=a,y=b))
lst <- list(
x,
x,
x,
x
)
ncol <- 4
# ncol <- input$ncol # need to have a render as this will triger the error: Operation not allowed without an active reactive context....
hw_grid(lst, rowheight = 300,ncol = ncol) %>% browsable()
```
### rendering example
```{r}
renderHighchart({
x <- hchart(data.table(a=c(input$ncol*1:5),b=c(.5 * input$ncol * 1:5)), type='column', hcaes(x=a,y=b))
})
```
Try using renderUI and htmlOutput together like so:
---
title: "test"
runtime: shiny
output:
flexdashboard::flex_dashboard:
orientation: rows
vertical_layout: fill
---
```{r}
library(highcharter)
library(data.table)
library(ggplot2)
library(htmltools)
library(purrr)
library(shiny)
```
### trying to render with hw_grid
```{r}
sliderInput('ncol','ncol',min = 1,max=4,value = 2)
```
```{r}
output$chart1 <- renderUI({
x <- hchart(data.table(a=c(1:5),b=c(1:5)), type='column', hcaes(x=a,y=b))
lst <- list(x,x,x,x)
hw_grid(lst, rowheight = 300,ncol = input$ncol)
})
htmlOutput('chart1')
```
### hw_grid example without rendering
```{r}
x <- hchart(data.table(a=c(1:5),b=c(1:5)), type='column', hcaes(x=a,y=b))
lst <- list(
x,
x,
x,
x
)
ncol <- 4
# ncol <- input$ncol # need to have a render as this will triger the error: Operation not allowed without an active reactive context....
hw_grid(lst, rowheight = 300,ncol = ncol) %>% browsable()
```
### rendering example
```{r}
renderHighchart({
x <- hchart(data.table(a=c(input$ncol*1:5),b=c(.5 * input$ncol * 1:5)), type='column', hcaes(x=a,y=b))
})
```
I'm trying to use Shiny + ShinyBS to create a collapsible panel whitch contains a bunch of column values per column.
However, I'm having trouble in applying do.call correctly (or in the sequence I want).
Source code for server.R:
require(shiny)
library(lazyeval)
library(shinyBS)
l <- lapply(mtcars, function(x) unique(x))
shinyServer(function(input, output) {
output$plot <- renderUI({
col_list <- lapply(1:length(l), function(i) {
col <- l[[i]]
a <- lapply(1:min(length(col), 10), function(j) {
interp(quote(bsToggleButton(nm,lb)),
.values=list(nm = paste0(names(l)[i],
'_val_',
j),
lb = col[j]))
})
pars <- list(inputId = paste0('btng_',
names(l)[i]),
label = '', value = '', a)
interp(quote(bsCollapsePanel(names(l)[i],
fluidRow(
column(4,
do.call(bsButtonGroup,
unlist(pars))
)
),
id = nm, value = val)),
.values = list(i = i,
nm = paste0('test_',i),
val = '')
)
})
pars2 <- list(multiple = TRUE,
open = "test_1",
id = "collapse1",
col_list)
do.call(bsCollapse, unlist(pars2))
})
})
Source code for ui.R:
require(shiny)
shinyUI(
fluidPage(
uiOutput('plot')
)
)
The code can NOT run! The problem is pars seems to be static, it only contains the value of the first iteration.
Firstly, the code was still not reproducible as is. I suspect you had run parts of the provided code within your environment (e.g. the 'pars' object was not found with your provided code on my machine).
Second, I think you have just made your apply statements too complex. The idea of apply statements is to improve readability of your code as opposed to for loops. Here you have crammed so much in to the lapply statements that it is difficult to parse out anything.
To address this, I broke the components apart into their own lapply statements (which is far more approachable now). What was happening with your previous code is that your pars object was taking all the variables from the a object. Once these components were separated, I could easily just alter the pars statement to iterate through each a element. This provides the different values for each iteration (i.e. variable). I have only included the server.R as there is not changes to your ui.R
As a followup to your comments below, you are correct that the interp and quote arguments are unnecessary (I generally avoid them again for clarity, my personal preference). As for best practices, I sum it up in one concept 'clarity then performance'. If you are unsure about your objects then LOOK AT THEM! Below you will find an updated server.R file. I have also minimally commented it. You will also find an example of accessing the bsGroupButton values. You can see it is the group id that you must reference. This should get you started (be sure to add tableOutput('result') to your ui.R. I highly recommend you look into the documentation of ShinyBS or at least the demo page.
Concise and annotated server.R
require(shiny)
library(shinyBS)
l <- lapply(mtcars,function(x)unique(x))
shinyServer(function(input, output) {
output$plot <- renderUI({
# Create your buttons
a <- lapply(1:length(l), function(i){
col <- l[[i]]
lapply(1:min(length(col),10), function(j){
bsButton(paste0(names(l)[i], '_val_', j), label=col[j], value=col[j])
})
})
# add the additional arguments for your future bsButtonGroup call
pars <- lapply(1:length(l), function(i) {
list(inputId =paste0('btng_',names(l)[i]), label = '', value = '',a[[i]])
})
col_list<-lapply(1:length(l), function(i) {
# separate the components for clarity
rawButtons <- unlist(pars[i], recursive=F)
buttons <- do.call(bsButtonGroup, c(rawButtons[[4]], inputId=rawButtons$inputId))
# collapse the groups into panels
bsCollapsePanel(title=names(l)[i],
buttons, id=paste0('test_',i), value='')
})
# Collapse everything, no need for pars2, just add elements in a vector
do.call(bsCollapse, c(col_list, multiple=TRUE, open="test_1", id="collapse1"))
})
output$result<- renderTable({
df <- cbind(c("mpg toggle button", c(deparse(input$btng_mpg))))
return(df)
})
})
original answer for server.R
require(shiny)
library(shinyBS)
require(lazyeval)
l <- lapply(mtcars,function(x)unique(x))
shinyServer(function(input, output) {
output$plot <- renderUI({
a <- lapply(1:length(l), function(i) {
col <- l[[i]]
lapply(1:min(length(col),10), function(j) {
interp(
quote(bsToggleButton(nm,lb))
,.values=list(nm=paste0(names(l)[i],'_val_', j),lb=col[j]))
})
})
pars <- lapply(1:length(l), function(i) {
list(inputId =paste0('btng_',names(l)[i]), label = '', value = '',a[[i]])
})
col_list<-lapply(1:length(l), function(i) {
interp(
quote(
bsCollapsePanel(names(l)[i],
fluidRow(
column(4,
do.call(bsButtonGroup,unlist(pars[i]))
)
),
id=nm,value=val))
,.values=list(i=i,nm=paste0('test_',i),val='')
)
})
pars2 <- list(multiple = TRUE, open = "test_1", id = "collapse1",col_list)
do.call(bsCollapse,unlist(pars2))
})
})