Nothing
#======================================================================
# Miscelaneous functions (and a data vector)
#======================================================================
#======================================================================
# convert named vector to 2-column data.frame
as.DF <- function(V, colnames=c("name", "x")) {
setNames(data.frame(c1 = names(V), c2=V), colnames)
}
#======================================================================
# test if can be converted to integers/numbers ----
check.integer <- function(xx) ifelse(is.na(xx), NA,
grepl("^[-]{0,1}[0-9]{1,}$", xx))
#======================================================================
# Comparison ----
eqv <- function(x, V, xNA=FALSE) {
if (length(x)==1) {
if (!is.na(x)) {
y <- ifelse(!is.na(V), x==V, FALSE)
} else if (is.na(xNA)) {
y <- is.na(V)
} else {
y <- rep(xNA, length(V))
}
} else if (length(x)==length(V)) {
y <- ifelse(!is.na(x) & !is.na(V),
x==V,
ifelse(is.na(x) & is.na(V),
ifelse(is.na(xNA),
TRUE,
xNA),
FALSE))
} else {
stop("unequal lengths")
}
y
}
#======================================================================
# Convert factor to numeric ----
FacToNum <- function(x) as.numeric(as.character(x))
#======================================================================
# inflate square matrix to larger square matrix with more IDs
inflate <- function(M, IDnew, na=NA) {
Mnew <- matrix(na, length(IDnew), length(IDnew), dimnames=list(IDnew, IDnew))
if (is.null(rownames(M)) & nrow(M)==ncol(M)) rownames(M) <- colnames(M)
Mnew[rownames(M), colnames(M)] <- M
Mnew
}
#======================================================================
# function adapted from Examples from integer {base}
is.wholenumber <- function(x, tol = .Machine$double.eps^0.5) {
ifelse(!is.numeric(x) | !is.finite(x),
FALSE,
abs(x - round(x)) < tol)
}
#======================================================================
#' @title Special Merge
#'
#' @description As regular merge, but combine data from columns with the same
#' name.
#'
#' @param df1 first dataframe (lowest priority if \code{overwrite=TRUE}).
#' @param df2 second dataframe (highest priority if \code{overwrite=TRUE}).
#' @param by columns used for merging, required.
#' @param overwrite If FALSE (the default), NA's in df1 are replaced by values
#' from df2. If TRUE, all values in df1 are overwritten by values from df2,
#' except where df2 has NA.
#' @param ... additional arguments to merge, such as \code{all}.
#'
#' @keywords internal
MergeFill <- function(df1, df2, by, overwrite=FALSE, ...) {
commonNames <- names(df1)[which(colnames(df1) %in% colnames(df2))]
commonNames <- commonNames[!commonNames %in% by]
dfmerged <- merge(df1,df2,by=by,...)
for(i in commonNames){
left <- paste0(i, ".x")
right <- paste0(i, ".y")
if (!overwrite) {
dfmerged[is.na(dfmerged[left]),left] <- dfmerged[is.na(dfmerged[left]),right]
} else {
dfmerged[!is.na(dfmerged[right]),left] <- dfmerged[!is.na(dfmerged[right]),right]
}
dfmerged[right]<- NULL
colnames(dfmerged)[colnames(dfmerged) == left] <- i
}
dfmerged
}
#======================================================================
# make a named list, i.e. namedlist(a, b, x) i.o. list(a=a, b=b, x=x) ----
namedlist <- function(...) {
L <- list(...)
EnvNames <- as.character(as.list( match.call())[-1L])
if (is.null(names(L))) { # all elements unnamed
names(L) <- EnvNames
} else { # some elements unnamed
names(L) <- ifelse(names(L)=="", EnvNames, names(L))
}
return( L )
}
#======================================================================
# priority of relationships (close -> distant)
# used by GetRelM() & ComparePairs()
RelRank <- c("S", "M", "P", "MP", "O", "PO?",
"FS","FS?", "MHS", "PHS", "HS", "HS?",
"MGM", "MGF", "PGM", "PGF", "GP", "GO","GP?",
"FA", "FN", "FA?", "2nd?", "HA", "HN","HA?",
"DFC1", "FC1", "XX?", "Q?", "U", "X")
#======================================================================
# simpleCap ----
.simpleCap <- function(x) {
s <- strsplit(x, " ")[[1]]
paste(toupper(substring(s, 1, 1)), tolower(substring(s, 2)),
sep = "", collapse = " ")
}
#======================================================================
# if plotting area too small: throw message & continue, instead of error stop
tryPlot <- function(FUN, ...,
# ErrMsg = "Plotting area too small",
oldpar) {
OK <- TRUE
img <- tryCatch(
suppressWarnings(
do.call(FUN, list(...))
),
error = function(e) {
message(e) #(ErrMsg)
return(NA)
} )
if (!is.null(img) && all(is.na(img))) {
OK <- FALSE
par(oldpar)
}
return(OK)
}
#======================================================================
# transform vector to matrix ----
VtoM <- function(V, nr=NULL, nc=2, Ng_odd=FALSE) {
if(Ng_odd) {
V <- V[1:((length(V)/nc-1)*nc)]
}
M <- matrix(V, length(V)/nc, nc)
if(!is.null(nr)) M <- M[1:nr, , drop=FALSE]
M
}
XtoM <- function(V, nr=NULL, nc=2, Ng_odd=FALSE) {
if(Ng_odd) {
V <- V[1 : (floor(length(V)/nc)*nc)] # Fortran doesn't round but chops
}
M <- matrix(V, length(V)/nc, nc)
if(!is.null(nr)) M <- M[1:nr, , drop=FALSE]
M
}
#======================================================================
##' Catch *and* save both errors and warnings, and in the case of
##' a warning, also keep the computed result.
##'
##' @title tryCatch both warnings (with value) and errors
##' @param expr an \R expression to evaluate
##' @return a list with 'value' and 'warning', where
##' 'value' may be an error caught.
##' @author Martin Maechler;
##' Copyright (C) 2010-2012 The R Core Team
##'
#' @keywords internal
tryCatch.W.E <- function(expr)
{
W <- NULL
w.handler <- function(w){ # warning handler
W <<- w
invokeRestart("muffleWarning")
}
list(value = withCallingHandlers(tryCatch(expr, error = function(e) e),
warning = w.handler),
warning = W)
}
# #======================================================================
# # functions not used in current version
# #======================================================================
#
# #======================================================================
# # test if can be converted to numbers
# check.numeric <- function(xx) ifelse(is.na(xx), NA,
# grepl("^[-]{0,1}[0-9]{0,}.{0,1}[0-9]{1,}$", xx))
#
#
# #======================================================================
# fc <- function(x, w=2) formatC(x, width=w, flag="0")
#
#
# #======================================================================
# # Value Matching
# "%ina%" <- function(x, y) ifelse(!is.na(x), match(x, y, nomatch = 0) > 0, NA)
#
#
# #======================================================================
# Replace <- function(V, old, new) {
# # base function 'replace' with match only replaces first match.
# if (length(old) != length(new)) stop("'old' and 'new' must have same length")
# if (!all(old %in% V)) stop("all 'old' must be in V")
# these <- lapply(seq_along(old), function(x, y=V) which(y == old[x]))
# newr <- rep(new, sapply(these, length))
# replace(V, unlist(these), newr)
# }
#
#
# #======================================================================
# # table, sets UseNA to 'ifany'
# Table <- function(...) table(..., useNA="ifany")
#
#
# #======================================================================
# # create a table, and ensure that the levels TRUE, FALSE and NA are always all
# tbl.logic <- function(x) table(factor(x, levels=c(TRUE, FALSE, NA)),
# useNA="always")
#
#
# #======================================================================
# add GP columns to pedigree ----
# GPcols <- function(Ped) {
# IDorder <- Ped$id # merge() ignores sort=FALSE
# Ped <- merge(Ped, setNames(Ped[Ped$id %in% Ped$dam, c("id","dam","sire")],
# c("dam", "MGM", "MGF")), all.x=TRUE)
# Ped <- merge(Ped, setNames(Ped[Ped$id %in% Ped$sire, c("id","dam","sire")],
# c("sire", "PGM", "PGF")), all.x=TRUE)
# rownames(Ped) <- Ped$id
# ColOrder <- c("id","dam","sire","MGM", "MGF","PGM", "PGF")
# return( Ped[IDorder, c(ColOrder, setdiff(colnames(Ped), ColOrder))] )
# }
#
#
# #======================================================================
# merge huge dataframes ----
# merge.dt <- function(df1, df2, key, quiet, ...) {
# if (requireNamespace("data.table", quietly = TRUE)) {
# df.12 <- as.data.frame(merge(data.table::data.table(df1, key=key),
# data.table::data.table(df2, key=key),
# ...))
# } else {
# df.12 <- merge(df1, df2, ...)
# if (!quiet & (nrow(df1)>5000 | nrow(df2)>5000)) { # fairly arbitrary
# message("installing package 'data.table' is recommended to speed up",
# "merging huge data.frames")
# }
# }
#
# return( df.12 )
# }
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.