/
knitUtil.R
318 lines (306 loc) · 16.2 KB
/
knitUtil.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
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
#' @title Specific utilities for use in a knitr document.
#'
#' @description Specific utilities for pretty printing various items in a knitr document.
#'
#' @details
#' \itemize{
#' \item \code{kCounts} is used to convert numeric numbers to \sQuote{word} numbers in a sentence.
#' \item \code{kPvalue} is used to print \sQuote{pretty} p-values.
#' \item \code{purl2} is used to create a modified (see below) Stangled or purled script.
#' \item \code{reproInfo} is used to print \sQuote{reproducibility information} for the document.
#' }
#'
#' @note In \code{reproInfo}, \code{elapsed} can be used to print the time it took to process the document by sending the elapsed time for processing to this argument. The simplest way to get an approximate elapsed time is to put \code{st <- proc.time()} very early (first line?) in your knitr code, put \code{et <- proc.time()-st} very late in your knitr code (i.e., just prior to \code{reproInfo}), and then used \code{elapsed=et["user.self"]+et["sys.self"]} in \code{reproInfo}.
#'
#' @param value A single numeric count or p-value.
#' @param capitalize A logical that indicates if the returned words should be capitalized or not (the default).
#' @param digits Number of decimal places to round the values to.
#' @param include.p A logical that indicates whether the result should be a character string with \dQuote{p=} appended to the numerical result.
#' @param latex A logical that indicates whether the resultant p-value string should be contained within dollar signs to form a latex formula.
#' @param file A string that contains the root name of the .RNW file. This will also be the name of the resultant purled file with .R appended.
#' @param out.dir A string that indicates the directory structure in which the purled file should be located. This should not have a forward slash at the end.
#' @param newname A string for the output filename (without the extension) from \code{purl2}.
#' @param moreItems A string that contains additional words that when found in the purled file will result in the entire line with those words to be deleted.
#' @param blanks A string that indicates if blank lines should be removed. If \code{blanks="all"} then all blank lines will be removed. If \code{blanks="extra"} then only \dQuote{extra} blanks lines will be removed (i.e., one blank line will be left where there was originally more than one blank line).
#' @param topnotes A character vector of lines to be added to the top of the output file. Each value in the vector will be placed on a single line at the top of the output file.
#' @param delHeader A single character that denotes the top and bottom of a block of lines that should be deleted from the script created by \code{purl2}.
#' @param timestamp A logical that indicates whether a timestamp comment should be appended to the bottom of the script created by \code{purl2}.
#' @param out A string that indicates the type of output from \code{reproInfo} -- Markdown, LaTeX, or simple R code.
#' @param rqrdPkgs A string vector that contains packages that are required for the vignette and for which all dependencies should be found.
#' @param elapsed A numeric, usually from \code{proc.time}, that is the time required to run the vignette. If \code{NULL} then this output will not be used. See the note below.
#' @param width A numeric that indicates the width to use for wrapping the reproducibility information when \code{out="r"}.
#' @param addTOC A logical that indicates whether or not a table of contents entry for the reproducibility section should be added to the LaTeX output. Used only if \R{out="latex"}
#' @param newpage A logical that indicates whether or not the reproducibility information should begin on a new page. Used only if \R{out="latex"}
#' @param links A named character vector that will add a links bullet to the reproducibility information. The names will be shown and the values are the links. Used only if \R{out="markdown}.
#' @param closeGraphics A logical that indicates whether the graphics device should be closed or not.
#' @param ind An integer that indicates the CRAN mirror to use. Defaults to 1.
#' @param \dots Additional arguments for the original \code{purl}.
#'
#' @return
#' \itemize{
#' \item \code{kCounts} returns a numeric value if the count is less than zero or greater than ten and returns a character string of the number \sQuote{name}. See the examples.
#' \item \code{kPvalue} returns a character string of the supplied p-value rounded to the requested number of digits or a character string that indicates what the p-value is less than the value with a \sQuote{5} in the \code{digits}+1 place. See the examples.
#' \item \code{purl2} is a modification of \code{purl} from \pkg{knitr} that creates a file with the same name as \code{file} but with lines removed that contain certain words (those found in \code{ItemsToRemove} and \code{moreItems}).
#' \item \code{reproInfo} returns Markdown, LaTeX, or R code that prints \dQuote{reproducibility information} at the bottom of the knitted document.
#' }
#'
#' @author Derek H. Ogle, \email{DerekOgle51@gmail.com}
#'
#' @seealso See \code{\link{formatC}} for functionality similar to \code{kPvalue}. See \code{purl} and \code{\link[knitr]{knit}} in \pkg{knitr} for functionality similar to \code{purl2}.
#'
#' @keywords manip
#'
#' @aliases kCounts kPvalue purl2 reproInfo
#'
#' @examples
#' kCounts(7)
#' kCounts(17)
#' kCounts(0)
#' kCounts(-6)
#' kCounts(3,capitalize=TRUE)
#'
#' kPvalue(0.123456789)
#' kPvalue(0.000123456)
#' kPvalue(0.000012345)
#' kPvalue(0.000012345,include.p=FALSE)
#' kPvalue(0.000012345,include.p=FALSE,latex=FALSE)
#'
#' @rdname knitUtil
#' @export
kCounts <- function(value,capitalize=FALSE) {
if (value <= 10 & value >= 0) {
numwords <- c("zero","one","two","three","four","five",
"six","seven","eight","nine","ten")
value <- numwords[value+1]
if (capitalize) value <- capFirst(value)
}
value
}
#' @rdname knitUtil
#' @export
kPvalue <- function(value,digits=4,include.p=TRUE,latex=TRUE) {
if(round(value,digits) == 0) {
res <- paste0("<",formatC(value,format="f",digits=digits),"5")
if(include.p) res <- paste0("p",res)
} else if (value>1) {
res <- ">1"
if(include.p) res <- paste0("p",res)
} else {
res <- formatC(value,format="f",digits=digits)
if (include.p) res <- paste0("p=",res)
}
if (latex) paste0("$",res,"$")
else res
}
#' @rdname knitUtil
#' @export
purl2 <- function(file,out.dir=NULL,newname=NULL,topnotes=NULL,
moreItems=NULL,blanks=c("extra","all","none"),
delHeader=NULL,timestamp=TRUE,...) { # nocov start
if (!requireNamespace("knitr")) STOP("'purl2' requires the 'knitr' package to be installed.")
else {
## Some checks
blanks <- match.arg(blanks)
## if no file is sent then stop
if (missing(file)) STOP("Must given filename with extenstion.")
## Get input directory (from filename) and potentially change the output directory
in.dir <- file.path(dirname(file))
if (is.null(out.dir)) out.dir <- in.dir
## Get just the filename prefix (i.e., remove directory and .Rnw or .Rmd if it exists)
fn.pre <- unlist(strsplit(basename(file),"\\.Rnw|\\.rnw|\\.RNW|\\.rmd|\\.Rmd|\\.RMD"))
## Make intermediate file for the tangled result (in in.dir)
fn.Ri <- iMakeFilename(fn.pre,".R",in.dir)
## Make output file (in out.dir)
if (is.null(newname)) fn.Ro <- iMakeFilename(fn.pre,".R",out.dir)
else fn.Ro <- iMakeFilename(newname,".R",out.dir)
## Remove already existing .R files with the same name
# Delete the original tangled file
unlink(fn.Ri)
unlink(fn.Ro)
## Purl the results and then read those results back into flines
# handle documentation (i.e., pure code)
knitr::purl(file,fn.Ri,documentation=1)
flines <- readLines(fn.Ri)
## Expand itemsToRemove if something in moreItems
itemsToRemove <- iMakeItemsToRemove(moreItems)
## Find the rows with the items to remove and then remove those items if they exist
for (i in seq_along(itemsToRemove)) {
RowsToRemove <- grep(itemsToRemove[i],flines)
if (length(RowsToRemove)>0) flines <- flines[-RowsToRemove]
}
## Delete blocks if directed
if (!is.null(delHeader)) {
delLines <- grep(delHeader,flines)
ndel <- length(delLines)
if (ndel>0) {
if (is.odd(ndel))WARN("Odd number of lines contain 'delHeader`, no blocks deleted")
else {
delLines1 <- delLines[is.odd(seq_len(ndel))]
delLines2 <- delLines[is.even(seq_len(ndel))]
delLines <- NULL
for (i in seq_len(ndel/2)) delLines <- c(delLines,seq(delLines1[i],delLines2[i],1))
flines <- flines[-delLines]
}
}
}
## Remove the blank lines as directed in blanks argument
if (blanks=="all") {
flines <- flines[-which(flines=="")]
} else {
if (blanks=="extra") {
blankLines <- which(flines=="")
extras <- which(c(2,diff(blankLines))==1)
if (length(extras)>0) flines <- flines[-blankLines[extras]]
}
}
## Add topnotes if any given
if (!is.null(topnotes)) flines <- c(paste("#",topnotes),flines)
## Delete first line if it is blank (often the case after removeItems)
if (flines[1]=="") flines <- flines[-1]
## Add timestampe if asked for
if (timestamp) flines <- c(flines,"",paste("# Script created at",Sys.time()))
## Delete the original purled/stangled file
unlink(fn.Ri)
## Write out a new purled/stangled file
write(flines,fn.Ro)
}
} # nocov end
#' @rdname knitUtil
#' @export
reproInfo <- function(out=c("r","markdown","latex"),rqrdPkgs=NULL,elapsed=NULL,
width=0.95*getOption("width"),
addTOC=TRUE,newpage=FALSE,links=NULL,
closeGraphics=TRUE,ind=1) { # nocov start
## Set a standard mirror (helps avoid a common error when knitting)
utils::chooseCRANmirror(ind=ind)
## Process the session info
ses <- iProcessSessionInfo()
## Handle the rqrdPkgs
if (is.null(rqrdPkgs)) rqrdPkgs <- "None given.\n"
else {
deps <- iGetAllDependencies(rqrdPkgs)
deps <- deps[!(deps %in% rqrdPkgs)]
rqrdPkgs <- paste0(paste(rqrdPkgs,collapse=", ")," and ",
ifelse(length(rqrdPkgs)>1,"their","its"),
" dependencies (",paste(deps,collapse=", "),")\n")
}
## Get date and time
compDate <- format(Sys.time(),'%a %b %d %Y')
compTime <- format(Sys.time(),'%X')
if (!is.null(elapsed)) elapsed <- round(elapsed,2)
## Prepare output depending on type of out
out <- tolower(match.arg(out))
if (out=="r") iReproInfoR(rqrdPkgs,ses,elapsed,compDate,compTime,width)
else if (out=="latex") iReproInfoLaTeX(rqrdPkgs,ses,elapsed,compDate,
compTime,addTOC,newpage)
else iReproInfoMarkdown(rqrdPkgs,ses,elapsed,compDate,compTime,links)
if (closeGraphics) grDevices::graphics.off()
} # nocov end
##################################################################
## Internal files used in knitUtils functions
##################################################################
iMakeItemsToRemove <- function(moreItems) {
mainItems <- c("Stangle","SweaveHooks","purl2","reproInfo","#line",
"## ","graphics.off()","purl")
c(mainItems,moreItems)
}
iMakeFilename <- function(file,extension,directory=NULL) {
res <- paste0(file,extension)
if (!is.null(directory)) res <- paste(directory,res,sep="/")
res
}
iGetAllDependencies <- function(pkgs) { # nocov start
## Check if repository has been set
if ("@CRAN@" %in% options("repos")$repos && interactive()) {
cat(gettext("--- Please select a CRAN mirror for this session ---"),"\n",sep="")
utils::flush.console()
utils::chooseCRANmirror()
}
## Get a list of packages that pkgs depends on
deps <- tools::package_dependencies(pkgs,utils::available.packages(),
which=c("Depends","Imports"))
## remove list, sort, and remove names attribute
deps <- sort(unlist(deps))
attr(deps,"names") <- NULL
# return original list and dependents
unique(c(pkgs,deps))
} # nocov end
iProcessSessionInfo <- function() { # nocov start
mkLabel <- function(L, n) {
# this is from print.sessionInfo in utils package
vers <- sapply(L[[n]], function(x) x[["Version"]])
pkg <- sapply(L[[n]], function(x) x[["Package"]])
paste(pkg, vers, sep = "_")
} # end internal mkLabel
ses <- utils::sessionInfo()
sys <- paste0(Sys.info()["sysname"],", ",ses$platform,"\n")
vers <- paste0(ses$R.version$version.string,"\n")
bpkgs <- sort(ses$basePkgs)
bpkgsP <- paste0(paste(sort(ses$basePkgs),collapse=", "),"\n")
opkgs <- names(ses$otherPkgs)
opkgsP <- paste0(paste(sort(mkLabel(ses,"otherPkgs")),collapse=", "),"\n")
lpkgs <- names(ses$loadedOnly)
lpkgsP <- paste0(paste(sort(mkLabel(ses,"loadedOnly")),collapse=", "),"\n")
list(sys=sys,vers=vers,bpkgs=bpkgs,bpkgsP=bpkgsP,opkgs=opkgs,opkgsP=opkgsP,lpkgs=lpkgs,lpkgsP=lpkgsP)
} # nocov end
iReproInfoLaTeX <- function(rqrdPkgs,ses,elapsed,compDate,compTime,
addTOC,newPage) { # nocov start
outp <- character()
if (newPage) {
if (addTOC) outp <- "\\cleardoublepage\n\\phantomsection\n"
else outp <- "\\newpage\n"
}
outp <- paste0(outp,"\\section*{Reproducibility Information}\n")
if (addTOC) outp <- paste(outp,"\\addcontentsline{toc}{section}{Reproducibility Information}\n")
cat(outp)
outp <- paste0("\\begin{Itemize}\n")
outp <- paste0(outp," \\item \\textbf{Compiled Date:} ",compDate,"\n")
outp <- paste0(outp," \\item \\textbf{Compiled Time:} ",compTime,"\n")
if (!is.null(elapsed)) outp <- paste0(outp," \\item \\textbf{Code Execution Time:} ",elapsed," s\n")
outp <- paste0(outp," \\item \\textbf{R Version:} ",ses$vers)
outp <- paste0(outp," \\item \\textbf{System:} ",gsub("[_]","\\\\_",ses$sys))
outp <- paste0(outp," \\item \\textbf{Base Packages:} ",gsub("[_]","\\\\_",ses$bpkgsP))
outp <- paste0(outp," \\item \\textbf{Required Packages:} ",rqrdPkgs)
outp <- paste0(outp," \\item \\textbf{Other Packages:} ",gsub("[_]","\\\\_",ses$opkgsP))
outp <- paste0(outp," \\item \\textbf{Loaded-Only Packages:} ",gsub("[_]","\\\\_",ses$lpkgsP))
outp <- paste0(outp,"\\end{Itemize}\n\n")
cat(outp)
} # nocov end
iReproInfoR <- function(rqrdPkgs,ses,elapsed,compDate,compTime,width) { # nocov start
outp <- cat("Reproducibility Information\n")
outp <- paste0(outp," Compiled Date: ",compDate,"\n")
outp <- paste0(outp," Compiled Time: ",compTime,"\n")
if (!is.null(elapsed)) outp <- paste0(outp," Code Execution Time: ",elapsed," s\n")
outp <- paste0(outp,"\n")
cat(outp)
outp <- paste0(" R Version: ",ses$vers)
outp <- paste0(outp," System: ",ses$sys)
cat(outp)
outp <- paste0("Base Packages: ",ses$bpkgsP)
cat(unlist(strwrap(outp,indent=2,exdent=4,simplify=FALSE,width=width)),sep="\n")
outp <- paste0("Required Packages: ",rqrdPkgs)
cat(unlist(strwrap(outp,indent=2,exdent=4,simplify=FALSE,width=width)),sep="\n")
outp <- paste0("Other Packages: ",ses$opkgsP)
cat(unlist(strwrap(outp,indent=2,exdent=4,simplify=FALSE,width=width)),sep="\n")
outp <- paste0("Loaded-Only Packages: ",ses$lpkgsP)
cat(unlist(strwrap(outp,indent=2,exdent=4,simplify=FALSE,width=width)),sep="\n")
} # nocov end
iReproInfoMarkdown <- function(rqrdPkgs,ses,elapsed,compDate,
compTime,links) { # nocov start
cat("## Reproducibility Information\n\n")
outp <- paste0("* **Compiled Date:** ",compDate,"\n")
outp <- paste0(outp,"* **Compiled Time:** ",compTime,"\n")
if (!is.null(elapsed)) outp <- paste0(outp,"* **Code Execution Time:** ",elapsed," s\n")
oupt <- paste0(outp,"\n")
outp <- paste0(outp,"* **R Version:** ",ses$vers)
outp <- paste0(outp,"* **System:** ",gsub("[_]","\\\\_",ses$sys))
outp <- paste0(outp,"* **Base Packages:** ",gsub("[_]","\\\\_",ses$bpkgsP))
outp <- paste0(outp,"* **Required Packages:** ",rqrdPkgs)
outp <- paste0(outp,"* **Other Packages:** ",gsub("[_]","\\\\_",ses$opkgsP))
outp <- paste0(outp,"* **Loaded-Only Packages:** ",gsub("[_]","\\\\_",ses$lpkgsP))
if (!is.null(links)) {
outp <- paste0(outp,"* **Links:** ")
outp <- paste0(outp,paste(paste0("[",names(links),"](",links,")"),collapse=" / "),"\n")
}
cat(outp)
} # nocov end