Here are the examples of the r api knitr-kable taken from open source projects. By voting up you can indicate which examples are most useful and appropriate.
179 Examples
19
File: car-report-1.R, author: wibeasley, license: GNU General Public License v2.0
summary(m2)$coef %>% knitr::kable(digits = 2, format = "markdown")
19
File: report-te-1.R, author: wibeasley, license: GNU General Public License v2.0
summary(m3)$coef %>% knitr::kable(digits = 2, format = "markdown")
19
File: violin.R, author: wiesenfa, license: GNU General Public License v2.0
violin.bootstrap.list = function(x, ...) {
ken = melt(kendall.bootstrap.list(x))
colnames(ken)[2] = "Task"
cat("\n\nSummary Kendall's tau:\n")
ss = ken %>% group_by(Task) %>% summarise(mean = mean(value,
na.rm = T), median = median(value, na.rm = T), q25 = quantile(value,
probs = 0.25, na.rm = T), q75 = quantile(value, probs = 0.75,
na.rm = T)) %>% arrange(desc(median))
print(knitr::kable(as.data.frame(ss)))
noResults < - sapply(split(ss, ss$Task), function(x) all(is.na(x[,
-1])))
if (any(noResults)) {
cat("\nNo Kendall's tau could be calculated for any bootstrap sample in task ",
names(noResults)[noResults], " because of missing variability. Task dropped from figure.",
fill = F)
ken < - ken %>% filter(Task %in% names(noResults)[!noResults])
}
xAxisText < - element_blank()
if (length(x$data) > 1) {
xAxisText < - element_text(angle = 90, vjust = 0.5, hjust = 1)
}
ken %>% mutate(Task = factor(.data$Task, levels = ss$Task)) %>%
ggplot(aes(Task, value)) + geom_violin(alpha = 0.3, color = NA,
na.rm = TRUE, fill = "blue") + geom_boxplot(width = 0.1,
na.rm = TRUE, fill = "white") + theme(axis.text.x = xAxisText,
legend.position = "none") + ylab("Kendall's tau") + scale_y_continuous(limits = c(min(min(ken$value),
0), max(max(ken$value), 1)))
}
19
File: view.R, author: WinVector, license: GNU General Public License v2.0
view.data.frame < - function(x, ..., title = paste(deparse(substitute(x)),
collapse = " "), n = 200) {
wrapr::stop_if_dot_args(substitute(list(...)), "view.data.frame")
if (interactive()) {
do.call("View", list(x, title = title), envir = globalenv())
}
else {
if (requireNamespace("knitr", quietly = TRUE)) {
knitr::kable(head(x, n = n), caption = title)
}
else {
print(format(head(x, n = n)))
}
}
}
19
File: Tex.sde.r, author: acguidoum, license: GNU General Public License v2.0
TEX.sde.default < - function(object, ...) {
greek < - c("alpha", "theta", "tau", "beta", "vartheta", "pi",
"upsilon", "gamma", "varpi", "phi", "delta", "kappa",
"rho", "iota", "varphi", "epsilon", "lambda", "varrho",
"chi", "varepsilon", "mu", "sigma", "psi", "zeta", "nu",
"varsigma", "omega", "eta", "xi", "Gamma", "Lambda",
"Sigma", "Psi", "Delta", "Xi", "Upsilon", "Omega", "Theta",
"Pi", "Phi")
greek0 < - c(paste0(greek, "0"))
greek1 < - c(paste0(greek, "1"))
greek2 < - c(paste0(greek, "2"))
greek3 < - c(paste0(greek, "3"))
greek4 < - c(paste0(greek, "4"))
greek5 < - c(paste0(greek, "5"))
greek6 < - c(paste0(greek, "6"))
greek7 < - c(paste0(greek, "7"))
greek8 < - c(paste0(greek, "8"))
greek9 < - c(paste0(greek, "9"))
greek10 < - c(paste0(greek, "10"))
greek11 < - c(paste0(greek, "11"))
greek12 < - c(paste0(greek, "12"))
greek13 < - c(paste0(greek, "13"))
greek14 < - c(paste0(greek, "14"))
greek15 < - c(paste0(greek, "15"))
greek16 < - c(paste0(greek, "16"))
greek17 < - c(paste0(greek, "17"))
greek18 < - c(paste0(greek, "18"))
greek19 < - c(paste0(greek, "19"))
greek20 < - c(paste0(greek, "20"))
greek21 < - c(paste0(greek, "21"))
greek22 < - c(paste0(greek, "22"))
greek23 < - c(paste0(greek, "23"))
greek24 < - c(paste0(greek, "24"))
greek25 < - c(paste0(greek, "25"))
greek26 < - c(paste0(greek, "26"))
greek27 < - c(paste0(greek, "27"))
greek28 < - c(paste0(greek, "28"))
greek29 < - c(paste0(greek, "29"))
greek30 < - c(paste0(greek, "30"))
greek_list < - setNames(paste0("\\", greek), greek)
greek_list0 < - setNames(paste0("\\", greek, "_", "{0}"),
greek0)
greek_list1 < - setNames(paste0("\\", greek, "_", "{1}"),
greek1)
greek_list2 < - setNames(paste0("\\", greek, "_", "{2}"),
greek2)
greek_list3 < - setNames(paste0("\\", greek, "_", "{3}"),
greek3)
greek_list4 < - setNames(paste0("\\", greek, "_", "{4}"),
greek4)
greek_list5 < - setNames(paste0("\\", greek, "_", "{5}"),
greek5)
greek_list6 < - setNames(paste0("\\", greek, "_", "{6}"),
greek6)
greek_list7 < - setNames(paste0("\\", greek, "_", "{7}"),
greek7)
greek_list8 < - setNames(paste0("\\", greek, "_", "{8}"),
greek8)
greek_list9 < - setNames(paste0("\\", greek, "_", "{9}"),
greek9)
greek_list10 < - setNames(paste0("\\", greek, "_", "{10}"),
greek10)
greek_list11 < - setNames(paste0("\\", greek, "_", "{11}"),
greek11)
greek_list12 < - setNames(paste0("\\", greek, "_", "{12}"),
greek12)
greek_list13 < - setNames(paste0("\\", greek, "_", "{13}"),
greek13)
greek_list14 < - setNames(paste0("\\", greek, "_", "{14}"),
greek14)
greek_list15 < - setNames(paste0("\\", greek, "_", "{15}"),
greek15)
greek_list16 < - setNames(paste0("\\", greek, "_", "{16}"),
greek16)
greek_list17 < - setNames(paste0("\\", greek, "_", "{17}"),
greek17)
greek_list18 < - setNames(paste0("\\", greek, "_", "{18}"),
greek18)
greek_list19 < - setNames(paste0("\\", greek, "_", "{19}"),
greek19)
greek_list20 < - setNames(paste0("\\", greek, "_", "{20}"),
greek20)
greek_list21 < - setNames(paste0("\\", greek, "_", "{21}"),
greek21)
greek_list22 < - setNames(paste0("\\", greek, "_", "{22}"),
greek22)
greek_list23 < - setNames(paste0("\\", greek, "_", "{23}"),
greek23)
greek_list24 < - setNames(paste0("\\", greek, "_", "{24}"),
greek24)
greek_list25 < - setNames(paste0("\\", greek, "_", "{25}"),
greek25)
greek_list26 < - setNames(paste0("\\", greek, "_", "{26}"),
greek26)
greek_list27 < - setNames(paste0("\\", greek, "_", "{27}"),
greek27)
greek_list28 < - setNames(paste0("\\", greek, "_", "{28}"),
greek28)
greek_list29 < - setNames(paste0("\\", greek, "_", "{29}"),
greek29)
greek_list30 < - setNames(paste0("\\", greek, "_", "{30}"),
greek30)
mem_sde < - c("m", "S", "m1", "m2", "m3", "S1", "S2", "S3",
"C12", "C13", "C23")
mem_sde_tex < - c("m(t)", "S(t)", "m_{1}(t)", "m_{2}(t)",
"m_{3}(t)", "S_{1}(t)", "S_{2}(t)", "S_{3}(t)", "C_{12}(t)",
"C_{13}(t)", "C_{23}(t)")
mem_sde_list < - setNames(mem_sde_tex, mem_sde)
var_sde < - c("x", "y", "z", "w", "w1", "w2", "w3", "X", "Y",
"Z", "W", "W1", "W2", "W3")
var_sde_tex < - c("X_{t}", "Y_{t}", "Z_{t}", "W_{t}", "W_{1,t}",
"W_{2,t}", "W_{3,t}", "X_{t}", "Y_{t}", "Z_{t}", "W_{t}",
"W_{1,t}", "W_{2,t}", "W_{3,t}")
var_sde_list < - setNames(var_sde_tex, var_sde)
greek_env < - list2env(as.list(c(greek_list, greek_list0,
greek_list1, greek_list2, greek_list3, greek_list4, greek_list5,
greek_list6, greek_list7, greek_list8, greek_list9, greek_list10,
greek_list11, greek_list12, greek_list13, greek_list14,
greek_list15, greek_list16, greek_list17, greek_list18,
greek_list19, greek_list20, greek_list21, greek_list22,
greek_list23, greek_list24, greek_list25, greek_list26,
greek_list27, greek_list28, greek_list29, greek_list30,
mem_sde_list, var_sde_list)), parent = emptyenv())
unary_op < - function(left, right) {
force(left)
force(right)
function(e1) {
paste0(left, e1, right)
}
}
binary_op < - function(sep) {
force(sep)
function(e1, e2) {
if (missing(e2)) {
paste0(" - ", e1)
}
else {
paste0(e1, sep, e2)
}
}
}
f_env < - new.env(parent = emptyenv())
f_env$"+" < - binary_op(" + ")
f_env$"-" < - binary_op(" - ")
f_env$"*" < - binary_op(" \\, ")
f_env$"/" < - binary_op(" / ")
f_env$"^" < - binary_op("^")
f_env$"[" < - binary_op("_")
f_env$"==" < - binary_op("=")
f_env$" < =" < - binary_op(" \\leq ")
f_env$">=" < - binary_op(" \\geq ")
f_env$"&" < - binary_op(" \\,\\&\\, ")
f_env$"|" < - binary_op(" \\mid ")
f_env$"," < - binary_op(" \\, ")
f_env$"{" < - unary_op("\\left{ ", " \\right}")
f_env$"(" < - unary_op("\\left( ", " \\right)")
f_env$sin < - unary_op("\\sin(", ")")
f_env$cos < - unary_op("\\cos(", ")")
f_env$tan < - unary_op("\\tan(", ")")
f_env$exp < - unary_op("\\exp(", ")")
f_env$expm1 < - unary_op("\\left(\\exp(", ")-1\\right)")
f_env$sqrt < - unary_op("\\sqrt{", "}")
f_env$log < - unary_op("\\log(", ")")
f_env$log1p < - unary_op("\\log\\left(1+", "\\right)")
f_env$abs < - unary_op("\\left| ", "\\right| ")
f_env$sign < - unary_op("\\mathop{\\mathrm{sgn}}(", ")")
f_env$"/" < - function(a, b) {
paste0("\\frac{", a, "}{", b, "}")
}
f_env$P < - unary_op(" \\mathsf{P}(", ")")
f_env$F < - unary_op(" \\mathsf{F}(", ")")
f_env$f < - unary_op(" \\mathsf{f}(", ")")
f_env$S < - unary_op(" \\mathsf{S}(", ")")
f_env$H < - unary_op(" \\mathsf{H}(", ")")
f_env$h < - unary_op(" \\mathsf{h}(", ")")
f_env$E < - unary_op(" \\mathsf{E}(", ")")
f_env$V < - unary_op(" \\mathsf{V}(", ")")
f_env$COV < - unary_op(" \\mathsf{COV}(", ")")
clone_env < - function(env, parent = parent.env(env)) {
list2env(as.list(env), parent = parent)
}
latex_env < - function(expr) {
greek_env
}
if (class(object) == "data.frame") {
cat("%%% LaTeX table generated in R", strsplit(version[["version.string"]],
" ")[[1]][3], "by TEX.sde() method", "\n")
cat("%%% Copy and paste the following output in your LaTeX file",
"\n\n")
cat(knitr::kable(object, format = "latex", ...), "\n")
}
else if (class(object) == "MCM.sde") {
tab < - object$MC
expr < - parse(text = rownames(tab))
names < - all.names(expr)
greek_env < - list2env(as.list(c(greek_list, greek_list1,
greek_list2, greek_list3, greek_list4, greek_list5,
greek_list6, greek_list7, greek_list8, greek_list9,
greek_list10, mem_sde_list)), parent = emptyenv())
symbol_list < - setNames(as.list(names), names)
symbol_env < - list2env(symbol_list, parent = f_env)
greek_env < - clone_env(greek_env, parent = symbol_env)
rownames(tab) < - sapply(1:length(expr), function(i) eval(expr[i],
latex_env(expr[i])))
greek_test < - as.list(c(mem_sde, mem_sde_tex, greek,
greek1, greek2, greek3, greek4, greek5, greek6, greek7,
greek8, greek9, greek10, greek_list, greek_list1,
greek_list2, greek_list3, greek_list4, greek_list5,
greek_list6, greek_list7, greek_list8, greek_list9,
greek_list10))
rownames(tab) < - sapply(1:length(expr), function(i) ifelse(rownames(tab)[i] %in%
greek_test, paste0("$", rownames(tab)[i], "$"), rownames(tab)[i]))
colnames(tab)[length(names(tab))] < - "CI( 2.5 \\% , 97.5 \\% )"
cat("%%% LaTeX table generated in R", strsplit(version[["version.string"]],
" ")[[1]][3], "by TEX.sde() method", "\n")
cat("%%% Copy and paste the following output in your LaTeX file",
"\n\n")
cat(knitr::kable(tab, format = "latex", escape = FALSE,
...), "\n")
}
else if (class(object) == "expression") {
expr < - object
names < - all.names(expr)
symbol_list < - setNames(as.list(names), names)
symbol_env < - list2env(symbol_list, parent = f_env)
greek_env < - clone_env(greek_env, parent = symbol_env)
if (length(expr) == 2) {
dr = eval(expr[[1]], latex_env(expr[[1]]))
df = eval(expr[[2]], latex_env(expr[[2]]))
body < - paste("%%% LaTeX equation generated in R",
strsplit(version[["version.string"]], " ")[[1]][3],
"by TEX.sde() method")
body < - c(body, paste("%%% Copy and paste the following output in your LaTeX file\n"))
body < - c(body, paste("\\begin{equation}\\label{eq:}"))
body < - c(body, paste("dX_{t} =", dr, "\\:dt + ",
df, "\\:dW_{t}"))
body < - c(body, paste("\\end{equation}"))
structure(body, class = "Latex")
}
else if (length(expr) == 4) {
dr1 = eval(expr[[1]], latex_env(expr[[1]]))
dr2 = eval(expr[[2]], latex_env(expr[[2]]))
df1 = eval(expr[[3]], latex_env(expr[[3]]))
df2 = eval(expr[[4]], latex_env(expr[[4]]))
body < - paste("%%% LaTeX equation generated in R",
strsplit(version[["version.string"]], " ")[[1]][3],
"by TEX.sde() method")
body < - c(body, paste("%%% Copy and paste the following output in your LaTeX file\n"))
body < - c(body, paste("\\begin{equation}\\label{eq:}"))
body < - c(body, paste("\\begin{cases}"))
body < - c(body, paste("\\begin{split}"))
body < - c(body, paste("dX_{t} &=", dr1, "\\:dt + ",
df1, "\\:dW_{1,t}", "\\\\"))
body < - c(body, paste("dY_{t} &=", dr2, "\\:dt + ",
df2, "\\:dW_{2,t}"))
body < - c(body, paste("\\end{split}"))
body < - c(body, paste("\\end{cases}"))
body < - c(body, paste("\\end{equation}"))
structure(body, class = "Latex")
}
else if (length(expr) == 6) {
dr1 = eval(expr[[1]], latex_env(expr[[1]]))
dr2 = eval(expr[[2]], latex_env(expr[[2]]))
dr3 = eval(expr[[3]], latex_env(expr[[3]]))
df1 = eval(expr[[4]], latex_env(expr[[4]]))
df2 = eval(expr[[5]], latex_env(expr[[5]]))
df3 = eval(expr[[6]], latex_env(expr[[6]]))
body < - paste("%%% LaTeX equation generated in R",
strsplit(version[["version.string"]], " ")[[1]][3],
"by TEX.sde() method")
body < - c(body, paste("%%% Copy and paste the following output in your LaTeX file\n"))
body < - c(body, paste("\\begin{equation}\\label{eq:}"))
body < - c(body, paste("\\begin{cases}"))
body < - c(body, paste("\\begin{split}"))
body < - c(body, paste("dX_{t} &=", dr1, "\\:dt + ",
df1, "\\:dW_{1,t}", "\\\\"))
body < - c(body, paste("dY_{t} &=", dr2, "\\:dt + ",
df2, "\\:dW_{2,t}", "\\\\"))
body < - c(body, paste("dZ_{t} &=", dr3, "\\:dt + ",
df3, "\\:dW_{3,t}"))
body < - c(body, paste("\\end{split}"))
body < - c(body, paste("\\end{cases}"))
body < - c(body, paste("\\end{equation}"))
structure(body, class = "Latex")
}
}
else if (class(object) == "MEM.sde") {
if (object$dim == 1) {
expr < - c(parse(text = deparse(object$Means)), parse(text = deparse(object$Var)))
names < - all.names(expr)
symbol_list < - setNames(as.list(names), names)
symbol_env < - list2env(symbol_list, parent = f_env)
greek_env < - clone_env(greek_env, parent = symbol_env)
dm = eval(expr[[1]], latex_env(expr[[1]]))
dS = eval(expr[[2]], latex_env(expr[[2]]))
body < - paste("%%% LaTeX equation generated in R",
strsplit(version[["version.string"]], " ")[[1]][3],
"by TEX.sde() method")
body < - c(body, paste("%%% Copy and paste the following output in your LaTeX file\n"))
body < - c(body, paste("\\begin{equation}\\label{eq:}"))
body < - c(body, paste("\\begin{cases}"))
body < - c(body, paste("\\begin{split}"))
body < - c(body, paste("\\frac{d}{dt} m(t) &=", dm,
"\\\\"))
body < - c(body, paste("\\frac{d}{dt} S(t) &=", dS))
body < - c(body, paste("\\end{split}"))
body < - c(body, paste("\\end{cases}"))
body < - c(body, paste("\\end{equation}"))
structure(body, class = "Latex")
}
else if (object$dim == 2) {
expr < - c(parse(text = deparse(object$Means[[1]])),
parse(text = deparse(object$Means[[2]])), parse(text = deparse(object$Var[[1]])),
parse(text = deparse(object$Var[[2]])), parse(text = deparse(object$Var[[3]])))
names < - all.names(expr)
symbol_list < - setNames(as.list(names), names)
symbol_env < - list2env(symbol_list, parent = f_env)
greek_env < - clone_env(greek_env, parent = symbol_env)
dm1 = eval(expr[[1]], latex_env(expr[[1]]))
dm2 = eval(expr[[2]], latex_env(expr[[2]]))
dS1 = eval(expr[[3]], latex_env(expr[[3]]))
dS2 = eval(expr[[4]], latex_env(expr[[4]]))
dC12 = eval(expr[[5]], latex_env(expr[[5]]))
body < - paste("%%% LaTeX equation generated in R",
strsplit(version[["version.string"]], " ")[[1]][3],
"by TEX.sde() method")
body < - c(body, paste("%%% Copy and paste the following output in your LaTeX file\n"))
body < - c(body, paste("\\begin{equation}\\label{eq:}"))
body < - c(body, paste("\\begin{cases}"))
body < - c(body, paste("\\begin{split}"))
body < - c(body, paste("\\frac{d}{dt} m_{1}(t) ~&=",
dm1, "\\\\"))
body < - c(body, paste("\\frac{d}{dt} m_{2}(t) ~&=",
dm2, "\\\\"))
body < - c(body, paste("\\frac{d}{dt} S_{1}(t) ~&=",
dS1, "\\\\"))
body < - c(body, paste("\\frac{d}{dt} S_{2}(t) ~&=",
dS2, "\\\\"))
body < - c(body, paste("\\frac{d}{dt} C_{12}(t) &=",
dC12))
body < - c(body, paste("\\end{split}"))
body < - c(body, paste("\\end{cases}"))
body < - c(body, paste("\\end{equation}"))
structure(body, class = "Latex")
}
else if (object$dim == 3) {
expr < - c(parse(text = deparse(object$Means[[1]])),
parse(text = deparse(object$Means[[2]])), parse(text = deparse(object$Means[[3]])),
parse(text = deparse(object$Var[[1]])), parse(text = deparse(object$Var[[2]])),
parse(text = deparse(object$Var[[3]])), parse(text = deparse(object$Var[[4]])),
parse(text = deparse(object$Var[[5]])), parse(text = deparse(object$Var[[6]])))
names < - all.names(expr)
symbol_list < - setNames(as.list(names), names)
symbol_env < - list2env(symbol_list, parent = f_env)
greek_env < - clone_env(greek_env, parent = symbol_env)
dm1 = eval(expr[[1]], latex_env(expr[[1]]))
dm2 = eval(expr[[2]], latex_env(expr[[2]]))
dm3 = eval(expr[[3]], latex_env(expr[[3]]))
dS1 = eval(expr[[4]], latex_env(expr[[4]]))
dS2 = eval(expr[[5]], latex_env(expr[[5]]))
dS3 = eval(expr[[6]], latex_env(expr[[6]]))
dC12 = eval(expr[[7]], latex_env(expr[[7]]))
dC13 = eval(expr[[8]], latex_env(expr[[8]]))
dC23 = eval(expr[[9]], latex_env(expr[[9]]))
body < - paste("%%% LaTeX equation generated in R",
strsplit(version[["version.string"]], " ")[[1]][3],
"by TEX.sde() method")
body < - c(body, paste("%%% Copy and paste the following output in your LaTeX file\n"))
body < - c(body, paste("\\begin{equation}\\label{eq:}"))
body < - c(body, paste("\\begin{cases}"))
body < - c(body, paste("\\begin{split}"))
body < - c(body, paste("\\frac{d}{dt} m_{1}(t) ~&=",
dm1, "\\\\"))
body < - c(body, paste("\\frac{d}{dt} m_{2}(t) ~&=",
dm2, "\\\\"))
body < - c(body, paste("\\frac{d}{dt} m_{3}(t) ~&=",
dm3, "\\\\"))
body < - c(body, paste("\\frac{d}{dt} S_{1}(t) ~&=",
dS1, "\\\\"))
body < - c(body, paste("\\frac{d}{dt} S_{2}(t) ~&=",
dS2, "\\\\"))
body < - c(body, paste("\\frac{d}{dt} S_{3}(t) ~&=",
dS3, "\\\\"))
body < - c(body, paste("\\frac{d}{dt} C_{12}(t) &=",
dC12, "\\\\"))
body < - c(body, paste("\\frac{d}{dt} C_{13}(t) &=",
dC13, "\\\\"))
body < - c(body, paste("\\frac{d}{dt} C_{23}(t) &=",
dC23))
body < - c(body, paste("\\end{split}"))
body < - c(body, paste("\\end{cases}"))
body < - c(body, paste("\\end{equation}"))
structure(body, class = "Latex")
}
}
else {
return(paste0("TEX.sde() function not available for this class."))
}
}
19
File: generate_report.R, author: bd-R, license: GNU General Public License v3.0
create_report_data < - function(input_data, flagged_data, cleaned_data,
responses, cleaning_true, format) {
assertive::assert_is_data.frame(input_data)
assertive::assert_has_cols(input_data)
assertive::assert_is_data.frame(flagged_data)
assertive::assert_has_cols(flagged_data)
assertive::assert_is_data.frame(cleaned_data)
assertive::assert_is_logical(cleaning_true)
if (!all(format %in% c("html_document", "pdf_document", "md_document",
"word_document"))) {
stop("Format can only be one of html_document, pdf_document")
}
for (question in responses$bdquestions) {
if (length(question$quality.checks) > 0 && length(question$users.answer) >
0) {
question$add_to_report(flagged_data, cleaning_true)
}
}
if (!cleaning_true) {
cleaned_data < - flagged_data
}
input_data < - as.data.frame(input_data)
input_size < - dim(input_data)
output_size < - dim(cleaned_data)
input_unique_species < - "NA"
output_unique_species < - "NA"
earliest_input_date < - "NA"
latest_input_date < - "NA"
earliest_output_date < - "NA"
latest_output_date < - "NA"
if ("scientificName" %in% colnames(input_data)) {
input_unique_species < - length(unique(input_data[, "scientificName"]))
output_unique_species < - length(unique(cleaned_data[,
"scientificName"]))
}
if ("eventDate" %in% colnames(input_data)) {
earliest_input_date < - try(as.POSIXct(unique(input_data[,
"eventDate"]), tz = "UTC"), silent = T)
if (class(earliest_input_date) != "try-error") {
earliest_input_date < - format(min(earliest_input_date),
"%d-%b-%Y")
latest_input_date < - format(max(as.POSIXct(unique(input_data[,
"eventDate"]), tz = "UTC")), "%d-%b-%Y")
}
else {
earliest_input_date < - "NA"
latest_input_date < - "NA"
}
earliest_output_date < - try(as.POSIXct(unique(cleaned_data[,
"eventDate"]), tz = "UTC"), silent = T)
if (class(earliest_output_date) != "try-error") {
earliest_output_date < - format(min(earliest_input_date))
latest_output_date < - format(max(as.POSIXct(unique(cleaned_data[,
"eventDate"]), tz = "UTC")), "%d-%b-%Y")
}
else {
earliest_output_date < - "NA"
latest_output_date < - "NA"
}
}
input_data_meta < - c(input_size[1], input_size[2], input_unique_species,
paste("From ", earliest_input_date, " to ", latest_input_date))
cleaned_data_meta < - c(output_size[1], output_size[2], output_unique_species,
paste("From", earliest_output_date, " to ", latest_output_date))
data.summary < - data.frame(input_data_meta, cleaned_data_meta)
row.names(data.summary) < - c("Rows", "Columns", "Number of unique scientific names",
"Date Range")
checks.records < - list()
index < - 1
for (question in responses$bdquestions) {
if (length(question$users.answer) > 0) {
checks.records[[paste("question", index, sep = "")]] < - list(question = question$question,
answer = question$users.answer, checks = question$cleaning.details)
index < - index + 1
}
}
records_table < - data.frame(DataCleaningProcedure = "Initial Records",
NoOfRecords = nrow(input_data), Action = "Initialize")
for (question in checks.records) {
check_index < - 1
for (check in question$checks) {
records_table < - rbind(records_table, data.frame(DataCleaningProcedure = names(question$checks)[check_index],
NoOfRecords = ifelse(is.null(check$affected_data),
0, check$affected_data), Action = ifelse(cleaning_true,
"Removal", "Flagging")))
check_index < - check_index + 1
}
}
remaining_records < - (nrow(cleaned_data))
removed_records < - nrow(input_data) - nrow(cleaned_data)
records_table < - rbind(records_table, data.frame(DataCleaningProcedure = "Total",
NoOfRecords = paste("Remaining ", remaining_records,
" Records (", (remaining_records/records_table[1,
2]) * 100, "%)", sep = ""), Action = paste(ifelse(cleaning_true,
"Removal of ", "Flagging of"), removed_records, " Records (",
(removed_records/records_table[1, 2]) * 100, "%)",
sep = "")))
message(knitr::kable(records_table, format = "markdown"))
generate_short_report(records_table, format)
generate_detailed_report(data.summary, checks.records, format)
}
19
File: beta_binom.R, author: bearloga, license: MIT License
present_bbfit < - function(object, conf_interval = TRUE, conf_level = 0.95,
interval_type = c("quantile", "HPD"), raw = FALSE, fancy_names = TRUE,
...) {
interval_type < - interval_type[1]
if (!interval_type %in% c("quantile", "HPD"))
stop("interval_type must be 'quantile' or 'HPD' (requires {coda} package)")
if (!requireNamespace("knitr", quietly = TRUE))
stop("knitr is required for generating a formatted table\"")
if (!requireNamespace("coda", quietly = TRUE) & interval_type ==
"HPD") {
message("High posterior density intervals (interval_type = \"HPD\") require the coda package to be installed. Defaulting to interval_type = \"quantile\"")
interval_type < - "quantile"
}
args < - list(...)
.digits < - ifelse("digits" %in% names(args), args$digits[1],
getOption("digits", 3))
if (class(object) == "list") {
if (any(vapply(object, class, "") != "beta_binomial_fit")) {
stop("The list had an object that was not of class 'beta_binomial_fit'")
}
}
else {
object < - list(object)
}
posterior_summaries < - purrr::map_dfr(object, function(fit) {
posterior < - tidy(fit, conf_level, interval_type)
totals < - as.integer(fit[["totals"]])
tibble::tibble(n1 = totals[1], n2 = totals[2], p1 = format_confint(100 *
posterior$estimate[posterior$term == "p1"], if_else(conf_interval,
100 * posterior[posterior$term == "p1", c("conf.low",
"conf.high")], NULL), digits = .digits, units = "%"),
p2 = format_confint(100 * posterior$estimate[posterior$term ==
"p2"], if_else(conf_interval, 100 * posterior[posterior$term ==
"p2", c("conf.low", "conf.high")], NULL), digits = .digits,
units = "%"), pd = format_confint(100 * posterior$estimate[posterior$term ==
"prop_diff"], if_else(conf_interval, 100 * posterior[posterior$term ==
"prop_diff", c("conf.low", "conf.high")], NULL),
digits = .digits, units = "%"), rr = format_confint(100 *
posterior$estimate[posterior$term == "relative_risk"],
if_else(conf_interval, 100 * posterior[posterior$term ==
"prop_diff", c("conf.low", "conf.high")], NULL),
digits = .digits), or = format_confint(100 *
posterior$estimate[posterior$term == "odds_ratio"],
if_else(conf_interval, 100 * posterior[posterior$term ==
"prop_diff", c("conf.low", "conf.high")], NULL),
digits = .digits))
}, .id = "bb_fit")
if (fancy_names) {
names(posterior_summaries) < - c("Beta-Binom Fit", "Group 1",
"Group 2", "Pr(Success) in Group 1", "Pr(Success) in Group 2",
"Difference", "Relative Risk", "Odds Ratio")
}
if (raw)
return(posterior_summaries)
return(knitr::kable(posterior_summaries, ...))
}
19
File: figures.R, author: bearloga, license: MIT License
population %>% rename(Population = brk) %>% group_by(Population) %>%
summarize(Counties = n()) %>% mutate(Proportion = Counties/sum(Counties)) %>%
knitr::kable(digits = 3, format = "html")
19
File: demo_estimate_effective_sample_size.R, author: beast-dev, license: MIT License
knitr::kable(estimates)
19
File: demo_estimate_effective_sample_size.R, author: beast-dev, license: MIT License
knitr::kable(df_esses)
19
File: profile_calc_esses.R, author: beast-dev, license: MIT License
knitr::kable(estimates)
19
File: profile_calc_esses.R, author: beast-dev, license: MIT License
knitr::kable(df_esses)
19
File: CreateCV.R, author: bomeara, license: GNU General Public License v3.0
CreatePeopleMarkdown < - function(infile = system.file("extdata",
"people.txt", package = "cv"), outdir = tempdir()) {
people < - read.delim2(infile, stringsAsFactors = FALSE)
people$Stop < - as.character(people$Stop)
people$Stop[is.na(people$Stop)] < - "present"
people$Duration < - paste(people$Start, "-", people$Stop,
sep = "")
people$Name < - paste(people$First, people$Last)
for (i in sequence(dim(people)[1])) {
if (nchar(people$URL[i]) > 3) {
people$Name[i] < - paste("[", people$First[i], " ",
people$Last[i], "](", people$URL[i], ")", sep = "")
}
}
cat("\n\n## Mentoring, Postdocs\n\nI have mentored numerous postdocs off of my own grants and/or as one of their chosen NIMBioS mentors. Note that NIMBioS postdocs pursue independent research projects but choose one faculty member to mentor them in math and another to mentor them in biology (I have served in both roles).",
file = paste(outdir, "/people.md", sep = ""), sep = "\n",
append = FALSE)
postdocs < - subset(people, Stage == "Postdoc")
postdocs < - postdocs[order(postdocs$Last), ]
postdocs.pretty < - postdocs[, c("Name", "Duration", "NIMBioS",
"CurrentPosition")]
names(postdocs.pretty)[4] < - "Current Position"
cat(capture.output(knitr::kable(postdocs.pretty, row.names = FALSE)),
file = paste(outdir, "/people.md", sep = ""), sep = "\n",
append = TRUE)
cat("\n\n## Mentoring, Grad students in my lab\n\n ", file = paste(outdir,
"/people.md", sep = ""), sep = "\n", append = TRUE)
grads < - subset(people, Stage == "PhD student")
grads < - grads[order(grads$Last), ]
grads.pretty < - grads[, c("Name", "Stage", "Duration", "Note")]
names(grads.pretty)[3] < - "Time in Lab"
cat(capture.output(knitr::kable(grads.pretty, row.names = FALSE)),
file = paste(outdir, "/people.md", sep = ""), sep = "\n",
append = TRUE)
cat("\n\n## Mentoring, Undergrad students in my lab\n\n ",
file = paste(outdir, "/people.md", sep = ""), sep = "\n",
append = TRUE)
undergrads < - subset(people, Stage == "Undergrad")
undergrads < - undergrads[order(undergrads$Last), ]
undergrads.pretty < - undergrads[, c("Name", "Stage", "Duration",
"Note")]
names(undergrads.pretty)[3] < - "Time in Lab"
cat(capture.output(knitr::kable(undergrads.pretty, row.names = FALSE)),
file = paste(outdir, "/people.md", sep = ""), sep = "\n",
append = TRUE)
cat("\n\n## Mentoring, Grad student committees\n\nIn addition to my own students, of course.",
file = paste(outdir, "/people.md", sep = ""), sep = "\n",
append = TRUE)
com < - subset(people, Stage == "Committee")
com < - com[order(com$Last), ]
com.pretty < - com[, c("Name", "Department")]
cat(capture.output(knitr::kable(com.pretty, row.names = FALSE)),
file = paste(outdir, "/people.md", sep = ""), sep = "\n",
append = TRUE)
cat("\n\n## Mentoring, Faculty\n\nOur department now has faculty mentored by a committee of later career faculty. I have served on committees for folks hired after me.",
file = paste(outdir, "/people.md", sep = ""), sep = "\n",
append = TRUE)
faculty < - subset(people, Stage == "Faculty")
faculty < - faculty[order(faculty$Last), ]
faculty.pretty < - faculty[, c("Name", "Department")]
cat(capture.output(knitr::kable(faculty.pretty, row.names = FALSE)),
file = paste(outdir, "/people.md", sep = ""), sep = "\n",
append = TRUE)
}
19
File: CreateCV.R, author: bomeara, license: GNU General Public License v3.0
CreateSummaryMarkdown < - function(orcid.info, outdir = tempdir(),
publications.offset = -2, prominent.pubs = "*Science, Nature, Ann. Rev Ecology, Evolution & Systematics, Systematic Biology, Evolution*, etc.") {
results < - data.frame(matrix(nrow = 6, ncol = 2))
colnames(results) < - c("", "")
results[1, 1] < - "**Publications**"
results[1, 2] < - paste(nrow(orcid.info$journals) + publications.offset,
" journal articles, including ", prominent.pubs, sep = "")
results[2, 1] < - "**Teaching**"
results[2, 2] < - "Approximately 2 courses per year on average, ranging from large introductory biology courses to small graduate seminars"
results[3, 1] < - "**Mentoring**"
people < - read.delim2(system.file("extdata", "people.txt",
package = "cv"), stringsAsFactors = FALSE)
results[3, 2] < - paste(sum(grepl("PhD student", people$Stage)),
" PhD students, ", sum(grepl("Postdoc", people$Stage)),
" postdocs, ", sum(grepl("Faculty", people$Stage)), " faculty, ",
"and served on ", sum(grepl("Committee", people$Stage)),
" graduate student committees", sep = "")
results[4, 1] < - "**Service/Outreach**"
results[4, 2] < - "Darwin Day TN advisor, curator of R phylogenetics task view, instructor at workshops in Sweden, Switzerland, Brazil, and various US locations (Ohio, TN, NC)"
results[5, 1] < - "**Leadership**"
results[5, 2] < - "Associate Head for Dept. of Ecology & Evolutionary Biology, 2016-present; Associate Director for the National Institute for Mathematical and Biological Synthesis, 2016-2018; Code of Conduct Committee for SSE/SSB/ASN, 2018-present; Communications Director for the Society of Systematic Biologists, 2016-2017; Society of Systematic Biologists Council, 2012-2014; iEvoBio co-organizer, 2014-2016."
results[6, 1] < - "**Funding**"
total.funding < - 0
for (i in sequence(nrow(orcid.info$funding))) {
local.funding < - rorcid::orcid_fundings(orcid.info$id,
put_code = orcid.info$funding$`put-code`[i])[[1]]
total.funding < - total.funding + as.numeric(local.funding$amount$value)
}
results[6, 2] < - paste("$", round((1e-06) * total.funding,
2), "M in external support, including ", sum(grepl("National Science Foundation",
orcid.info$funding$organization.name)), " NSF grants (including a CAREER grant) plus funding from iPlant and Encyclopedia of Life",
sep = "")
scholar.id = "vpjEkQwAAAAJ"
impact.story.id = "0000-0002-0337-5997"
g.profile < - scholar::get_profile(scholar.id)
github.user < - jsonlite::fromJSON(txt = "https://api.github.com/users/bomeara")
i.profile < - jsonlite::fromJSON(txt = paste("https://impactstory.org/api/person/",
impact.story.id, sep = ""))
i.sources < - i.profile$sources
cat("\n\n## Summary\n\n ", file = paste(outdir, "/summary.md",
sep = ""), sep = "\n", append = FALSE)
cat(capture.output(knitr::kable(results, row.names = FALSE)),
file = paste(outdir, "/summary.md", sep = ""), sep = "\n",
append = TRUE)
}
19
File: SimulatePolicies.R, author: casact, license: Mozilla Public License 2.0
dfGL_CA %>% arrange(policyholder_id) %>% head() %>% knitr::kable()
19
File: SimulatePolicies.R, author: casact, license: Mozilla Public License 2.0
tbl_policies %>% mutate(PolicyYear = lubridate::year(policy_effective_date)) %>%
group_by(PolicyYear) %>% summarise(MaxPolicyholderID = max(policyholder_id)) %>%
knitr::kable()
19
File: html_transformation.R, author: choonghyunryu, license: GNU General Public License v2.0
html_paged_impute_missing < - function(.data, target = NULL, full_width = TRUE,
font_size = 13, base_family = NULL) {
if (is.null(base_family)) {
base_family < - "Roboto Condensed"
}
numerics < - c("mean", "median", "mode", "knn", "rpart", "mice")
categories < - c("mode", "rpart", "mice")
n_na < - .data %>% sapply(function(x) sum(is.na(x))) %>% .[. >
0]
if (length(n_na) > 0) {
data_type < - get_class(.data)
tab_missing < - n_na %>% tibble::as_tibble() %>% mutate(variable = names(n_na)) %>%
rename(missing = value) %>% bind_cols(n = NROW(.data)) %>%
mutate(rate_missing = missing/n) %>% inner_join(data_type,
by = "variable") %>% select(variable, class, n, missing,
rate_missing)
nm_cols < - c("variables", "data types", "observations",
"missing", "missing(%)")
caption < - "Information of missing values"
tab_missing %>% knitr::kable(format = "html", digits = 2,
caption = caption, col.names = nm_cols) %>% kableExtra::kable_styling(full_width = full_width,
font_size = font_size, position = "left") %>% gsub("font-size: initial !important;",
"font-size: 12px !important;", .) %>% cat()
break_page_asis()
for (i in seq(NROW(tab_missing))) {
variable < - tab_missing$variable[i]
type < - tab_missing$class[i] %>% as.character()
el < - div(h3(variable))
cat(as.character(el))
if (type %in% c("integer", "numeric")) {
method < - numerics
}
else if (type %in% c("factor", "ordered")) {
method < - categories
}
if (is.null(target)) {
method < - setdiff(method, c("knn", "rpart", "mice"))
}
else {
method < - method
}
imputes < - method %>% lapply(function(x) {
if (is.null(target)) {
imputate_na(.data, all_of(variable), all_of(target),
method = x, print_flag = FALSE)
}
else {
imputate_na(.data, all_of(variable), method = x,
print_flag = FALSE)
}
})
p_compare < - imputes %>% lapply(function(x) {
plot(x, base_family = base_family)
})
suppressMessages({
mat < - imputes %>% purrr::map_dfc(function(x) {
summary_imputation(x) %>% as.data.frame()
})
})
if (type %in% c("integer", "numeric")) {
drops < - seq(ncol(mat))[seq(ncol(mat))%%2 ==
1][-1]
mat < - mat[, -c(drops)]
names(mat) < - c("original", paste("inpute", method,
sep = "_"))
nm_cols < - c("mean", "standard devation", "IQR",
"min", "Q1", "median", "Q3", "max", "skewness",
"kurtosis")
tab_compare < - mat %>% t() %>% as.data.frame() %>%
select(mean, sd, IQR, p00, p25, p50, p75, p100,
skewness, kurtosis)
for (j in seq(length(method))) {
el < - div(h4(paste0(variable, " - ", method[j])))
cat(as.character(el))
print(p_compare[[j]])
break_line_asis(1)
caption < - paste0("Distribution with ", method[j],
" method")
tab_compare[c(1, j + 1), ] %>% knitr::kable(format = "html",
digits = 2, caption = caption, col.names = nm_cols) %>%
kableExtra::kable_styling(full_width = full_width,
font_size = font_size, position = "left") %>%
gsub("font-size: initial !important;", "font-size: 12px !important;",
.) %>% cat()
break_page_asis()
}
}
else if (type %in% c("factor", "ordered")) {
drops < - seq(ncol(mat))[seq(ncol(mat))%%4 !=
2][-1]
mat < - mat[, -c(drops)]
names(mat) < - c("original", paste("inpute", method,
sep = "_"))
tab_compare < - mat %>% t() %>% as.data.frame()
names(tab_compare)[ncol(tab_compare)] < - " < Missing>"
tab_compare_rate < - tab_compare/rowSums(tab_compare)
for (j in seq(length(method))) {
el < - div(h4(paste0(variable, " - ", method[j])))
cat(as.character(el))
print(p_compare[[j]])
break_line_asis(1)
caption < - paste0("Contingency table with ",
method[j], " method")
header_above < - c(1, NCOL(tab_compare))
names(header_above) < - c("imputation method",
target)
tab_compare[c(1, j + 1), ] %>% knitr::kable(format = "html",
caption = caption, format.args = list(big.mark = ",")) %>%
kableExtra::add_header_above(header_above) %>%
kableExtra::kable_styling(full_width = full_width,
font_size = font_size, position = "left") %>%
gsub("font-size: initial !important;", "font-size: 12px !important;",
.) %>% cat()
break_line_asis(1)
caption < - paste0("Relate Contingency Table with ",
method[j], " method")
tab_compare_rate[c(1, j + 1), ] %>% knitr::kable(format = "html",
digits = 2, caption = caption) %>% kableExtra::add_header_above(header_above) %>%
kableExtra::kable_styling(full_width = full_width,
font_size = font_size, position = "left") %>%
gsub("font-size: initial !important;", "font-size: 12px !important;",
.) %>% cat()
break_page_asis()
}
}
}
}
else {
html_cat("There are no variables in the dataset with missing values.")
break_page_asis()
}
}
19
File: html_transformation.R, author: choonghyunryu, license: GNU General Public License v2.0
html_paged_impute_outlier < - function(.data, full_width = TRUE,
font_size = 13, base_family = NULL) {
if (is.null(base_family)) {
base_family < - "Roboto Condensed"
}
method < - c("mean", "median", "mode", "capping")
n < - nrow(.data)
outlist < - find_outliers(.data, index = FALSE)
if (length(outlist) > 0) {
tab_outlier < - .data %>% select_at(outlist) %>% diagnose_numeric() %>%
mutate(n = n) %>% mutate(rate_outlier = outlier/n) %>%
select(variables, n, min, max, outlier, rate_outlier)
nm_cols < - c("variables", "observations", "min", "max",
"outlier", "outlier(%)")
caption < - "Information of outliers"
tab_outlier %>% knitr::kable(format = "html", digits = 2,
caption = caption, col.names = nm_cols) %>% kableExtra::kable_styling(full_width = full_width,
font_size = font_size, position = "left") %>% gsub("font-size: initial !important;",
"font-size: 12px !important;", .) %>% cat()
break_page_asis()
for (i in seq(NROW(tab_outlier))) {
variable < - tab_outlier$variables[i]
el < - div(h3(variable))
cat(as.character(el))
imputes < - method %>% lapply(function(x) {
imputate_outlier(.data, all_of(variable), method = x)
})
p_compare < - imputes %>% lapply(function(x) {
plot(x, base_family = base_family)
})
suppressMessages({
mat < - imputes %>% purrr::map_dfc(function(x) {
summary_imputation(x) %>% as.data.frame()
})
})
drops < - seq(ncol(mat))[seq(ncol(mat))%%2 == 1][-1]
mat < - mat[, -c(drops)]
names(mat) < - c("original", paste("inpute", method,
sep = "_"))
tab_compare < - mat %>% t() %>% as.data.frame() %>%
select(mean, sd, IQR, p00, p25, p50, p75, p100,
skewness, kurtosis)
nm_cols < - c("mean", "standard devation", "IQR",
"min", "Q1", "median", "Q3", "max", "skewness",
"kurtosis")
for (j in seq(length(method))) {
el < - div(h4(paste0(variable, " - ", method[j])))
cat(as.character(el))
print(p_compare[[j]])
break_line_asis(1)
caption < - paste0("Distribution with ", method[j],
" method")
tab_compare[c(1, j + 1), ] %>% knitr::kable(format = "html",
digits = 2, caption = caption, col.names = nm_cols) %>%
kableExtra::kable_styling(full_width = full_width,
font_size = font_size, position = "left") %>%
gsub("font-size: initial !important;", "font-size: 12px !important;",
.) %>% cat()
break_page_asis()
}
}
}
else {
html_cat("There are no variables in the dataset with outliers.")
break_page_asis()
}
}
19
File: html_transformation.R, author: choonghyunryu, license: GNU General Public License v2.0
html_paged_resolve_skewness < - function(.data, full_width = TRUE,
font_size = 13, base_family = NULL) {
if (is.null(base_family)) {
base_family < - "Roboto Condensed"
}
skewlist < - find_skewness(.data, index = FALSE)
if (length(skewlist) > 0) {
tab_skewness < - .data %>% select_at(skewlist) %>% dlookr::describe(statistics = c("quantiles",
"skewness"), quantiles = c(0, 0.25, 0.5, 0.75, 1)) %>%
select(variable, p00:p100, skewness)
nm_cols < - c("variables", "min", "Q1", "median", "Q3",
"max", "skewness")
caption < - "Information of skewness"
tab_skewness %>% knitr::kable(format = "html", digits = 2,
caption = caption, col.names = nm_cols) %>% kableExtra::kable_styling(full_width = full_width,
font_size = font_size, position = "left") %>% gsub("font-size: initial !important;",
"font-size: 12px !important;", .) %>% cat()
break_page_asis()
for (i in seq(NROW(tab_skewness))) {
variable < - tab_skewness$variable[i]
el < - div(h3(variable))
cat(as.character(el))
skewness < - tab_skewness$skewness[i]
if (skewness < = 0) {
method < - c("1/x", "x^2", "x^3", "Box-Cox")
}
else {
method < - c("log", "log+1", "sqrt", "Box-Cox")
}
resolve < - method %>% lapply(function(x) {
transform(pull(.data, variable), method = x)
})
suppressMessages({
mat < - resolve %>% purrr::map_dfc(function(x) {
summary_transform(x) %>% as.data.frame()
})
})
drops < - seq(ncol(mat))[seq(ncol(mat))%%2 == 1][-1]
mat < - mat[, -c(drops)]
names(mat) < - c("original", paste("transform", method,
sep = "_"))
tab_compare < - mat %>% t() %>% as.data.frame() %>%
select(IQR, p00, p25, p50, p75, p100, skewness,
kurtosis)
nm_cols < - c("IQR", "min", "Q1", "median", "Q3",
"max", "skewness", "kurtosis")
for (j in seq(length(method))) {
el < - div(h4(paste0(variable, " - ", method[j])))
cat(as.character(el))
plot(resolve[[j]], base_family = base_family)
break_line_asis(1)
caption < - paste0("Distribution with ", method[j],
" method")
tab_compare[c(1, j + 1), ] %>% knitr::kable(format = "html",
digits = 2, caption = caption, col.names = nm_cols) %>%
kableExtra::kable_styling(full_width = full_width,
font_size = font_size, position = "left") %>%
gsub("font-size: initial !important;", "font-size: 12px !important;",
.) %>% cat()
break_page_asis()
}
}
}
else {
html_cat("There are no variables including skewed.")
break_page_asis()
}
}
19
File: html_transformation.R, author: choonghyunryu, license: GNU General Public License v2.0
html_paged_binning < - function(.data, full_width = TRUE, font_size = 13,
base_family = NULL) {
if (is.null(base_family)) {
base_family < - "Roboto Condensed"
}
method < - c("quantile", "equal", "pretty", "kmeans", "bclust")
numlist < - find_class(.data, "numerical", index = FALSE)
if (length(numlist) > 0) {
tab_numerical < - .data %>% select_at(numlist) %>% diagnose() %>%
full_join(data.frame(method = method, stringsAsFactors = FALSE),
by = character()) %>% select(variables, types,
unique_count, unique_rate, method)
options(show.error.messages = FALSE)
bins < - seq(nrow(tab_numerical)) %>% lapply(function(x) {
binn < - try(binning(pull(.data, tab_numerical$variables[x]),
type = tab_numerical$method[x]), silent = TRUE)
if (class(binn) == "try-error") {
return(NULL)
}
else {
return(binn)
}
})
options(show.error.messages = TRUE)
tab_numerical$n_bins < - bins %>% sapply(function(x) attr(x,
"levels") %>% length)
nm_cols < - c("variables", "data types", "unique", "unique rate",
"binning method", "bins")
caption < - "Information of binnings"
print_tab(tab_numerical, n_rows = 30, add_row = 3, caption = caption,
full_width = TRUE, font_size = 13, col.names = nm_cols,
digits = 3, big_mark = TRUE)
variable_before < - ""
for (i in seq(NROW(tab_numerical))) {
variable < - tab_numerical$variables[i]
if (variable_before != variable) {
el < - div(h3(variable))
cat(as.character(el))
}
variable_before < - variable
el < - div(h4(paste0(variable, " - ", tab_numerical[i,
5])))
cat(as.character(el))
plot(bins[[i]], base_family = base_family)
break_line_asis(1)
nm_cols < - c("bins", "frequency", "frequency(%)")
caption < - "Contingency table with bins"
summary(bins[[i]]) %>% knitr::kable(format = "html",
digits = 2, caption = caption, col.names = nm_cols) %>%
kableExtra::kable_styling(full_width = full_width,
font_size = font_size, position = "left") %>%
gsub("font-size: initial !important;", "font-size: 12px !important;",
.) %>% cat()
break_page_asis()
}
}
else {
html_cat("There are no numerical variables.")
break_page_asis()
}
}
19
File: html_transformation.R, author: choonghyunryu, license: GNU General Public License v2.0
html_paged_optimal_binning < - function(.data, target, full_width = TRUE,
font_size = 13, base_family = NULL) {
if (is.null(base_family)) {
base_family < - "Roboto Condensed"
}
numlist < - find_class(.data, "numerical", index = FALSE)
if (is.null(target)) {
html_cat("The target variable is not defied.")
break_page_asis()
}
else if (!target %in% names(.data)) {
html_cat(paste0("The target variable ", target, " is not in the data."))
break_page_asis()
}
else if (length(numlist) == 0) {
html_cat("There are no numerical variables.")
break_page_asis()
}
else {
n_levles < - length(table(pull(.data, target)))
if (n_levles != 2) {
html_cat("The target variable is not a binary class.")
break_page_asis()
}
else {
tab_numerical < - .data %>% select_at(numlist) %>%
diagnose() %>% select(-missing_count, -missing_percent)
bins < - lapply(numlist, function(x) binning_by(.data,
y = target, x = all_of(x), p = 0.05))
success < - ifelse(sapply(bins, is.character), "No significant splits",
"Success")
tab_numerical < - tab_numerical %>% bind_cols(data.frame(success = success))
tab_numerical$n_bins < - bins %>% purrr::map_int(function(x) {
attr(x, "levels") %>% length
})
nm_cols < - c("variables", "data types", "unique",
"unique rate", "success", "bins")
caption < - "Information of optimal binnings"
print_tab(tab_numerical, n_rows = 30, add_row = 3,
caption = caption, full_width = TRUE, font_size = 13,
col.names = nm_cols, digits = 3, big_mark = TRUE)
for (i in seq(NROW(tab_numerical))) {
if (tab_numerical$n_bins[i] == 0) {
next
}
variable < - tab_numerical$variables[i]
el < - div(h3(variable))
cat(as.character(el))
plot(bins[[i]], base_family = base_family)
break_line_asis(1)
caption < - "Binning table with performance measures"
attr(bins[[i]], "performance") %>% select(-CntCumPos,
-CntCumNeg, -RateCumPos, -RateCumNeg) %>% knitr::kable(format = "html",
digits = 2, caption = caption) %>% kableExtra::kable_styling(full_width = full_width,
font_size = font_size, position = "left") %>%
gsub("font-size: initial !important;", "font-size: 12px !important;",
.) %>% cat()
break_page_asis()
}
}
}
}
19
File: overview.R, author: choonghyunryu, license: GNU General Public License v2.0
summary.overview < - function(object, html = FALSE, ...) {
nms < - c("Number of observations", "Number of variables",
"Number of values", "Size of located memory(bytes)",
"Number of duplicated observations", "Number of completed observations",
"Number of observations with NA", "Number of variables with NA",
"Number of NA", "Number of numeric variables", "Number of integer variables",
"Number of factors variables", "Number of character variables",
"Number of Date variables", "Number of POSIXct variables",
"Number of other variables")
nms < - format(nms)
line_break < - function(html = FALSE) {
if (!html) {
cat("\n")
}
else {
cat(" < br>")
}
}
vls < - format(object$value, big.mark = ",")
N < - object$value[1]
n_dup < - object$value[5]
n_na < - object$value[7]
p_dup < - paste0("(", round(n_dup/N * 100, 2), "%)")
p_na < - paste0("(", round(n_na/N * 100, 2), "%)")
vls[5] < - paste(vls[5], p_dup)
vls[7] < - paste(vls[7], p_na)
if (!html) {
cat_rule(left = "Data Scale", right = "", width = 60)
}
else {
cat_rule(left = "Data Scale", right = "", width = 60) %>%
paste(" < br>") %>% cat()
}
info_scale < - paste0(nms[1:4], " : ", vls[1:4])
if (html) {
info_scale < - paste(info_scale, " < br>")
}
cat_bullet(info_scale)
line_break()
if (!html) {
cat_rule(left = "Duplicated Data", right = "", width = 60)
}
else {
cat_rule(left = "Duplicated Data", right = "", width = 60) %>%
paste(" < br>") %>% cat()
}
duplicated < - paste0(nms[5], " : ", vls[5])
if (html) {
duplicated < - paste(duplicated, " < br>")
}
cat_bullet(duplicated)
line_break()
if (!html) {
cat_rule(left = "Missing Data", right = "", width = 60)
}
else {
cat_rule(left = "Missing Data", right = "", width = 60) %>%
paste(" < br>") %>% cat()
}
info_missing < - paste0(nms[6:9], " : ", vls[6:9])
if (html) {
info_missing < - paste(info_missing, " < br>")
}
cat_bullet(info_missing)
line_break()
if (!html) {
cat_rule(left = "Data Type", right = "", width = 60)
}
else {
cat_rule(left = "Data Type", right = "", width = 60) %>%
paste(" < br>") %>% cat()
}
info_type < - paste0(nms[10:16], " : ", vls[10:16])
if (html) {
info_type < - paste(info_type, " < br>")
}
cat_bullet(info_type)
line_break()
if (!html) {
cat_rule(left = "Individual variables", right = "", width = 60)
}
else {
cat_rule(left = "Individual variables", right = "", width = 60) %>%
paste(" < br>") %>% cat()
}
info_class < - attr(object, "info_class")
names(info_class) < - c("Variables", "Data Type")
if (!html) {
print(info_class)
}
else {
info_class %>% knitr::kable(format = "html") %>% kableExtra::kable_styling(full_width = FALSE,
font_size = 15, position = "left")
}
}
19
File: paged.R, author: choonghyunryu, license: GNU General Public License v2.0
print_tab < - function(tab, n_rows = 25, add_row = 3, caption = "",
full_width = TRUE, font_size = 14, align = NULL, col.names = NA,
digits = 2, big_mark = TRUE) {
N < - nrow(tab)
n_pages < - 1
if (N > n_rows) {
n_pages < - n_pages + ceiling((N - n_rows)/(n_rows + add_row))
}
for (i in seq(n_pages)) {
if (i == 1) {
idx < - intersect(seq(N), seq(n_rows))
}
else {
idx < - (max(idx) + 1):(max(idx) + n_rows + add_row) %>%
pmin(N) %>% unique()
}
if (is.null(align)) {
if (big_mark) {
ktab < - knitr::kable(tab[idx, ], digits = digits,
format = "html", caption = ifelse(i > 1, paste(caption,
"(continued)"), caption), col.names = col.names,
format.args = list(big.mark = ","))
}
else {
ktab < - knitr::kable(tab[idx, ], digits = digits,
format = "html", caption = ifelse(i > 1, paste(caption,
"(continued)"), caption), col.names = col.names)
}
}
else {
if (big_mark) {
ktab < - knitr::kable(tab[idx, ], digits = digits,
format = "html", align = align, caption = ifelse(i >
1, paste(caption, "(continued)"), caption),
col.names = col.names, format.args = list(big.mark = ","))
}
else {
ktab < - knitr::kable(tab[idx, ], digits = digits,
format = "html", align = align, caption = ifelse(i >
1, paste(caption, "(continued)"), caption),
col.names = col.names)
}
}
ktab %>% kableExtra::kable_styling(full_width = full_width,
font_size = font_size, position = "left") %>% gsub("font-size: initial !important;",
"font-size: 12px !important;", .) %>% cat()
if (n_pages == 1 | i < n_pages) {
break_page_asis()
}
}
}
19
File: BLCAsubtyping.R, author: cit-bioinfo, license: GNU General Public License v2.0
kableExtra::kable_styling(knitr::kable(head(cl), digits = 3,
format = "html"))
19
File: consensusMIBC.R, author: cit-bioinfo, license: GNU General Public License v2.0
kableExtra::kable_styling(knitr::kable(dt, digits = 3, format = "html"))
19
File: corpusSearchContextModule.R, author: cwolk, license: GNU General Public License v3.0
searchContextModule < - function(input, output, session, config,
searchTool, mainCorpus) {
if (identical(config$ContextDisplay$Type, "Multicolumns")) {
lapply(config$ContextDisplay$Columns, function(column) {
output[[column]] < - renderUI(if (!is.null(searchTool$selected())) {
if (attributes(mainCorpus$query$querystring())$searchterm ==
"")
p(searchTool$selected()[[column]])
else HTML(annotate_html(searchTool$selected()[[column]],
mainCorpus$query$querystring()))
}
else p("select concordance line"))
})
}
else if (identical(config$ContextDisplay$Type, "LocalContext")) {
output$localcontext < - renderUI({
if (!is.null(searchTool$selected())) {
if (searchTool$mode() == "Data")
positions < - cbind(1, 1000)
else positions < - cbind(max(1, searchTool$selected()$ShinyConc.KWICmatchStart -
700), min(stringr::str_length(searchTool$selected()$text),
searchTool$selected()$ShinyConc.KWICmatchEnd +
700))
extract < - stringr::str_sub(searchTool$selected()$text,
positions)
if (is.na(extract))
return(NULL)
extract < - paste(if (positions[1] == 1)
NULL
else "...", extract, if (positions[2] == stringr::str_length(searchTool$selected()$text))
NULL
else "...", sep = "")
if (attributes(mainCorpus$query$querystring())$searchterm ==
"")
p(extract)
else HTML(annotate_html(extract, mainCorpus$query$querystring()))
}
else p("select concordance line")
})
}
else if (identical(config$ContextDisplay$Type, "LineContext")) {
output$contextview < - renderUI({
if (!is.null(searchTool$selected())) {
queryS < - mainCorpus$query$querystring()
pre < - ((searchTool$previous())(5))()
result < - searchTool$selected()
post < - ((searchTool$following())(5))()
colsToShow < - if (is.null(config$ContextDisplay$Columns))
c("speaker", "text")
else config$ContextDisplay$Columns
if (nrow(pre) > 0)
pre$text < - paste(" < span type=\"context\">",
htmltools::htmlEscape(pre$text), " < span/>")
result$text < - annotate_html(result$text, queryS)
if (nrow(post) > 0)
post$text < - paste(" < span type=\"context\">",
htmltools::htmlEscape(post$text), " < span/>")
HTML(knitr::kable(rbind(rbind(pre, result[, colnames(result) %in%
colnames(pre)]), post)[, colsToShow], format = "html",
escape = FALSE, row.names = FALSE, table.attr = "class=\"contextTable\""))
}
else p("select concordance line")
})
}
output$fulltextView < - renderUI(if (!is.null(searchTool$selected())) {
if (attributes(mainCorpus$query$querystring())$searchterm ==
"")
p(searchTool$selected()$text)
else HTML(annotate_html(searchTool$selected()$text, mainCorpus$query$querystring()))
}
else p("No text selected."))
}
19
File: consultations-example.R, author: DataS-DHSC, license: GNU General Public License v3.0
knitr::kable(dummy_response[1:5, ])
19
File: readme.R, author: davidruvolo51, license: MIT License
readme$as_md_table < - function(data) {
data %>% select(name, description, version, link) %>% mutate(link = case_when(link ==
"TBD" ~ "TBD", TRUE ~ paste0("[tutorial](", link, ")"))) %>%
knitr::kable(.)
}
19
File: Entity.R, author: dymium-org, license: GNU General Public License v3.0
Entity < - R6::R6Class(classname = "Entity", inherit = Generic,
public = list(initialize = function(databackend, .data, id_col) {
checkmate::assert_character(id_col, null.ok = FALSE,
min.len = 1, unique = T, any.missing = FALSE, names = "unnamed")
checkmate::assert_names(names(.data), must.include = id_col,
type = "strict")
checkmate::assert_integerish(.data[[id_col[1]]], unique = TRUE,
any.missing = FALSE, null.ok = FALSE, min.len = 1)
private$.data[[1]] < - databackend$new(.data, key = id_col[1])
checkmate::assert_r6(private$.data[[1]], classes = "DataBackend",
.var.name = "databackend")
names(private$.data)[1] < - "attrs"
private$.last_id < - max(.data[[id_col[1]]])
private$.id_col < - id_col
invisible()
}, add_data = function(databackend = DataBackendDataTable,
.data, name) {
checkmate::assert_names(names(.data), must.include = private$.id_col[[1]],
type = "strict")
checkmate::assert_string(name, null.ok = FALSE, na.ok = FALSE)
checkmate::assert_names(name, type = "strict")
checkmate::assert_names(names(private$.data), disjunct.from = name)
private$.data[[length(private$.data) + 1L]] < - databackend$new(.data)
names(private$.data)[length(private$.data)] < - name
invisible()
}, data = function(name) {
if ((missing(name) & length(private$.data) == 0) | is.null(self$get_data_names())) {
lg$warn("{class(self)[[1]]} has no data.")
return(NULL)
}
if (missing(name)) {
.data_pos < - 1
} else {
.data_pos < - which(names(private$.data) == name)
}
if (length(.data_pos) != 1) {
stop(glue::glue("name='{name}' didn't match any data in private$.data [{.data_names}].",
.data_names = glue::glue_collapse(names(private$.data),
", ", last = " and ")))
}
lg$trace("returning {names(private$.data)[[.data_pos]]}")
return(private$.data[[.data_pos]])
}, get_data = function(name, ids, copy = TRUE) {
if (missing(name)) {
name < - "attrs"
}
DataObj < - self$data(name)
if (is.null(DataObj)) {
return(NULL)
}
if (copy == FALSE) {
if (!missing(ids)) {
stop("It is not possible to return a reference semetic to the specific rows in `ids`.")
}
return(DataObj$get(copy = FALSE))
}
if (missing(ids)) {
return(DataObj$get())
} else {
checkmate::check_integerish(x = ids, unique = TRUE,
lower = 1, min.len = 1, null.ok = FALSE, any.missing = FALSE)
if (name == "attrs") {
return(DataObj$get(rows = self$get_idx(ids)))
} else {
lg$warn("The order of the returned data is not garantee to be the same \\\n with the input `ids`. Also not all ids are garantee to have \\\n valid records.")
return(DataObj$get()[get(self$get_id_col()) %in%
ids, ])
}
}
}, get_data2 = function(name = "attrs", ids, copy = TRUE) {
DataObj < - self$data(name)
if (is.null(DataObj)) {
return(NULL)
}
if (copy == FALSE) {
if (!missing(ids)) {
stop("It is not possible to return a reference semetic to the specific rows in `ids`.")
}
return(DataObj$get(copy = FALSE))
}
if (missing(ids)) {
return(DataObj$get())
} else {
checkmate::check_integerish(x = ids, unique = TRUE,
lower = 1, min.len = 1, null.ok = FALSE, any.missing = FALSE)
if (name == "attrs") {
if (is.null(DataObj$key)) {
DataObj$setkey(self$get_id_col())
}
return(data.table:::na.omit.data.table(DataObj$get(copy = FALSE)[J(ids)],
cols = DataObj$colnames[2]))
} else {
lg$warn("The order of the returned data is not garantee to be the same \\\n with the input `ids`. Also not all ids are garantee to have \\\n valid records.")
return(DataObj$get()[get(self$get_id_col()) %in%
ids, ])
}
}
}, get_data_names = function() {
names(private$.data)
}, add = function(.data, check_existing = FALSE) {
checkmate::assert_data_frame(.data)
checkmate::assert_flag(check_existing, na.ok = FALSE,
null.ok = FALSE)
.data < - data.table::copy(.data)
NewData < - DataBackendDataTable$new(.data, key = self$primary_id)
res < - all.equal(target = omit_derived_vars(self$database$attrs$data[0,
]), current = omit_derived_vars(NewData$data[0, ]),
check.attributes = FALSE, ignore.col.order = TRUE)
if (!isTRUE(res)) {
cli::cli_alert_info("New data (.data)")
print(NewData$head())
cli::cli_alert_info("Existing data")
print(self$database$attrs$head())
stop(res)
}
checkmate::assert_integerish(.data[[self$primary_id]],
any.missing = FALSE, null.ok = FALSE, unique = T)
if (any(.data[[self$primary_id]] %in% self$get_ids(include_removed = T))) {
lg$warn("entities in `.data` have the same ids as some of the existing \\\n entities. The duplicated ids will be replaced.")
data.table::set(x = .data, j = self$primary_id, value = self$generate_new_ids(n = .data[,
.N]))
}
if (length(self$id_col) > 1) {
ids_in_relation_cols < - c()
relation_cols < - self$id_col[!self$id_col %in% self$primary_id]
for (relation_col in relation_cols) {
ids_in_relation_cols < - c(ids_in_relation_cols,
na.omit(.data[[relation_col]]))
}
ids_in_relation_cols < - unique(ids_in_relation_cols)
if (check_existing) {
assert_subset2(ids_in_relation_cols, choices = c(self$get_ids(),
.data[[self$primary_id]]))
} else {
assert_subset2(ids_in_relation_cols, choices = .data[[self$primary_id]])
}
}
self$database$attrs$add(.data = .data, fill = TRUE)
invisible()
}, has_attr = function(x) {
x %in% self$database$attrs$colnames
}, get_attr = function(x, ids) {
checkmate::assert_string(x, na.ok = FALSE, null.ok = FALSE)
if (!missing(ids)) {
return(self$get_data(copy = FALSE)[self$get_idx(ids = ids)][[x]])
}
self$data()$get(col = x)[[1]]
}, get_removed_data = function(name) {
DataObj < - self$data(name)
if (is.null(DataObj)) {
return(NULL)
} else {
DataObj$get_removed()
}
}, get_ids = function(include_removed = FALSE) {
if (include_removed) {
return(c(self$get_attr(self$primary_id), self$get_removed_data()[[self$primary_id]]))
}
self$get_attr(self$primary_id)
}, get_idx = function(ids, expect_na = FALSE) {
if (missing(ids)) {
return(seq_len(self$data()$nrow()))
}
all_ids < - self$get_ids()
if (expect_na == FALSE) {
assert_entity_ids(self, ids)
}
sorted_idx < - which(all_ids %in% ids)
sorted_ids < - all_ids[sorted_idx]
tab < - data.table(id = sorted_ids, idx = sorted_idx)
if (requireNamespace("fastmatch", quietly = TRUE)) {
return(tab[fastmatch::fmatch(ids, id)][["idx"]])
}
tab[match(ids, id)][["idx"]]
}, get_id_col = function(all = FALSE) {
if (all) {
return(private$.id_col)
} else {
return(private$.id_col[[1]])
}
}, remove = function(ids) {
checkmate::assert_integerish(ids, any.missing = FALSE,
unique = TRUE, lower = 1, min.len = 1)
if (length(private$.data) == 0) {
lg$warn("There is no data to be removed!")
return(invisible())
}
for (DataObj in private$.data) {
idx < - which(DataObj$get(copy = FALSE)[[private$.id_col[[1]]]] %in%
ids)
DataObj$remove(rows = idx)
}
invisible()
}, idx_exist = function(idx, by_element = FALSE) {
checkmate::assert_integerish(x = idx, lower = 0, any.missing = FALSE,
null.ok = FALSE)
if (by_element) {
return(self$data()$nrow() >= idx)
} else {
return(self$data()$nrow() >= max(idx))
}
}, ids_exist = function(ids, include_removed_data = FALSE) {
test_entity_ids(self, ids, include_removed_data = include_removed_data)
}, summary = function(verbose = TRUE) {
if (length(private$.data) == 0) {
summary_dt < - data.table(dataname = NA, ncol = NA,
nrow = NA, nrow_removed = NA, size = NA)
} else {
summary_dt < - purrr::map2(.x = private$.data, .y = names(private$.data),
.f = ~{
data.table(dataname = .y, ncol = .x$ncol(),
nrow = .x$nrow(), nrow_removed = nrow(.x$get_removed()),
size = format(object.size(.x$get()), units = "Mb",
standard = "SI"))
}) %>% rbindlist()
}
if (verbose) {
print(knitr::kable(summary_dt))
}
invisible(summary_dt)
}, print = function() {
.data_summary < - self$summary(verbose = FALSE) %>% .[,
`:=`(description, glue::glue("{dataname}[{nrow}, {ncol}]",
.envir = .))]
.class_inheritance < - glue::glue_collapse(class(self),
sep = " < - ")
.data_names < - glue::glue_collapse(.data_summary[["description"]],
sep = ", ", last = " and ")
.n_removed < - ifelse(is.null(self$get_removed_data()),
0, nrow(self$get_removed_data()))
message(glue::glue("Class: {class(self)[[1]]}\n Inheritance: {.class_inheritance}\n Number_of_entities: {self$n()}\n Number_of_removed_entities: {.n_removed}\n Data[rows, cols]: {.data_names}\n "))
}, print_data = function(n = 5) {
if (n > 0) {
print(purrr::map(private$.data, ~.x$head(n)))
}
data_names < - glue::glue_collapse(names(private$.data),
", ", last = " and ")
lg$info(glue::glue("{class(self)[[1]]} has {length(private$.data)} datasets{seperator} {.data_names}",
.data_names = ifelse(is.character(data_names), data_names,
""), seperator = ifelse(is.character(data_names),
"...", "")))
invisible()
}, n = function() {
if (is.null(self$data())) {
return(0L)
} else {
self$data()$nrow()
}
}, get_last_id = function() {
private$.last_id
}, get_new_ids = function() {
private$.new_ids
}, generate_new_ids = function(n) {
checkmate::assert_integerish(n, lower = 1, len = 1, null.ok = FALSE,
any.missing = FALSE)
new_ids < - seq(from = self$get_last_id() + 1L, to = self$get_last_id() +
n, by = 1L) %>% as.integer()
private$.last_id < - private$.last_id + n
private$.new_ids < - new_ids
invisible(new_ids)
}, subset_ids = function(expr) {
j_expr < - substitute(expr)
subset(x = self$get_data(copy = FALSE), subset = eval(j_expr),
select = self$get_id_col())[[1]]
}), active = list(database = function() {
get(".data", envir = private)
}, id_col = function() {
get(".id_col", envir = private)
}, primary_id = function() {
get(".id_col", envir = private)[[1]]
}, data_template = function() {
return(data.table())
}), private = list(.data = list(), .id_col = NULL, .history = NULL,
.last_id = NA_integer_, .new_ids = NA_integer_))
19
File: package.R, author: EagerAI, license: Apache License 2.0
fix_fit = function(disable_graph = FALSE) {
fastaip < - reticulate::import("fastprogress")
fastaip$progress_bar$fill = ""
if (!disable_graph) {
fastaip$fastprogress$WRITER_FN = function(value, ...,
sep = " ", end = "\n", flush = FALSE) {
args = list(value, ...)
text = unlist(strsplit(trimws(args[[1]]), " "))
text = text[!text == ""]
lgl = grepl("epoch", text)
nm = paste(tempdir(), "to_df.csv", sep = "/")
if (lgl[1]) {
if (file.exists(nm))
file.remove(nm)
tmm = tempdir()
tmp_name = paste(tmm, "output.txt", sep = "/")
fileConn < - file(tmp_name)
writeLines(text, fileConn)
close(fileConn)
}
if (lgl[1]) {
df < - data.frame(matrix(ncol = length(text),
nrow = 0))
colnames(df) < - text
df[nrow(df) + 1, ] = as.character(round(stats::runif(ncol(df)),
3))
df = knitr::kable(df, format = "pandoc")
cat(df[1:2], sep = "\n")
if (interactive()) {
try(dev.off(), TRUE)
}
set_theme = function() {
ggplot2::theme_set(ggpubr::theme_pubr())
utils::flush.console()
}
invisible(try(set_theme(), TRUE))
}
else {
utils::flush.console()
tmm = tempdir()
tmp_name = paste(tmm, "output.txt", sep = "/")
text2 = readLines(paste(tmm, "output.txt", sep = "/"))
df < - data.frame(matrix(ncol = length(text2),
nrow = 0))
colnames(df) < - text2
silent_fun = function() {
df[nrow(df) + 1, ] = text
df = knitr::kable(df, format = "pandoc")
cat(df[3], sep = "\n")
}
prnt = try(silent_fun(), TRUE)
if (!inherits(prnt, "try-error")) {
df[nrow(df) + 1, ] = text
to_df = df
to_df$time = NULL
if (file.exists(nm)) {
to_df_orig = read.csv(nm)
to_df = rbind(to_df_orig, to_df)
to_df$time = NULL
}
write.csv(to_df, nm, row.names = FALSE)
prnt
to_df = read.csv(nm)
loss_names = grepl("loss", names(to_df))
losses = cbind(to_df[1], to_df[loss_names])
metrics_ = cbind(to_df[1], to_df[!names(to_df) %in%
names(losses)])
column_fun < - function(column_name, df, yaxis,
colour) {
lp < - ggplot2::ggplot(df, ggplot2::aes_string("epoch"))
strings = column_name
if (length(strings) > 1) {
for (i in 1:length(strings)) {
variable = ggplot2::sym(strings[i])
lp < - lp + ggplot2::geom_line(ggplot2::aes(y = !!variable,
colour = !!strings[i])) + ggplot2::geom_point(ggplot2::aes(y = !!variable,
colour = !!strings[i]))
}
lp < - lp + ggplot2::scale_x_continuous(breaks = seq(min(df) -
1, max(df), 1)) + ggplot2::ylab(yaxis) +
ggplot2::labs(colour = yaxis) + ggplot2::theme(legend.position = "bottom",
legend.title = ggplot2::element_text(size = 9),
legend.margin = ggplot2::margin(t = 0,
unit = "cm"), axis.text = ggplot2::element_text(size = 9),
axis.title = ggplot2::element_text(size = 9,
face = "bold"))
}
else {
variable < - ggplot2::sym(column_name)
strings = column_name
lp = lp + ggplot2::geom_line(ggplot2::aes(y = !!variable,
colour = column_name)) + ggplot2::geom_point(ggplot2::aes(y = !!variable,
colour = column_name)) + ggplot2::scale_x_continuous(breaks = seq(min(df) -
1, max(df), 1)) + ggplot2::ylab(yaxis) +
ggplot2::labs(colour = yaxis) + ggplot2::theme(legend.position = "bottom",
legend.title = ggplot2::element_text(size = 9),
legend.margin = ggplot2::margin(t = 0,
unit = "cm"), axis.text = ggplot2::element_text(size = 9),
axis.title = ggplot2::element_text(size = 9,
face = "bold"))
}
lp
}
result_fun = function() {
if (nrow(to_df) > 1) {
if (ncol(metrics_) > 1 & ncol(losses) >
1) {
p1 = column_fun(names(metrics_)[!names(metrics_) %in%
"epoch"], metrics_, "Metrics", "darkgreen")
p2 = column_fun(names(losses)[!names(losses) %in%
"epoch"], losses, "Loss", "red")
figure < - ggpubr::ggarrange(p2, p1, labels = c("",
""), ncol = 1, nrow = 2)
print(figure)
}
else if (ncol(metrics_) > 1 & ncol(losses) < =
1) {
p1 = column_fun(names(metrics_)[!names(metrics_) %in%
"epoch"], metrics_, "Metrics", "darkgreen")
print(p1)
}
else if (ncol(metrics_) < = 1 & ncol(losses) >
1) {
p2 = column_fun(names(losses)[!names(losses) %in%
"epoch"], losses, "Loss", "red")
print(p2)
}
else {
"None"
}
}
paste("done plot")
}
if (interactive()) {
try(result_fun(), TRUE)
}
}
}
}
}
else {
fastaip$fastprogress$WRITER_FN = function(value, ...,
sep = " ", end = "\n", flush = FALSE) {
args = list(value, ...)
text = unlist(strsplit(trimws(args[[1]]), " "))
text = text[!text == ""]
lgl = grepl("epoch", text)
if (lgl[1]) {
tmm = tempdir()
tmp_name = paste(tmm, "output.txt", sep = "/")
fileConn < - file(tmp_name)
writeLines(text, fileConn)
close(fileConn)
}
if (lgl[1]) {
df < - data.frame(matrix(ncol = length(text),
nrow = 0))
colnames(df) < - text
df[nrow(df) + 1, ] = as.character(round(stats::runif(ncol(df)),
3))
df = knitr::kable(df, format = "pandoc")
cat(df[1:2], sep = "\n")
}
else {
tmm = tempdir()
tmp_name = paste(tmm, "output.txt", sep = "/")
text2 = readLines(paste(tmm, "output.txt", sep = "/"))
df < - data.frame(matrix(ncol = length(text2),
nrow = 0))
colnames(df) < - text2
silent_fun = function() {
df[nrow(df) + 1, ] = text
df = knitr::kable(df, format = "pandoc")
cat(df[3], sep = "\n")
}
try(silent_fun(), TRUE)
}
}
}
}
19
File: 07_model_assessment_v001.R, author: EcoForecast, license: MIT License
knitr::kable(stats)
19
File: kable.R, author: ellessenne, license: GNU General Public License v3.0
kable.simsum < - function(x, stats = NULL, digits = max(3, getOption("digits") -
3), ...) {
out < - tidy(x, stats = stats)
knitr::kable(x = out, digits = digits, ...)
}
19
File: 2016_simulator.R, author: elliottmorris, license: MIT License
sims %>% group_by(draw) %>% summarise(dem_ev = sum(ev * (sim_clinton_margin >
0)), dem_nat_pop_margin = unique(dem_nat_pop_margin)) %>%
mutate(scenario = case_when(dem_ev >= 270 & dem_nat_pop_margin >
0 ~ "Democrats win the popular vote and electoral college",
dem_ev >= 270 & dem_nat_pop_margin < 0 ~ "Republicans win the popular vote, but Democrats win the electoral college",
dem_ev < 270 & dem_nat_pop_margin > 0 ~ "Democrats win the popular vote, but Republicans win the electoral college",
dem_ev < 270 & dem_nat_pop_margin < 0 ~ "Republicans win the popular vote and electoral college",
)) %>% group_by(scenario) %>% summarise(chance = n()) %>%
mutate(chance = round(chance/sum(chance) * 100)) %>% setNames(.,
c("", "Chance (%)")) %>% knitr::kable()
19
File: main_poll_simulator.R, author: elliottmorris, license: MIT License
tipping_point.kable < - left_join(tipping_point %>% group_by(draw) %>%
mutate(cumulative_ev = cumsum(ev)) %>% filter(cumulative_ev >=
270) %>% filter(row_number() == 1) %>% group_by(state) %>%
summarise(prop = n()) %>% mutate(prop = round(prop/sum(prop) *
100, 1)) %>% arrange(desc(prop)) %>% head(nrow(.)/2) %>%
mutate(row_number = row_number()), tipping_point %>% group_by(draw) %>%
mutate(cumulative_ev = cumsum(ev)) %>% filter(cumulative_ev >=
270) %>% filter(row_number() == 1) %>% group_by(state) %>%
summarise(prop = n()) %>% mutate(prop = round(prop/sum(prop) *
100, 1)) %>% arrange(desc(prop)) %>% tail(nrow(.) - (nrow(.)/2)) %>%
mutate(row_number = row_number()), by = "row_number") %>%
select(-row_number) %>% setNames(., c("State", "Tipping point chance (%)",
"State", "Tipping point chance (%)")) %>% knitr::kable(.)
19
File: main_poll_simulator.R, author: elliottmorris, license: MIT License
margin.kable.close < - margin.kable.close %>% setNames(., c("State",
"Biden margin, uncertainty interval (%)", "State", "Biden margin, ... (%)")) %>%
knitr::kable(.)
19
File: main_poll_simulator.R, author: elliottmorris, license: MIT License
margin.kable.not_close < - margin.kable.not_close %>% setNames(.,
c("State", "Biden margin, uncertainty interval (%)", "State",
"Biden margin, ... (%)")) %>% knitr::kable(.)
19
File: main_poll_simulator.R, author: elliottmorris, license: MIT License
scenarios.kable < - sims %>% group_by(draw) %>% summarise(dem_ev = sum(ev *
(sim_biden_margin > 0)), dem_nat_pop_margin = unique(dem_nat_pop_margin)) %>%
mutate(scenario = case_when(dem_ev >= 270 & dem_nat_pop_margin >
0 ~ "Democrats win the popular vote and electoral college",
dem_ev >= 270 & dem_nat_pop_margin < 0 ~ "Republicans win the popular vote, but Democrats win the electoral college",
dem_ev < 270 & dem_nat_pop_margin > 0 ~ "Democrats win the popular vote, but Republicans win the electoral college",
dem_ev < 270 & dem_nat_pop_margin < 0 ~ "Republicans win the popular vote and electoral college",
)) %>% group_by(scenario) %>% summarise(chance = n()) %>%
mutate(chance = round(chance/sum(chance) * 100)) %>% setNames(.,
c("", "Chance (%)")) %>% knitr::kable()
19
File: Handling-pedigrees.R, author: famuvie, license: GNU General Public License v3.0
knitr::kable(ped.nightmare)
19
File: Handling-pedigrees.R, author: famuvie, license: GNU General Public License v3.0
knitr::kable(as.data.frame(ped.fix))
19
File: Handling-pedigrees.R, author: famuvie, license: GNU General Public License v3.0
knitr::kable(PBVs, digits = 2)
19
File: Handling-pedigrees.R, author: famuvie, license: GNU General Public License v3.0
knitr::kable(founders.PBVs, digits = 2)
19
File: Overview.R, author: famuvie, license: GNU General Public License v3.0
knitr::kable(head(globulus))
19
File: Overview.R, author: famuvie, license: GNU General Public License v3.0
knitr::kable(var.comp)
19
File: Overview.R, author: famuvie, license: GNU General Public License v3.0
knitr::kable(round(valid.pred, 2))
19
File: Overview.R, author: famuvie, license: GNU General Public License v3.0
knitr::kable(round(valid.pred[, c(1, 3, 2)], 2))
19
File: help_server.R, author: gadenbuie, license: GNU General Public License v3.0
make_html_table < - function(x) {
select(x, .data$regexp, .data$text) %>% knitr::kable(col.names = c("Regexp",
"Text"), escape = FALSE, format = "html")
}
19
File: kable.R, author: Gedevan-Aleksizde, license: BSD 3-Clause "New" or "Revised" License
kable < - function(x, format, digits = getOption("digits"), row.names = NA,
col.names = NA, align, caption = NULL, label = NULL, format.args = list(),
escape = TRUE, ...) {
knitr::kable(x = x, digits = digits, row.names = row.names,
col.names = col.names, caption = if (knitr::is_latex_output())
commonmark::markdown_latex(caption)
else caption, label = label, format.args = format.args,
escape = escape, ...)
}
19
File: global.R, author: GerkeLab, license: MIT License
debug_input < - function(x, x_name = NULL) {
if (!isTRUE(DEBUG))
return()
if (is.null(x)) {
cat(if (!is.null(x_name))
paste0(x_name, ":"), "NULL", "\n")
}
else if (inherits(x, "igraph")) {
cat(capture.output(print(x)), "", sep = "\n")
}
else if (length(x) == 1 && !is.list(x)) {
cat(if (!is.null(x_name))
paste0(x_name, ":"), if (length(names(x)))
names(x), "-", x, "\n")
}
else if (is.list(x) && length(x) == 0) {
cat(if (!is.null(x_name))
paste0(x_name, ":"), "list()", "\n")
}
else {
if (!inherits(x, "data.frame"))
x < - tibble::enframe(x)
cat(if (!is.null(x_name))
paste0(x_name, ":"), knitr::kable(x), "", sep = "\n")
}
}
19
File: vignette4.R, author: GuillaumePressiat, license: GNU General Public License v2.0
knitr::kable(pmeasyr::vvr_libelles_valo("lib_type_sej"))
19
File: vignette4.R, author: GuillaumePressiat, license: GNU General Public License v2.0
knitr::kable(pmeasyr::vvr_libelles_valo("lib_valo"))
See More Examples
