Nothing
#' @title Internal functions.
#'
#' @description Internal functions that are common to several functions in FSA.
#'
#' @rdname FSA-internals
#' @keywords internal
#' @aliases .onAttach iAddLoessLine iCheckALK iCheckMultColor iCheckStartcatW iCILabel iGetDecimals iGetVarFromFormula iHndlCols2UseIgnore iHndlFormula iHndlMultWhat iLegendHelp iListSpecies iMakeColor iPlotExists is.wholenumber iTypeoflm STOP WARN
# Sends a start-up message to the console when the package is loaded.
.onAttach <- function(lib,pkg,...) {
vers <- read.dcf(system.file("DESCRIPTION",package=pkg,lib.loc=lib),
fields="Version")
msg <- paste0("## FSA v",vers,". See citation('FSA') if used in publication.\n")
msg <- paste0(msg,"## Run fishR() for related website and fishR('IFAR') for related book.")
packageStartupMessage(msg)
}
iAddLoessLine <- function(r,fv,lty.loess,lwd.loess,col.loess,
trans.loess,span=0.75) {
suppressWarnings(mdl <- stats::loess(r~fv,span=span))
xseq <- seq(from=min(fv),to=max(fv),length=80)
pred <- stats::predict(mdl,newdata=data.frame(fv=xseq),se=TRUE)
graphics::polygon(c(xseq,rev(xseq)),
c(pred$fit-pred$se.fit*stats::qt(0.975,pred$df),
rev(pred$fit+pred$se.fit*stats::qt(0.975,pred$df))),
col=col2rgbt(col.loess,trans.loess),border=NA,xpd=FALSE)
graphics::lines(pred$fit~xseq,lwd=lwd.loess,lty=lty.loess,col=col.loess,
xpd=FALSE)
} # end iAddLoessLine internal function
iCheckALK <- function(key,only1=FALSE,remove0rows=FALSE) {
#### only1=TRUE ... only check if rows sum to 1, otherwise also check if sum to 0
#### remove0rows=TRUE ... remove the rows that sum to 0.
## Check that row names and column names can be considered as numeric
suppressWarnings(tmp <- as.numeric(rownames(key)))
if (any(is.na(tmp))) STOP("The row names of 'key' must be numeric (and\n",
"contain the minimum value of the lenth intervals).")
suppressWarnings(tmp <- as.numeric(colnames(key)))
if (any(is.na(tmp))) STOP("The column names of 'key' must be numeric\n",
"(and contain age values).")
## Check if key is proportions, if not change to proportions
if (any(key>1,na.rm=TRUE)) {
WARN("'key' contained values >1; to continue, assumed\n",
"values were frequencies and converted to row proportions.")
key <- prop.table(key,margin=1)
}
## Remove rows that sum to 0 or NA (i.e., only keeps lens with data in key)
key.rowSum <- rowSums(key,na.rm=TRUE)
if (remove0rows & any(key.rowSum==0)) {
WARN("'key' contained rows that sum to 0; as requested,\n",
"these rows were removed from the table.")
key <- key[!is.na(key.rowSum) & key.rowSum!=0,]
}
## Check if rows sum to 1 (allows for some minimal rounding error and
## does not consider zeroes )
if (any(key.rowSum>0.01 & (key.rowSum<0.99 | key.rowSum>1.01)))
WARN("Key contained a row that does not sum to 1.")
## Check if rows sum to 0 (allow for some minimal rounding error)
if (!only1 & !remove0rows & any(key.rowSum==0))
WARN("Key contained rows that sum to 0.")
## Return the potentially modified key
key
}
iCheckW <- function(w) {
if (!is.numeric(w)) STOP("'w' must be numeric.")
if (length(w)>1) STOP("'w' must be a single value.")
if (w<=0) STOP("'w' must be positive.")
# returns decimals of w
iGetDecimals(w)
}
iCheckStartcat <- function(startcat,w,d) {
if (!is.numeric(startcat)) STOP("'startcat' must be numeric.")
if (length(startcat)>1) STOP("'startcat' must be a single value.")
if (startcat<0) STOP("'startcat' must be non-negative.")
if (round(min(d,na.rm=TRUE),w) < round(startcat,w))
STOP("'startcat' is larger than the minimum observation.")
# return decimals of w
iGetDecimals(startcat)
}
iCheckStartcatW <- function(startcat,w,d) {
wdec <- iCheckW(w)
scdec <- iCheckStartcat(startcat,w,d)
# does w have more than (or equal) decimals as startcat
if (scdec>wdec) STOP("'startcat' should not have more decimals than 'w'.",
call.=FALSE)
# return decimals
list(scdec=scdec,wdec=wdec)
}
# Creates a vector of default multiple colors if col==NULL. If col is in
# hcl.pals() then it will create default colors based on that palette,
# Otherwise checks if the provided vector of colors is the same length as n.
iCheckMultColor <- function(col,num) {
# Function to check if all items are valid colors. This is largely from ...
# https://stackoverflow.com/questions/13289009/check-if-character-string-is-a-valid-color-representation/13290832#13290832
iAreColors <- function(x) {
out <- sapply(x,function(x) {
tryCatch(is.matrix(grDevices::col2rgb(x)),error=function(e) FALSE)
})
if(any(is.na(names(out)))) out[is.na(names(out))] <- FALSE
out
}
## Main function
if (is.null(col)) col <- grDevices::hcl.colors(num)
if (length(col)==1) {
if (col %in% grDevices::hcl.pals())
col <- grDevices::hcl.colors(num,palette=col)
}
colcheck <- iAreColors(col)
if (any(!colcheck))
STOP("Your col='",col[!colcheck],
"' is not a valid color or palette in 'hcl.pals()'.")
if (length(col) < num)
WARN("Number of colors (",length(col),
") is less than number of ages (",num,
"); colors will be recycled")
else if (length(col) > num)
WARN("Number of colors (",length(col),
") is more than number of ages (",num,
"); some colors will not be used")
col
}
iCILabel <- function(conf.level,digits=1)
paste(paste0(round(100*conf.level,digits),"%"),c("LCI","UCI"))
# Returns number of decimal places in a number
# Completely from Peter Savicky in http://r.789695.n4.nabble.com/number-of-decimal-places-in-a-number-td4635697.html
iGetDecimals <- function(x) {
if (!is.numeric(x)) STOP("'x' must be numeric.")
if (length(x)>1) STOP("'x' must be a single value.")
if (is.integer(x)) 0
else {
tmp <- format.info(x,digits=10)
if (tmp[3]!=0)
WARN("'x' will be presented in exponential notation.\nReturned decimals may not be what you expected.")
tmp[2]
}
}
iGetVarFromFormula <- function(formula,data,expNumVars=NULL) {
varNms <- names(stats::model.frame(formula,data=data))
# don't "error" check the number of variables
if (is.null(expNumVars)) varNms
else if (length(varNms)!=expNumVars)
STOP("Function only works with formulas with ",expNumVars," variable",
ifelse(expNumVars==1,".","s."))
else varNms
}
iHndlCols2UseIgnore <- function(df,cols2use=NULL,cols2ignore=NULL) {
iHndlCols2Use <- function(df,cols2use) {
if (!inherits(cols2use,c("integer","numeric","character")))
STOP("'cols2use' must be a numeric index or column name.")
if (is.character(cols2use)) {
## Convert character column names to numeric
cols2use <- which(names(df) %in% cols2use)
if (length(cols2use)==0)
STOP("None of columns in 'cols2use' exist in 'df'.")
} else { ## numeric column choices
if (any(cols2use<=0) & any(cols2use>=0))
STOP("'cols2use' must be all positive or all negative.")
if (any(abs(cols2use)>ncol(df)))
STOP("Some 'cols2use' do not exist in 'df'.")
}
cols2use
}
iHndlCols2Ignore <- function(df,col2ignore) {
if (!inherits(cols2ignore,c("integer","numeric","character")))
STOP("'cols2ignore' must be a numeric index or column name.")
if (is.character(cols2ignore)) {
## Convert character column names to numeric
cols2ignore <- which(names(df) %in% cols2ignore)
if (length(cols2ignore)==0)
STOP("None of columns in 'cols2ignore' exist in 'df'.")
} else {
if (any(cols2ignore<=0) & any(cols2ignore>=0))
STOP("'cols2ignore' must be all positive or all negative.")
cols2ignore <- abs(cols2ignore)
if (any(cols2ignore>ncol(df)))
STOP("Some 'cols2ignore' do not exist in 'df'.")
}
-cols2ignore
}
## if both cols2use and cols2ignore are NULL, return the original df
if (is.null(cols2use) & is.null(cols2ignore)) ind <- seq_len(ncol(df))
else if (!is.null(cols2use) & !is.null(cols2ignore))
STOP("Cannot use both 'cols2use' and 'cols2ignore'.")
else if (!is.null(cols2use)) ind <- iHndlCols2Use(df,cols2use)
else ind <- iHndlCols2Ignore(df,cols2ignore)
## Return data.frame of only columns asked for
res <- df[,ind,drop=FALSE]
if (ncol(res)==0) WARN("Resultant data.frame contains no columns.")
res
}
iHndlFormula <- function(formula,data,expNumR=NULL,
expNumE=NULL,expNumENums=NULL,expNumEFacts=NULL) {
mf <- stats::model.frame(formula,data=data,na.action=NULL)
if (ncol(mf)==1) {
# One variable. Return only model.frame, name of variable, and it's
# class; but handle an odd case where the item is an array by
# returning the mode
return(list(mf=mf,vnum=1,vname=names(mf),
vclass=ifelse(is.array(mf[,1]),mode(mf[,1]),class(mf[,1]))))
} else {
# More than one variable in the formula.
# Must identify if there is a LHS.
ifelse(attr(stats::terms(formula),"response")==0,
LHS <- FALSE,LHS <- TRUE)
# See if more than one variable on LHS
if (LHS) {
fcLHS <- as.character(formula)[2]
ifelse(any(c("*","+") %in% substring(fcLHS,seq_len(nchar(fcLHS)),
seq_len(nchar(fcLHS)))),
LHSgt1 <- TRUE, LHSgt1 <- FALSE)
# STOP if there is more than one variable on LHS
if (LHSgt1)
STOP("Function does not work with more than one variable on the LHS.")
else {
# There is a LHS and it has only one variable.
Rpos <- Rnum <- 1
Rname <- names(mf)[Rpos]
Rmf <- mf[,Rpos]
Rclass <- class(Rmf)
Epos <- 2:ncol(mf)
Enames <- names(mf)[Epos]
Enum <- length(Enames)
Emf <- mf[,Epos]
}
} else {
# There is not a LHS
Rnum <- 0
Rpos <- Rname <- Rclass <- NULL
Rmf <- NULL
Emf <- mf
Enames <- names(Emf)
Enum <- length(Enames)
Epos <- seq_len(Enum)
}
# find the class of each response and explanatory variable on the RHS
if (Enum>0) ifelse(Enum==1,Eclass <- class(Emf),
Eclass <- unlist(lapply(Emf,class)))
# get positions of numeric and factor explanatory vars on RHS
ENumPos <- which(Eclass %in% c("numeric","integer","AsIs"))
EFactPos <- which(Eclass %in% c("factor","character"))
# add one to positions if Rnum==1
if (Rnum==1) {
ENumPos <- ENumPos + 1
EFactPos <- EFactPos + 1
}
# get number of numeric and number of factor explanatory vars on RHS
ENumNum <- length(ENumPos)
EFactNum <- length(EFactPos)
}
# Identify the type of data at hand
Etype <- "mixed"
if (ENumNum==0) Etype <- "factor"
if (EFactNum==0) Etype <- "numeric"
# Recreate the model frame data frame
if (Rnum==0) df <- Emf
else df <- data.frame(Rmf,Emf)
names(df) <- c(Rname,Enames)
# Check if the expected number of each type of variable was met
metExpNumR <- metExpNumE <- metExpNumENums <- metExpNumEFacts <- NULL
if (!is.null(expNumR)) ifelse(Rnum==expNumR,
metExpNumR <- TRUE,metExpNumR <- FALSE)
if (!is.null(expNumE)) ifelse(Enum==expNumE,
metExpNumE <- TRUE,metExpNumE <- FALSE)
if (!is.null(expNumENums)) ifelse(ENumNum==expNumENums,
metExpNumENums <- TRUE,
metExpNumENums <- FALSE)
if (!is.null(expNumEFacts)) ifelse(EFactNum==expNumEFacts,
metExpNumEFacts <- TRUE,
metExpNumEFacts <- FALSE)
# put it all together to return
list(formula=formula,mf=df,vnum=Rnum+Enum,
Rnum=Rnum,Rname=Rname,Rclass=Rclass,Rpos=Rpos,
Etype=Etype,Enames=Enames,Eclass=Eclass,Enum=Enum,
ENumNum=ENumNum,ENumPos=ENumPos,
EFactNum=EFactNum,EFactPos=EFactPos,
metExpNumR=metExpNumR,metExpNumE=metExpNumE,
metExpNumENums=metExpNumENums,metExpNumEFacts=metExpNumEFacts)
}
# Internal functions used to handle multiple what= arguments. If more than one
# item then print a line return and return the what vector without item in it.
# This allows an easy way to put space between multiple items without an extra
# space after the last one.
iHndlMultWhat <- function(what,item,type=c("message","cat")) {
type <- match.arg(type)
if (length(what)>1) {
if (type=="message") message("\n")
else cat("\n")
what[-pmatch(item, what)]
}
}
iLegendHelp <- function(legend) {
do.legend <- FALSE
x <- y <- NULL
if (inherits(legend,"logical")) {
if(legend) { # nocov start
do.legend <- TRUE
x <- graphics::locator(1)
} # nocov end
} else if (!is.null(legend)) {
do.legend <- TRUE
if (inherits(legend,"character")) {
if (!(legend %in% c("bottomright","bottom","bottomleft","left",
"topleft","top","topright","right","center")))
STOP("Must use proper keyword for 'legend'.")
x <- legend
} else {
x <- legend[1]
y <- legend[2]
}
}
list(do.legend=do.legend,x=x,y=y)
}
iListSpecies <- function(d) {
message("\nSpecies name must be one of following. Be careful of spelling and capitalization.")
tmp <- unique(d$species)
print(tmp[order(tmp)])
return(invisible())
} # end internal function
iMakeColor <- function(col,transp) {
## Takes a color string and will make it transparent based on
## the value of transp. The transp value must be greater
## than 0. If transp is greater than 1 than it is interpreted
## as the number of points plotted on top of each other before the
## transparency is lost and is, thus, transformed to 1/transp.
## The return value is an rgb() color.
if (transp <= 0) STOP("'transp' must be greater than 0.")
if (transp > 1) transp <- 1/transp
colprts <- grDevices::col2rgb(col)/255
grDevices::rgb(colprts[1,1],colprts[2,1],colprts[3,1],transp)
}
# Checks if a plot exists ... i.e., was there a plot.new
iPlotExists <- function() {
# set options so that warnings are errors
withr::local_options(list(warn=2))
# if plot does not exist that par(new=TRUE) will error and then
# try will return a class of "try-error"
res <- try(graphics::par(new=TRUE),silent=TRUE)
# if errored then say FALSE (i.e., plot does not exist)
res <- ifelse(class(res)=="try-error",FALSE,TRUE)
# return
res
}
# Checks if a value is a whole number
is.wholenumber <- function(x,tol=.Machine$double.eps^0.5) {
abs(x - round(x)) < tol
}
iTypeoflm <- function(mdl) {
if (any(class(mdl)!="lm")) STOP("'iTypeoflm' only works with objects from 'lm()'.")
tmp <- iHndlFormula(stats::formula(mdl),stats::model.frame(mdl))
if (tmp$Enum==0)
STOP("Object must have one response and at least one explanatory variable")
if (!tmp$Rclass %in% c("numeric","integer"))
STOP("Response variable must be numeric")
if (any(tmp$Eclass=="character"))
WARN("An explanatory variable is a 'character' class. If behavior is different\n than you expected you may want to change this to a 'factor' class.")
if (tmp$Etype=="factor") { #ANOVA
if (tmp$EFactNum>2) STOP("Function only works for one- or two-way ANOVA.")
if (tmp$EFactNum==2) lmtype <- "TWOWAY"
else lmtype <- "ONEWAY"
} else { # not an anova
if (tmp$Enum==1) lmtype <- "SLR"
else if (tmp$Etype=="mixed") lmtype <- "IVR"
else if (all(grepl(tmp$Enames[1],tmp$Enames[-1]))) lmtype <- "POLY"
else lmtype <- "MLR"
}
tmp <- c(list(type=lmtype,mdl=mdl),tmp)
class(tmp) <- c(lmtype,"list")
tmp
}
# same as stop() and warning() but with call.=FALSE as default
STOP <- function(...,call.=FALSE,domain=NULL) stop(...,call.=call.,domain=domain)
WARN <- function(...,call.=FALSE,immediate.=FALSE,noBreaks.=FALSE,domain=NULL) {
warning(...,call.=call.,immediate.=immediate.,noBreaks.=noBreaks.,domain=domain)
}
#Checks if specified confidence interval is numeric.
iCheckConfLevel <- function(conf.level) {
if (!is.numeric(conf.level)) STOP("'conf.level' must be numeric.")
if (conf.level<=0 | conf.level>=1) STOP("'conf.level' must be between 0 and 1")
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.