#-----------------------------------------------------------------------
# phfuncs_func.R
#
# PH, 10/9/18
#-----------------------------------------------------------------------
# libraries
#-----------------------------------------------------------------------
#libs <- c(
# "tidyr",
# "dplyr",
# "broom",
# "ggplot2",
# "tidyverse",
# "cowplot"
# )
#
#if (!require("pacman")) install.packages("pacman")
#library("pacman")
#pacman::p_load(char=libs)
#
# functions
#-----------------------------------------------------------------------
#' create_package
#'
#' This function creates an R package from scratch.
#' @param project_name Name of the project.
#' @param folder Root folder to start the project in. Default: ~/projects
#' @keywords module R
#' @export
#' @examples
#' create_package("myproject", "~/tmp")
create_package <- function(project_name, folder) {
# credit:
# hilaryparker.com/2014/04/29/writing-an-r-package-from-scratch/
setwd(folder)
devtools::create(project_name)
}
#' load_libraries
#'
#' This function loads all libraries for building an R package from
#' scratch.
#' @keywords module R
#' @export
#' @examples
#' load_libraries()
load_libraries <- function() {
libs <- c("devtools", "roxygen2")
if (!require("pacman")) install.packages("pacman")
library("pacman")
devtools::install_github("klutometis/roxygen")
pacman::p_load(char=libs)
}
#' create_project
#'
#' This function sets up the typical file structure for projects
#' @param name The name of the project
#' @param title The title of the project
#' @param author The author of the project
#' @param email The email of the project's author
#' @param inst The institution of the project's author
#' @param root The root folder for the project
#' @keywords module R reproducible research
#' @export
#' @examples create_project("myproject", "My Author", "myemail@me.com",
#' "My Institution", "rootdirectory")
create_project <- function(name, title, author, email, inst, root) {
subdirs <- c(
"src",
"lib",
"doc",
"templates",
"output/figures",
"output/R",
"output/tmp",
"pub",
"ext/LaTeX",
"ext/logos"
)
files <- c(
"README.org",
"LICENSE",
"Makefile",
"ms.org",
"clean.R",
"func.R",
"do.R",
"load.R",
"elisp-header.org",
"header.org",
"version.R",
"Module1.xba",
"dialog.xlb",
"script.xlb",
"scientifictemplate.ott",
"install_macro.sh",
"uninstall_macro.sh",
"dotemacs",
"logo.pdf",
"logo_feinstein.pdf",
"github.pdf",
"twitter.pdf",
"beamerthemefeinstein.sty"
)
targets <- c(
paste(name, "README.org", sep="/"),
paste(name, "LICENSE", sep="/"),
paste(name, "Makefile", sep="/"),
paste(name, "/src/", name, "_ms.org", sep=""),
paste(name, "/src/", name, "_clean.R", sep=""),
paste(name, "/src/", name, "_load.R", sep=""),
paste(name, "/src/", name, "_func.R", sep=""),
paste(name, "/src/", name, "_do.R", sep=""),
paste(name, "/templates/", "elisp-header.org", sep=""),
paste(name, "/templates/", "header.org", sep=""),
paste(name, "/templates/", "version.R", sep=""),
paste(name, "/ext/LaTeX/", "Module1.xba", sep=""),
paste(name, "/ext/LaTeX/", "dialog.xlb", sep=""),
paste(name, "/ext/LaTeX/", "script.xlb", sep=""),
paste(name, "/ext/", "scientifictemplate.ott", sep=""),
paste(name, "/ext/", "install_macro.sh", sep=""),
paste(name, "/ext/", "uninstall_macro.sh", sep=""),
paste(name, "/ext/", "dotemacs", sep=""),
paste(name, "/ext/logos/", "logo.pdf", sep=""),
paste(name, "/ext/logos/", "logo_feinstein.pdf", sep=""),
paste(name, "/ext/logos/", "github.pdf", sep=""),
paste(name, "/ext/logos/", "twitter.pdf", sep=""),
paste(name, "/ext/", "beamerthemefeinstein.sty", sep="")
)
#dir.create(project_name)
for (i in 1:length(subdirs)) {
fn <- paste(name, "/", subdirs[i], sep="")
print(fn)
dir.create(fn, recursive=TRUE)
system(paste("touch ", fn, "/NULL", sep=""))
}
for (i in 1:length(files)) {
#from <- paste(project_name, "/templates/", files[i], sep=""))
from <- system.file("templates", files[i], package="phfuncs")
to <- targets[i]
file.copy(from, to)
# parse the file
# replace @@name@@ by project name
system(paste("sed -e 's/@@name@@/", name, "/g' ", to,
" > tmp.txt", sep=""))
# replace @@title@@ by project title
system(paste("sed -e 's/@@title@@/", title, "/g' ", "tmp.txt > ",
to, sep=""))
# replace @@author@@ by project author
system(paste("sed -e 's/@@author@@/", author, "/g' ", to,
" > tmp.txt", sep=""))
# replace @@email@@ by project author's email
system(paste("sed -e 's/@@email@@/", email, "/g' ", "tmp.txt >",
to, sep=""))
# replace @@root@@ by project root
system(paste("sed -e 's/@@root@@/", root, "/g' ", to,
" > tmp.txt", sep=""))
# replace @@inst@@ by project author's institution
system(paste("sed -e 's/@@inst@@/", inst, "/g' ",
"tmp.txt > ", to, sep=""))
# replace @@date@@ by today's date
datestr <- date()
system(paste("sed -e 's/@@date@@/", date(), "/g' ", to,
" > tmp.txt", sep=""))
file.copy("tmp.txt", to, overwrite=TRUE)
}
}
#' starsfromp
#'
#' This function returns asterisks for your P-value.
#' @param pval p-value of interest.
#' @param c1 character for P < 0.1.
#' @param c2 character(s) for P < 0.05.
#' @keywords P-value
#' @export
#' @examples
#' starsfromp(0.02, "")
starsfromp <- function(pval, c1="~", c2="*") {
as <- vector(mode="character", length=length(pval))
for (i in 1:length(pval)) {
p <- pval[i]
if (p < 0.1) as[i] <- c1
if (p < 0.05) as[i] <- paste(c2, sep="")
if (p < 0.01) as[i] <- paste(c2, c2, sep="")
if (p < 0.001) as[i] <- paste(c2, c2, c2, sep="")
}
return(as)
}
#' dic
#'
#' This function calculates the Deviance Information Criterion (DIC).
#' @param stanfit Stan object.
#' @keywords stan
#' @export
#' @examples
#' dic(stanfit)
dic <- function(stanfit) {
p <- rstan::extract(stanfit, permuted=T)
return(mean(p$dev) + 0.5 * (sd(p$dev))^2)
}
#' parse_vals
#'
#' This function parses and formats a P-value.
#' @param action action string. Defaults to pval
#' @param param P-value
#' @keywords P-value
#' @export
#' @examples
#' parse_vals("pval", 0.0001)
parse_vals <- function(action="pval", param) {
switch(action,
pval={
if (param < 0.001) {
return("< 0.001")
} else {
return(paste("=", round(param, 3)))
}
})
}
#' parse_msd
#'
#' This function parses and formats a mean and SD.
#' @param m Mean
#' @param sd Standard deviation
#' @keywords format
#' @export
#' @examples
#' parse_msd(0, 1)
parse_msd <- function(m, sd) {
print(paste("M = ", round(m, 2), ", SD = ", round(sd, 2), sep=""))
}
#' parse_tstat
#'
#' This function parses and formats a t statistic.
#' @param tstat t-test object
#' @keywords stats, t-test
#' @export
#' @examples
#' tstat <- t.test(rnorm(100, 0, 1))
#' parse_tstat(tstat)
parse_tstat <- function(tstat) {
print(paste("/t/ (", round(tstat$parameter,2), ") = ",
round(tstat$statistic, 2), ", /P/ ", parse_vals("pval",
tstat$p.value), sep=""))
}
#' parse_rstat
#'
#' This function parses and formats an r statistic.
#' @param rstat cor.test object
#' @param method Type of correlation. Defaults to Pearson.
#' @keywords stats, correlation
#' @export
#' @examples
#' rstat <- cor.test(rnorm(100, 0, 1), rnorm(100, 0, 1))
#' parse_rstat(rstat)
parse_rstat <- function(rstat, method="pearson") {
switch(method,
pearson = {
print(paste("/r/ (", round(rstat$parameter, 2), ") = ",
round(rstat$estimate, 2), ", /P/ ",
parse_vals("pval", rstat$p.value), sep=""))
},
spearman = {
print(paste("\rho = ",
round(rstat$estimate, 2), ", /P/ ",
parse_vals("pval", rstat$p.value), sep=""))
})
}
#' parse_lm
#'
#' This function parses and formats an linear model object.
#' @param lmfit lm object
#' @param index Line index in data frame
#' @param scaled Was the predicor scaled. Defaults to FALSE.
#' @param style Output format. Defaults to beta.
#' @keywords stats, linear model
#' @export
#' @examples
#' lmfit <- lm(rnorm(100, 0, 1) ~ rnorm(100, 0, 1))
#' parse_lm(lmfit, 1, FALSE, "beta")
parse_lm <- function(lmfit, index=2, scaled=FALSE, style="beta") {
lsm <- as.data.frame(coef(summary(lm.beta(lmfit))))[index, ]
if (scaled==FALSE) {
beta <- lm.beta::lm.beta(lmfit)$standardized.coefficients[index]
}
else {
beta <- lsm$Estimate
}
def <- summary(lmfit)$df[2]
switch(style,
beta = {print(paste("\\beta = ",
round(beta, 2),
", /t/ (", round(def, 2), ") = ",
round(lsm$"t value", 2), ", /P/ ",
parse_vals("pval", lsm$"Pr(>|t|)"),
sep=""))
},
ci = {print(paste("b = ",
round(beta, 2),
", 95% CI [",
round(confint(lmfit, index)[1]),
"; ",
round(confint(lmfit, index)[2]),
"], ",
", /t/ (", round(def, 2), ") = ",
round(lsm$"t value", 2), ", /P/ ",
parse_vals("pval", lsm$"Pr(>|t|)"),
sep=""))
})
}
## parse_fstat <- function(anovatab, index) {
## #
## # parse data frame coming from f test
## #
## #print(anovatab)
## #print(index)
## a <- as.data.frame(anovatab)[index, ]
## print(paste("/F/ (", round(a$NumDF, 2), ", ", round(a$DenDF, 2),
## ") = ", round(a$"F value", 2), ", /P/ ", parse_vals("pval",
## a$"Pr(>F)"), sep=""))
## }
## parse_chi <- function(chisq, def) {
## #
## # fill in pieces of chi square test as text
## #
## pval <- pchisq(chisq, def, lower=FALSE)
## print(paste("\\chi^{2} = ",
## round(chisq, 2), ", df=", def,
## ", /P/ ", parse_vals("pval", pval), sep=""))
## }
## parse_table <- function(table) {
## #
## # remove any nil by replacing NA by whitespace
## #
## table[is.na(table)] <- ""
## return(table)
## }
## parse_pval <- function(pval, rf=2, chs="steq") {
## #
## # Returns a nicely formatted pvalue string
## #
## if(pval < 0.001) {
## fp <- "0.001"
## char <- "< "
## } else if(pval == 0) {
## return(fpval(0.0001))
## } else {
## fp <- as.character(round(pval, rf))
## if (chs == "steq") {
## char <- "= "
## } else {
## char <- NULL
## }
## }
## return(paste(char, fp, sep=""))
## }
## get_partcorr_vec <- function(lmfit, xc) {
## #
## # return partial correlations vectors
## #
## ff <- tempfile()
## png(filename=ff)
## a <- avPlots(lmfit)
## dev.off()
## unlink(ff)
## x <- as.data.frame(a[xc])[, 1]
## y <- as.data.frame(a[xc])[, 2]
## return(data.frame(x=x, y=y))
## }
#df_sum_stats <- function(df) {
# dfm <- df %>% gather(key=Characteristic, value=Value) %>%
# group_by(Characteristic) %>%
# dplyr::summarize(N=sum(!is.na(Value)),
# Mean=round(mean(Value, na.rm=TRUE), 1),
# SD=round(sd(Value, na.rm=TRUE), 1),
# Min=round(min(Value, na.rm=TRUE), 1),
# Max=round(max(Value, na.rm=TRUE), 1))
#
#}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.