-
Notifications
You must be signed in to change notification settings - Fork 8
/
functions.R
145 lines (117 loc) · 4.63 KB
/
functions.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
#' Print step number
#'
#' Generates a closure (i.e. function with data) that prints a step header and increments the step number each time it is called.
#'
make_step_counter_function <- function() {
step <- 0
function(content) {
step <<- step 1
paste0("**<mark><input type='checkbox'>", " Step ", step, ")</mark> ", content, "**")
}
}
#' Generate example HTML
#'
#' Generates a closure (i.e. function with data) that prints a peice of RMarkdown markup and the results of rendering it to HTML.
#' The function generated can remember the information from previous calls and append content.
#'
#' @param content (\code{character} of lenght one) RMarkdown text to display and render.
#'
make_markdown_example_function <- function(content, horizontal = FALSE) {
counter <- 0
previous_content <- ""
function(content, cumulative = FALSE, height = NULL, prefix = FALSE, show_knit_button = FALSE, render = TRUE) {
# Set default figure height
if (is.null(height)) {
height <- (length(gregexpr("\\n", content)[[1]]) 1) * 20
}
# increment counter so that file names can be unique
counter <<- counter 1
# implement content saving
currrent_content <- content
if (cumulative) {
if (prefix) {
content <- paste0(content, previous_content)
} else {
content <- paste0(previous_content, content)
}
previous_content <<- content
}
# get input document information
current_file_name <- knitr:::knit_concord$get("infile")
current_folder <- normalizePath(knitr:::.knitEnv$input.dir)
# Create source Rmd file
source_path <- tempfile(pattern = "rmarkdown_example", fileext = ".Rmd", tmpdir = current_folder)
cat(content, file = source_path)
# Render source file to html
current_knit_opts <- opts_chunk$get() # Save external knit parameters to restore later
if (render) {
output_path <- tempfile(pattern = "rmarkdown_example", fileext = ".html", tmpdir = current_folder)
opts_chunk$restore() # Set knitr to use default chunk options
rmarkdown::render(input = source_path, output_file = output_path, quiet = TRUE, output_format = "html_fragment")
}
# Generate html to display source
source_html <- paste0("<pre class = 'rmd_example_code'>", currrent_content, "</pre>")
# Generate html to display knit image
img_path <- "./images/pressing_knit_down_arrow.png"
image_html <- paste0("<img src='", img_path, "' class='knit_image'>")
# Rendered HTML
if (render) {
result_html <- readChar(output_path, file.info(output_path)$size)
}
on.exit({
do.call(opts_chunk$set, current_knit_opts) # Restore external knit parameters
file.remove(source_path)
if (render) { file.remove(output_path) }
})
# Display result
if (horizontal) {
cat(paste0('<div class = "rmd_example_container">',
'<div class = "rmd_example_inner rmd_example_source">', source_html, '</div>',
ifelse(render, paste0('<div class = "rmd_example_inner rmd_example_result">', result_html, '</div>'), ""),
'</div><div style="clear: left;"></div>'))
} else {
cat(paste0('<div class = "rmd_example_container">',
'<div class = "rmd_example_source">', source_html, '</div>',
ifelse(show_knit_button, image_html, ""),
ifelse(render, paste0('<div class = "rmd_example_result">', result_html, '</div>'), ""),
'</div><div style="clear: left;"></div>'))
}
}
}
#' Scrolls iframes
#'
#' Prints Javascript to make iframes scrolled down when page loads
pre_scroll_iframe <- function() {
cat('
<script type="text/javascript">
$(window).load(function ()
{
var $contents = $(".example_frame").contents();
$contents.scrollTop(10000);
});
</script>
')
}
#' Glossary
#'
#' Handles the defining and printing of glossary terms.
make_glossary_function <- function() {
glossary <- list()
function(term = NULL, description = NULL, display_glossary = FALSE) {
if (display_glossary) {
for (index in seq_along(glossary)) {
glossary <<- glossary[order(names(glossary))]
cat(paste0("<strong><ins>", names(glossary)[index], "</ins></strong>: ", glossary[[index]], "\n\n"))
}
} else {
if (is.null(term) | is.null(description)) {
stop("Glossary term and/or description required")
}
# Save term in glossary
glossary[term] <<- description
# Print formatted term
rendered_term <- paste0("<strong><ins>", term, "</ins></strong>")
return(rendered_term)
}
}
}