# set up per-format symbols
formats <- c('markdown','html','ascii','latex', 'docx', 'pandoc',
'markdown_github')
markdownSynonyms <- c('markdown_github')
symCodes <- c('startB','endB','startI','endI','eq','lt',
'RSq','chiSq')
syms <- matrix('',nrow=length(formats),ncol=length(symCodes),
dimnames=list(formats,symCodes))
syms[,'eq'] <- '='
syms[,'lt'] <- '<'
syms[,'RSq'] <- 'R2'
syms[,'chiSq'] <- 'X2'
syms['html','startI'] <- '<i>'
syms['html','endI'] <- '</i>'
syms['html','startB'] <- '<b>'
syms['html','endB'] <- '</b>'
syms['html','lt'] <- '<'
syms['html','RSq'] <- '<i>R<sup>2</sup></i>'
syms['html','chiSq'] <- '<i>χ<sup>2</sup></i>'
syms['latex','startI'] <- '\\textit{'
syms['latex','endI'] <- '}'
syms['latex','startB'] <- '\\textbf{'
syms['latex','endB'] <- '}'
syms['latex','lt'] <- ' $\\lt$ '
syms['latex','RSq'] <- '$R^2$'
syms['latex','chiSq'] <- '$\\chi^2$'
syms['markdown',] <- syms['html',]
syms['markdown','startI'] <- '*'
syms['markdown','endI'] <- '*'
syms['markdown','startB'] <- '**'
syms['markdown','endB'] <- '**'
syms['markdown','RSq'] <- '<i>R^2^</i>'
syms['markdown','chiSq'] <- '<i>χ^2^</i>'
syms['pandoc',] <- syms['markdown',]
syms['docx',] <- syms['markdown',]
for(fi in markdownSynonyms) {
syms[fi,] <- syms['markdown',]
}
#' Detect rendering format (using knitr).
#'
#'
#' @return rendering format
#'
#' @examples
#'
#' getRenderingFormat()
#'
#' @export
getRenderingFormat <- function() {
fmt <- NULL
if(requireNamespace("knitr",quietly=TRUE)) {
fmt <- knitr::opts_knit$get("rmarkdown.pandoc.to")
}
if(is.null(fmt)) {
fmt <- 'ascii'
}
if(!isTRUE(fmt %in% formats)) {
fmt <- "ascii"
}
fmt
}
#' @importFrom parallel parLapplyLB
NULL
# maybe run parallel
plapply <- function(workList, worker, parallelCluster) {
if(is.null(parallelCluster) || (!requireNamespace("parallel",quietly=TRUE))) {
res <- lapply(workList,worker)
} else {
res <- parallel::parLapplyLB(parallelCluster,workList,worker)
}
res
}
#' Calculate deviance.
#'
#' @param pred numeric predictions
#' @param y logical truth
#' @param na.rm logical, if TRUE remove NA values
#' @param eps numeric, smoothing term
#' @return deviance
#'
#' @examples
#'
#' sigr::calcDeviance(1:4,c(TRUE,FALSE,TRUE,TRUE))
#'
#' @export
calcDeviance <- function(pred, y,
na.rm= FALSE,
eps= 1.0e-6) {
if(!is.numeric(pred)) {
stop("sigr::calcDeviance pred must be numeric")
}
if(!is.logical(y)) {
stop("sigr::calcDeviance y must be logical")
}
if((length(pred)==1)&&(length(y)>1)) {
pred <- rep(pred, length(y))
}
if(length(pred)!=length(y)) {
stop("sigr::calcDeviance must have length(pred)==length(y)")
}
if(na.rm) {
goodPosns <- (!is.na(pred)) & (!is.na(y))
pred <- pred[goodPosns]
y <- y[goodPosns]
}
-2*sum(log(pmin(1-eps,pmax(eps,ifelse(y,pred,1-pred)))))
}
#' Calculate sum of squared error.
#'
#' @param pred numeric predictions
#' @param y numeric truth
#' @param na.rm logical, if TRUE remove NA values
#' @return sum of squared error
#'
#' @examples
#'
#' sigr::calcSSE(1:4,c(1,0,1,1))
#'
#' @export
calcSSE <- function(pred, y,
na.rm= FALSE) {
if(!is.numeric(pred)) {
stop("sigr::calcSSE pred must be numeric")
}
if(!is.numeric(y)) {
stop("sigr::calcSSE y must be numeric")
}
if((length(pred)==1)&&(length(y)>1)) {
pred <- rep(pred, length(y))
}
if(length(pred)!=length(y)) {
stop("sigr::calcSSE must have length(pred)==length(y)")
}
if(na.rm) {
goodPosns <- (!is.na(pred)) & (!is.na(y))
pred <- pred[goodPosns]
y <- y[goodPosns]
}
sum((y-pred)^2)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.