Nothing
R/misc.R
In tractor.base: Read, Manipulate and Visualise Magnetic Resonance Images
#' Create a character string by concatenating the elements of a vector
#'
#' Create a character string by concatenating the elements of a vector, using a
#' separator and optional final separator.
#'
#' @param strings A vector, which will be coerced to mode \code{character}.
#' @param sep A unit length character vector giving the separator to insert
#' between elements.
#' @param finalSep An optional unit length character vector giving the
#' separator to insert between the final two elements.
#' @param ranges Logical value. If \code{TRUE} and \code{strings} can be
#' interpreted as integers, collapse runs of consecutive numbers into range
#' notation.
#' @return A character vector of length one.
#' @author Jon Clayden
#' @seealso \code{\link{paste}}
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @examples
#' implode(1:3, ", ") # "1, 2, 3"
#' implode(1:3, ", ", " and ") # "1, 2 and 3"
#' implode(1:2, ", ", " and ") # "1 and 2"
#' implode(1:3, ", ", ranges=TRUE) # "1-3"
#'
#' @export
implode <- function (strings, sep = "", finalSep = NULL, ranges = FALSE)
{
# Transform runs of integers into ranges
# This is surprisingly tricky to get right!
if (ranges && is.integer(strings) && length(strings) > 1)
{
# Perform run-length encoding on the differences between elements
gapRunLengths <- rle(diff(strings))
# Mark all elements not taken and find ranges (>1 consecutive unit difference)
taken <- rep(FALSE, length(strings))
withinRange <- gapRunLengths$values == 1 & gapRunLengths$lengths > 1
# Convert range groups into strings, marking elements as taken to avoid double-counting
rangeStrings <- lapply(which(withinRange), function(i) {
# NB: Sum of a length-zero vector is zero
start <- sum(gapRunLengths$lengths[seq_len(i-1)]) + 1
end <- start + gapRunLengths$lengths[i]
taken[start:end] <<- TRUE
return (paste(strings[start], strings[end], sep="-"))
})
# Convert remaining elements into strings
nonRangeStrings <- lapply(which(!withinRange), function(i) {
start <- sum(gapRunLengths$lengths[seq_len(i-1)]) + 1
end <- start + gapRunLengths$lengths[i]
toKeep <- setdiff(start:end, which(taken))
taken[toKeep] <<- TRUE
return (as.character(strings)[toKeep])
})
# Arrange list of strings in the right order, and convert back to character vector
strings <- vector("list", length(withinRange))
strings[withinRange] <- rangeStrings
strings[!withinRange] <- nonRangeStrings
strings <- unlist(strings)
}
else
strings <- as.character(strings)
if (length(strings) == 1)
return (strings[1])
else if (length(strings) > 1)
{
result <- strings[1]
for (i in 2:length(strings))
{
if (i == length(strings) && !is.null(finalSep))
result <- paste(result, strings[i], sep=finalSep)
else
result <- paste(result, strings[i], sep=sep)
}
return (result)
}
else
return ("")
}
#' Number agreement with a vector
#'
#' This function chooses the singular or plural form of a word based on the
#' length of an associated vector, or an integer.
#'
#' @param singular The singular form of the word.
#' @param x A vector of any mode, whose length is used to choose the correct
#' word form, unless \code{n} is specified.
#' @param n An integer which is used to choose the correct word form (singular
#' if n = 1, plural otherwise). Take priority over \code{x} if not
#' \code{NULL}.
#' @param plural The plural form of the word. If \code{NULL}, an 's' is simply
#' appended to the singular form.
#' @return Either \code{singular} or \code{plural}, as appropriate.
#'
#' @author Jon Clayden
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @export
pluralise <- function (singular, x = NULL, n = NULL, plural = NULL)
{
if (is.null(x) && is.null(n))
report(OL$Error, "Either \"x\" or \"n\" must be given")
else if (is.null(n))
n <- length(x)
if (is.null(plural))
plural <- paste0(singular, "s")
return (ifelse(n==1L, singular, plural))
}
#' Combine similar strings into one
#'
#' Merge a vector of strings with a common prefix and/or suffix into one string
#' with the unique parts in braces, comma-separated.
#'
#' @param strings A vector, which will be coerced to mode \code{character}.
#' @return A single merged string, with the common prefix and suffix as
#' attributes.
#'
#' @author Jon Clayden
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @examples
#' embrace(c("image.hdr", "image.img"))
#'
#' @export
embrace <- function (strings)
{
strings <- as.character(strings)
if (length(strings) < 1)
return (structure("", prefix="", suffix=""))
else if (length(strings) < 2)
return (structure(strings, prefix="", suffix=""))
codepoints <- lapply(enc2utf8(strings), utf8ToInt)
lengths <- sapply(codepoints, length)
sharedLength <- min(lengths)
if (sharedLength == 0)
return (structure(paste0("{",implode(strings,","),"}"), prefix="", suffix=""))
else
{
forwardCodepoints <- sapply(codepoints, function(x) x[seq_len(sharedLength)], simplify="array")
forwardMatches <- apply(forwardCodepoints, 1, allEqual)
prefixLength <- ifelse(all(forwardMatches), sharedLength, which(!forwardMatches)[1] - 1L)
reverseCodepoints <- sapply(codepoints, function(x) rev(x)[seq_len(sharedLength)], simplify="array")
reverseMatches <- apply(reverseCodepoints, 1, allEqual)
suffixLength <- ifelse(all(reverseMatches), sharedLength, which(!reverseMatches)[1] - 1L)
prefix <- intToUtf8(codepoints[[1]][seq_len(prefixLength)])
suffix <- intToUtf8(rev(rev(codepoints[[1]])[seq_len(suffixLength)]))
uniqueParts <- sapply(seq_along(codepoints), function(i) {
indices <- setdiff(seq_len(lengths[i]), c(seq_len(prefixLength), seq_len(suffixLength)+lengths[i]-suffixLength))
intToUtf8(codepoints[[i]][indices])
})
return (structure(es("#{prefix}{#{implode(uniqueParts,',')}}#{suffix}"), prefix=prefix, suffix=suffix))
}
}
#' Pretty print labelled information
#'
#' This is a simple function to print a series of labels and associated data
#' values, or key-value pairs.
#'
#' @param labels A character vector of labels.
#' @param values A character vector of values. Must have the same length as
#' \code{labels}.
#' @param outputLevel The output level to print the output to. See
#' \code{setOutputLevel}, in the reportr package.
#' @param leftJustify Logical value: if \code{TRUE} the labels will be left
#' justified; otherwise they will be right justified.
#' @return This function is called for its side effect.
#' @author Jon Clayden
#' @seealso \code{\link{setOutputLevel}} for the reportr output level system.
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @export
printLabelledValues <- function (labels, values, outputLevel = OL$Info, leftJustify = FALSE)
{
if (length(labels) != length(values))
report(OL$Error, "Labels and values should be of the same length")
labelLengths <- nchar(labels)
maxLabelLength <- max(labelLengths)
nValues <- length(values)
for (i in seq_len(nValues))
{
if (leftJustify)
report(outputLevel, " ", labels[i], implode(rep(" ",maxLabelLength-labelLengths[i]),sep=""), " : ", values[i], prefixFormat="")
else
report(outputLevel, implode(rep(" ",maxLabelLength-labelLengths[i]),sep=""), labels[i], " : ", values[i], prefixFormat="")
}
invisible(NULL)
}
#' Concatenate and deduplicate vectors
#'
#' This function returns its arguments, after concatenating them using \code{c}
#' and then removing elements with duplicate names. The first element with each
#' name will remain, possibly with subsequent elements' content appended to it.
#' Unnamed elements are retained.
#'
#' @param ... One or more vectors of any mode, usually named.
#' @param merge If \code{FALSE}, the default, duplicate elements will simply
#' be discarded. If \code{TRUE}, additional elements with the same name will
#' be appended to the retained one. This does not apply to unnamed elements.
#' If this kind of deduplication actually happens, the return value will be a
#' list, regardless of the source type.
#' @return The concatenated and deduplicated vector.
#' @author Jon Clayden
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @export
deduplicate <- function (..., merge = FALSE)
{
x <- c(...)
n <- names(x)
if (!is.null(n))
{
isDup <- (n != "" & duplicated(n))
if (merge && any(isDup))
{
x <- as.list(x)
# For each duplicated name, replace the first matching element with a concatenated vector
for (dup in unique(n[isDup]))
x[[dup]] <- do.call("c", c(x[names(x) == dup], list(use.names=FALSE)))
}
x <- x[!isDup]
}
return (x)
}
#' Extract one or more elements from a list
#'
#' Given a list-like first argument, this function extracts one or more of its
#' elements. Numeric and character indexing are allowed.
#'
#' @param list A list-like object, with a \code{[[} indexing method.
#' @param index A vector of integers or strings, or \code{NULL}.
#' @return If \code{index} is \code{NULL}, the whole list is returned.
#' Otherwise, if \code{index} has length one, the corresponding element is
#' extracted and returned. Otherwise a list containing the requested subset
#' is returned.
#'
#' @note This function is not type-safe, in the sense that its return type
#' depends on its arguments. It should therefore be used with care.
#' @author Jon Clayden
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @export
indexList <- function (list, index = NULL)
{
if (is.null(index))
return (list)
else if (length(index) == 1)
return (list[[index]])
else
return (list[index])
}
#' Functions for file name and path manipulation
#'
#' Functions for expanding file paths, finding relative paths and ensuring that
#' a file name has the required suffix.
#'
#' The \code{resolvePath} function passes its arguments elementwise through any
#' matching path handler, and returns the resolved paths. Nonmatching elements
#' are returned as-is. \code{registerPathHandler} registers a new path handler
#' for special syntaxes, and is for advanced use only. \code{relativePath}
#' returns the specified \code{path}, expressed relative to
#' \code{referencePath}. \code{matchPaths} resolves a vector of paths against a
#' vector of reference paths. \code{expandFileName} returns the full path to
#' the specified file name, collapsing \code{".."} elements if appropriate.
#' \code{ensureFileSuffix} returns the specified file names with the requested
#' suffixes appended (if they are not already).
#'
#' @param path,referencePath Character vectors whose elements represent file
#' paths (which may or may not currently exist).
#' @param \dots Additional arguments to custom path handlers.
#' @param regex A Ruby-style regular expression.
#' @param handler A function taking and returning a string.
#' @param fileName A character vector of file names.
#' @param base If \code{fileName} is a relative path, this option gives the
#' base directory which the path is relative to. If \code{fileName} is an
#' absolute path, this argument is ignored.
#' @param suffix A character vector of file suffixes, which will be recycled if
#' shorter than \code{fileName}.
#' @param strip A character vector of suffixes to remove before appending
#' \code{suffix}. The intended suffix does not need to be given here, as the
#' function will not append it if the specified file name already has the
#' correct suffix.
#' @return A character vector.
#'
#' @author Jon Clayden
#' @seealso \code{\link{normalizePath}} does most of the work for
#' \code{expandFileName}.
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @aliases paths
#' @rdname paths
#' @export
resolvePath <- function (path, ...)
{
sapply(path, function(p) {
for (i in seq_along(.Workspace$pathHandlers))
{
if (p %~% names(.Workspace$pathHandlers)[i])
{
result <- .Workspace$pathHandlers[[i]](p, ...)
if (!is.null(result))
{
report(OL$Debug, "Resolving #{p} to #{result}")
return (result)
}
}
}
return (p)
})
}
#' @rdname paths
#' @export
relativePath <- function (path, referencePath)
{
mainPieces <- ore.split(ore.escape(.Platform$file.sep), expandFileName(path))
mainPieces <- mainPieces[mainPieces != "."]
refPieces <- ore.split(ore.escape(.Platform$file.sep), expandFileName(referencePath))
refPieces <- refPieces[refPieces != "."]
refIsDir <- isTRUE(file.info(referencePath)$isdir)
shorterLength <- min(length(mainPieces), length(refPieces))
firstDifferentPiece <- min(which(mainPieces[1:shorterLength] != refPieces[1:shorterLength])[1], shorterLength+1, na.rm=TRUE)
newPieces <- rep("..", max(0, length(refPieces)-firstDifferentPiece+as.integer(refIsDir)))
if (length(mainPieces >= firstDifferentPiece))
newPieces <- c(newPieces, mainPieces[firstDifferentPiece:length(mainPieces)])
return (implode(newPieces, sep=.Platform$file.sep))
}
#' @rdname paths
#' @export
matchPaths <- function (path, referencePath)
{
expandedPath <- expandFileName(path)
expandedReferencePath <- expandFileName(referencePath)
indices <- match(expandedPath, expandedReferencePath)
result <- structure(referencePath[indices], indices=indices)
return (result)
}
#' @rdname paths
#' @export
registerPathHandler <- function (regex, handler)
{
if (!is.character(regex) || length(regex) != 1)
report(OL$Error, "Regular expression should be specified as a character string")
handler <- match.fun(handler)
.Workspace$pathHandlers[[regex]] <- handler
invisible(NULL)
}
#' @rdname paths
#' @export
expandFileName <- function (fileName, base = getwd())
{
# Absolute paths are assumed to start with an optional drive letter and colon (for Windows), and then a slash or backslash
# This covers C:\dir\file, \dir\file, \\server\dir\file, //server/dir/file and /dir/file, but not URLs
# Cf. https://docs.microsoft.com/en-gb/windows/win32/fileio/naming-a-file#fully-qualified-vs-relative-paths
fileName <- ifelse(fileName %~% "^([A-Za-z]:)?[/\\\\]|^~", fileName, file.path(base,fileName))
return (normalizePath(fileName, .Platform$file.sep, FALSE))
}
#' @rdname paths
#' @export
ensureFileSuffix <- function (fileName, suffix, strip = NULL)
{
if (is.null(strip))
strip <- suffix %||% "\\w+"
else
strip <- c(strip, suffix)
stripPattern <- paste("\\.(", implode(strip,sep="|"), ")$", sep="")
fileStem <- sub(stripPattern, "", fileName, ignore.case=TRUE, perl=TRUE)
if (is.null(suffix))
return (fileStem)
else if (length(suffix) == 0)
return (character(0))
else
{
fileName <- paste(fileStem, suffix, sep=".")
return (fileName)
}
}
#' @rdname execute
#' @export
locateExecutable <- function (fileName, errorIfMissing = TRUE)
{
pathDirs <- unlist(strsplit(Sys.getenv("PATH"), .Platform$path.sep, fixed=TRUE))
possibleLocations <- file.path(pathDirs, fileName)
if (grepl(.Platform$file.sep, fileName, fixed=TRUE))
possibleLocations <- fileName
filesExist <- file.exists(possibleLocations)
if (sum(filesExist) == 0)
{
if (errorIfMissing)
report(OL$Error, "Required executable \"", fileName, "\" is not available on the system path")
else
return (NULL)
}
else
{
realLocations <- possibleLocations[filesExist]
return (realLocations[1])
}
}
#' Find or run an external executable file
#'
#' The \code{execute} function is a wrapper around the \code{\link{system2}}
#' function in base, which additionally echoes the command being run (including
#' the full path to the executable) if the reportr output level is
#' \code{Debug}. \code{locateExecutable} simply returns the path to an
#' executable file on the system \code{PATH}.
#'
#' @param executable,fileName Name of the executable to run.
#' @param params A character vector giving the parameters to pass to the
#' executable, if any. Elements will be separated by a space.
#' @param errorOnFail,errorIfMissing Logical value: should an error be produced
#' if the executable can't be found?
#' @param silent Logical value: should the executable be run without any
#' output?
#' @param \dots Additional arguments to \code{\link{system}}.
#' @return For \code{execute}, the return value of the underlying call to
#' \code{\link{system2}}. For \code{locateExecutable}, the location of the
#' requested executable, or \code{NULL} if it could not be found.
#'
#' @note These functions are designed for Unix systems and may not work on
#' Windows.
#' @author Jon Clayden
#' @seealso \code{\link{system2}}
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @export
execute <- function (executable, params = NULL, errorOnFail = TRUE, silent = FALSE, ...)
{
execLoc <- locateExecutable(executable, errorOnFail)
if (!is.null(execLoc))
{
report(OL$Debug, "#{execLoc} #{implode(params,sep=' ')}")
if (silent && getOutputLevel() > OL$Debug)
system2(execLoc, as.character(params), stdout=FALSE, stderr=FALSE, ...)
else
system2(execLoc, as.character(params), ...)
}
}
#' Promote a vector to a single-column or single-row matrix
#'
#' The \code{promote} function promotes a vector argument to a single-column or
#' single-row matrix. Matrix arguments are returned unmodified.
#'
#' @param x A vector or matrix.
#' @param byrow Logical value: if \code{TRUE}, a vector will be promoted to a
#' single-row matrix; otherwise a single-column matrix will result.
#' @return A matrix version of the \code{x} argument.
#' @author Jon Clayden
#' @seealso \code{\link{matrix}}
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @export
promote <- function (x, byrow = FALSE)
{
if (is.matrix(x))
return (x)
else if (byrow)
return (matrix(x, nrow=1))
else
return (matrix(x, ncol=1))
}
#' Test two numeric vectors for equivalence
#'
#' This function is a wrapper for \code{isTRUE(all.equal(x,y,\dots{}))}, but
#' with the additional capability of doing sign-insensitive comparison.
#'
#' @param x The first numeric vector.
#' @param y The second numeric vector.
#' @param signMatters Logical value: if FALSE then equivalence in absolute
#' value is sufficient.
#' @param \dots Additional arguments to \code{\link{all.equal}}, notably
#' \code{tolerance}.
#' @return \code{TRUE} if all elements of \code{x} match all elements of
#' \code{y} to within tolerance, ignoring signs if required. \code{FALSE}
#' otherwise.
#' @author Jon Clayden
#' @seealso \code{\link{all.equal}}
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @examples
#'
#' equivalent(c(-1,1), c(1,1)) # FALSE
#' equivalent(c(-1,1), c(1,1), signMatters=FALSE) # TRUE
#' equivalent(1:2, 2:3, tolerance=2) # TRUE
#'
#' @export
equivalent <- function (x, y, signMatters = TRUE, ...)
{
if (signMatters)
return (isTRUE(all.equal(x, y, ...)))
else
return (isTRUE(all.equal(abs(x), abs(y), ...)))
}
#' Test whether all elements of a vector are equal
#'
#' This function tests whether all elements of the specified vector are equal
#' to each other, i.e., whether the vector contains only a single unique value.
#' For lists, equality is determined using \code{\link{equivalent}}.
#'
#' @param x A vector of any mode, including a list.
#' @param ignoreMissing If \code{TRUE}, missing elements will be ignored.
#' Otherwise the presence of missing values will result in a return value of
#' \code{FALSE}.
#' @param \dots Additional arguments to \code{all.equal}, via
#' \code{\link{equivalent}}.
#' @return \code{TRUE} if all elements test equivalent; \code{FALSE}
#' otherwise.
#' @author Jon Clayden
#' @seealso \code{\link{equivalent}} for elementwise equivalence of two
#' vectors.
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @examples
#'
#' allEqual(c(1,1,1)) # TRUE
#' allEqual(c(1,1,NA)) # FALSE
#' allEqual(c(1,1,NA), ignoreMissing=TRUE) # TRUE
#'
#' @export
allEqual <- function (x, ignoreMissing = FALSE, ...)
{
if (ignoreMissing)
x <- x[!is.na(x)]
return (isTRUE(all(sapply(x, equivalent, x[[1]], ...))))
}
stripNul <- function (x, method = c("truncate","drop"))
{
method <- match.arg(method)
nul <- which(x == 0L)
if (length(nul) == 0)
return (x)
else if (method == "truncate")
return (x[seq_len(nul[1]-1)])
else
return (x[-nul])
}
#' Obtain thread-safe temporary file names
#'
#' This function is a wrapper around \code{\link{tempfile}}, which creates
#' temporary file names whose path contains the process ID of the calling
#' process. This avoids clashes between threads created by functions such as
#' \code{mclapply} (in the ``parallel'' package), which can easily occur with
#' the standard \code{\link{tempfile}} function.
#'
#' @param pattern Character vector giving the initial part of each file name.
#' @return A character vector of temporary file names. No files are actually
#' created.
#' @author Jon Clayden
#' @seealso \code{\link{tempfile}}
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @export
threadSafeTempFile <- function (pattern = "file")
{
tempDir <- file.path(tempdir(), paste("temp",Sys.getpid(),sep="_"))
if (!file.exists(tempDir))
dir.create(tempDir)
return (tempfile(pattern=pattern, tmpdir=tempDir))
}
#' Compact conditional values
#'
#' This simple function checks whether its first argument is a logical value
#' that evaluates to \code{TRUE}. If so, it returns its second argument. If
#' not, it returns its third argument.
#'
#' This function differs from the standard \code{\link{ifelse}} function in
#' that it does not act elementwise, and that the third argument is optional,
#' defaulting to \code{NULL}.
#'
#' @param condition An expression that resolves to a single logical value.
#' @param value,fallback Any expression.
#' @return \code{value}, if \code{condition} evaluates to \code{TRUE};
#' otherwise \code{fallback}.
#' @author Jon Clayden
#' @seealso ifelse
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @export
where <- function (condition, value, fallback = NULL)
{
conditionString <- deparse(substitute(condition))
assert(is.logical(condition) && length(condition) == 1, "Condition \"#{conditionString}\" does not evaluate to a single logical value", level=OL$Warning)
if (isTRUE(condition))
return (value)
else
return (fallback)
}
#' Resolve a variable to a default when NULL
#'
#' This is a very simple infix function for the common TractoR idiom whereby
#' \code{NULL} is used as a default argument value, but later needs to be
#' resolved to a meaningful value if not overridden in the call. It returns its
#' first argument unless it is \code{NULL}, in which case it falls back on the
#' second argument.
#'
#' @param X,Y R objects, possibly \code{NULL}.
#' @return \code{X}, if it is not \code{NULL}; otherwise \code{Y}.
#' @author Jon Clayden
#' @seealso \code{\link{where}}, which resolves a value if an expression is
#' \code{TRUE}. Several calls to that function can be conveniently chained
#' together with this one.
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @name infix
#' @rawNamespace if (getRversion() < "4.4") export("%||%")
"%||%" <- function (X, Y)
{
if (is.null(X)) Y else X
}
Try the tractor.base package in your browser
Any scripts or data that you put into this service are public.
tractor.base documentation built on May 29, 2024, 7:58 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
#' Create a character string by concatenating the elements of a vector
#'
#' Create a character string by concatenating the elements of a vector, using a
#' separator and optional final separator.
#'
#' @param strings A vector, which will be coerced to mode \code{character}.
#' @param sep A unit length character vector giving the separator to insert
#' between elements.
#' @param finalSep An optional unit length character vector giving the
#' separator to insert between the final two elements.
#' @param ranges Logical value. If \code{TRUE} and \code{strings} can be
#' interpreted as integers, collapse runs of consecutive numbers into range
#' notation.
#' @return A character vector of length one.
#' @author Jon Clayden
#' @seealso \code{\link{paste}}
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @examples
#' implode(1:3, ", ") # "1, 2, 3"
#' implode(1:3, ", ", " and ") # "1, 2 and 3"
#' implode(1:2, ", ", " and ") # "1 and 2"
#' implode(1:3, ", ", ranges=TRUE) # "1-3"
#'
#' @export
implode <- function (strings, sep = "", finalSep = NULL, ranges = FALSE)
{
# Transform runs of integers into ranges
# This is surprisingly tricky to get right!
if (ranges && is.integer(strings) && length(strings) > 1)
{
# Perform run-length encoding on the differences between elements
gapRunLengths <- rle(diff(strings))
# Mark all elements not taken and find ranges (>1 consecutive unit difference)
taken <- rep(FALSE, length(strings))
withinRange <- gapRunLengths$values == 1 & gapRunLengths$lengths > 1
# Convert range groups into strings, marking elements as taken to avoid double-counting
rangeStrings <- lapply(which(withinRange), function(i) {
# NB: Sum of a length-zero vector is zero
start <- sum(gapRunLengths$lengths[seq_len(i-1)]) + 1
end <- start + gapRunLengths$lengths[i]
taken[start:end] <<- TRUE
return (paste(strings[start], strings[end], sep="-"))
})
# Convert remaining elements into strings
nonRangeStrings <- lapply(which(!withinRange), function(i) {
start <- sum(gapRunLengths$lengths[seq_len(i-1)]) + 1
end <- start + gapRunLengths$lengths[i]
toKeep <- setdiff(start:end, which(taken))
taken[toKeep] <<- TRUE
return (as.character(strings)[toKeep])
})
# Arrange list of strings in the right order, and convert back to character vector
strings <- vector("list", length(withinRange))
strings[withinRange] <- rangeStrings
strings[!withinRange] <- nonRangeStrings
strings <- unlist(strings)
}
else
strings <- as.character(strings)
if (length(strings) == 1)
return (strings[1])
else if (length(strings) > 1)
{
result <- strings[1]
for (i in 2:length(strings))
{
if (i == length(strings) && !is.null(finalSep))
result <- paste(result, strings[i], sep=finalSep)
else
result <- paste(result, strings[i], sep=sep)
}
return (result)
}
else
return ("")
}
#' Number agreement with a vector
#'
#' This function chooses the singular or plural form of a word based on the
#' length of an associated vector, or an integer.
#'
#' @param singular The singular form of the word.
#' @param x A vector of any mode, whose length is used to choose the correct
#' word form, unless \code{n} is specified.
#' @param n An integer which is used to choose the correct word form (singular
#' if n = 1, plural otherwise). Take priority over \code{x} if not
#' \code{NULL}.
#' @param plural The plural form of the word. If \code{NULL}, an 's' is simply
#' appended to the singular form.
#' @return Either \code{singular} or \code{plural}, as appropriate.
#'
#' @author Jon Clayden
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @export
pluralise <- function (singular, x = NULL, n = NULL, plural = NULL)
{
if (is.null(x) && is.null(n))
report(OL$Error, "Either \"x\" or \"n\" must be given")
else if (is.null(n))
n <- length(x)
if (is.null(plural))
plural <- paste0(singular, "s")
return (ifelse(n==1L, singular, plural))
}
#' Combine similar strings into one
#'
#' Merge a vector of strings with a common prefix and/or suffix into one string
#' with the unique parts in braces, comma-separated.
#'
#' @param strings A vector, which will be coerced to mode \code{character}.
#' @return A single merged string, with the common prefix and suffix as
#' attributes.
#'
#' @author Jon Clayden
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @examples
#' embrace(c("image.hdr", "image.img"))
#'
#' @export
embrace <- function (strings)
{
strings <- as.character(strings)
if (length(strings) < 1)
return (structure("", prefix="", suffix=""))
else if (length(strings) < 2)
return (structure(strings, prefix="", suffix=""))
codepoints <- lapply(enc2utf8(strings), utf8ToInt)
lengths <- sapply(codepoints, length)
sharedLength <- min(lengths)
if (sharedLength == 0)
return (structure(paste0("{",implode(strings,","),"}"), prefix="", suffix=""))
else
{
forwardCodepoints <- sapply(codepoints, function(x) x[seq_len(sharedLength)], simplify="array")
forwardMatches <- apply(forwardCodepoints, 1, allEqual)
prefixLength <- ifelse(all(forwardMatches), sharedLength, which(!forwardMatches)[1] - 1L)
reverseCodepoints <- sapply(codepoints, function(x) rev(x)[seq_len(sharedLength)], simplify="array")
reverseMatches <- apply(reverseCodepoints, 1, allEqual)
suffixLength <- ifelse(all(reverseMatches), sharedLength, which(!reverseMatches)[1] - 1L)
prefix <- intToUtf8(codepoints[[1]][seq_len(prefixLength)])
suffix <- intToUtf8(rev(rev(codepoints[[1]])[seq_len(suffixLength)]))
uniqueParts <- sapply(seq_along(codepoints), function(i) {
indices <- setdiff(seq_len(lengths[i]), c(seq_len(prefixLength), seq_len(suffixLength)+lengths[i]-suffixLength))
intToUtf8(codepoints[[i]][indices])
})
return (structure(es("#{prefix}{#{implode(uniqueParts,',')}}#{suffix}"), prefix=prefix, suffix=suffix))
}
}
#' Pretty print labelled information
#'
#' This is a simple function to print a series of labels and associated data
#' values, or key-value pairs.
#'
#' @param labels A character vector of labels.
#' @param values A character vector of values. Must have the same length as
#' \code{labels}.
#' @param outputLevel The output level to print the output to. See
#' \code{setOutputLevel}, in the reportr package.
#' @param leftJustify Logical value: if \code{TRUE} the labels will be left
#' justified; otherwise they will be right justified.
#' @return This function is called for its side effect.
#' @author Jon Clayden
#' @seealso \code{\link{setOutputLevel}} for the reportr output level system.
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @export
printLabelledValues <- function (labels, values, outputLevel = OL$Info, leftJustify = FALSE)
{
if (length(labels) != length(values))
report(OL$Error, "Labels and values should be of the same length")
labelLengths <- nchar(labels)
maxLabelLength <- max(labelLengths)
nValues <- length(values)
for (i in seq_len(nValues))
{
if (leftJustify)
report(outputLevel, " ", labels[i], implode(rep(" ",maxLabelLength-labelLengths[i]),sep=""), " : ", values[i], prefixFormat="")
else
report(outputLevel, implode(rep(" ",maxLabelLength-labelLengths[i]),sep=""), labels[i], " : ", values[i], prefixFormat="")
}
invisible(NULL)
}
#' Concatenate and deduplicate vectors
#'
#' This function returns its arguments, after concatenating them using \code{c}
#' and then removing elements with duplicate names. The first element with each
#' name will remain, possibly with subsequent elements' content appended to it.
#' Unnamed elements are retained.
#'
#' @param ... One or more vectors of any mode, usually named.
#' @param merge If \code{FALSE}, the default, duplicate elements will simply
#' be discarded. If \code{TRUE}, additional elements with the same name will
#' be appended to the retained one. This does not apply to unnamed elements.
#' If this kind of deduplication actually happens, the return value will be a
#' list, regardless of the source type.
#' @return The concatenated and deduplicated vector.
#' @author Jon Clayden
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @export
deduplicate <- function (..., merge = FALSE)
{
x <- c(...)
n <- names(x)
if (!is.null(n))
{
isDup <- (n != "" & duplicated(n))
if (merge && any(isDup))
{
x <- as.list(x)
# For each duplicated name, replace the first matching element with a concatenated vector
for (dup in unique(n[isDup]))
x[[dup]] <- do.call("c", c(x[names(x) == dup], list(use.names=FALSE)))
}
x <- x[!isDup]
}
return (x)
}
#' Extract one or more elements from a list
#'
#' Given a list-like first argument, this function extracts one or more of its
#' elements. Numeric and character indexing are allowed.
#'
#' @param list A list-like object, with a \code{[[} indexing method.
#' @param index A vector of integers or strings, or \code{NULL}.
#' @return If \code{index} is \code{NULL}, the whole list is returned.
#' Otherwise, if \code{index} has length one, the corresponding element is
#' extracted and returned. Otherwise a list containing the requested subset
#' is returned.
#'
#' @note This function is not type-safe, in the sense that its return type
#' depends on its arguments. It should therefore be used with care.
#' @author Jon Clayden
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @export
indexList <- function (list, index = NULL)
{
if (is.null(index))
return (list)
else if (length(index) == 1)
return (list[[index]])
else
return (list[index])
}
#' Functions for file name and path manipulation
#'
#' Functions for expanding file paths, finding relative paths and ensuring that
#' a file name has the required suffix.
#'
#' The \code{resolvePath} function passes its arguments elementwise through any
#' matching path handler, and returns the resolved paths. Nonmatching elements
#' are returned as-is. \code{registerPathHandler} registers a new path handler
#' for special syntaxes, and is for advanced use only. \code{relativePath}
#' returns the specified \code{path}, expressed relative to
#' \code{referencePath}. \code{matchPaths} resolves a vector of paths against a
#' vector of reference paths. \code{expandFileName} returns the full path to
#' the specified file name, collapsing \code{".."} elements if appropriate.
#' \code{ensureFileSuffix} returns the specified file names with the requested
#' suffixes appended (if they are not already).
#'
#' @param path,referencePath Character vectors whose elements represent file
#' paths (which may or may not currently exist).
#' @param \dots Additional arguments to custom path handlers.
#' @param regex A Ruby-style regular expression.
#' @param handler A function taking and returning a string.
#' @param fileName A character vector of file names.
#' @param base If \code{fileName} is a relative path, this option gives the
#' base directory which the path is relative to. If \code{fileName} is an
#' absolute path, this argument is ignored.
#' @param suffix A character vector of file suffixes, which will be recycled if
#' shorter than \code{fileName}.
#' @param strip A character vector of suffixes to remove before appending
#' \code{suffix}. The intended suffix does not need to be given here, as the
#' function will not append it if the specified file name already has the
#' correct suffix.
#' @return A character vector.
#'
#' @author Jon Clayden
#' @seealso \code{\link{normalizePath}} does most of the work for
#' \code{expandFileName}.
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @aliases paths
#' @rdname paths
#' @export
resolvePath <- function (path, ...)
{
sapply(path, function(p) {
for (i in seq_along(.Workspace$pathHandlers))
{
if (p %~% names(.Workspace$pathHandlers)[i])
{
result <- .Workspace$pathHandlers[[i]](p, ...)
if (!is.null(result))
{
report(OL$Debug, "Resolving #{p} to #{result}")
return (result)
}
}
}
return (p)
})
}
#' @rdname paths
#' @export
relativePath <- function (path, referencePath)
{
mainPieces <- ore.split(ore.escape(.Platform$file.sep), expandFileName(path))
mainPieces <- mainPieces[mainPieces != "."]
refPieces <- ore.split(ore.escape(.Platform$file.sep), expandFileName(referencePath))
refPieces <- refPieces[refPieces != "."]
refIsDir <- isTRUE(file.info(referencePath)$isdir)
shorterLength <- min(length(mainPieces), length(refPieces))
firstDifferentPiece <- min(which(mainPieces[1:shorterLength] != refPieces[1:shorterLength])[1], shorterLength+1, na.rm=TRUE)
newPieces <- rep("..", max(0, length(refPieces)-firstDifferentPiece+as.integer(refIsDir)))
if (length(mainPieces >= firstDifferentPiece))
newPieces <- c(newPieces, mainPieces[firstDifferentPiece:length(mainPieces)])
return (implode(newPieces, sep=.Platform$file.sep))
}
#' @rdname paths
#' @export
matchPaths <- function (path, referencePath)
{
expandedPath <- expandFileName(path)
expandedReferencePath <- expandFileName(referencePath)
indices <- match(expandedPath, expandedReferencePath)
result <- structure(referencePath[indices], indices=indices)
return (result)
}
#' @rdname paths
#' @export
registerPathHandler <- function (regex, handler)
{
if (!is.character(regex) || length(regex) != 1)
report(OL$Error, "Regular expression should be specified as a character string")
handler <- match.fun(handler)
.Workspace$pathHandlers[[regex]] <- handler
invisible(NULL)
}
#' @rdname paths
#' @export
expandFileName <- function (fileName, base = getwd())
{
# Absolute paths are assumed to start with an optional drive letter and colon (for Windows), and then a slash or backslash
# This covers C:\dir\file, \dir\file, \\server\dir\file, //server/dir/file and /dir/file, but not URLs
# Cf. https://docs.microsoft.com/en-gb/windows/win32/fileio/naming-a-file#fully-qualified-vs-relative-paths
fileName <- ifelse(fileName %~% "^([A-Za-z]:)?[/\\\\]|^~", fileName, file.path(base,fileName))
return (normalizePath(fileName, .Platform$file.sep, FALSE))
}
#' @rdname paths
#' @export
ensureFileSuffix <- function (fileName, suffix, strip = NULL)
{
if (is.null(strip))
strip <- suffix %||% "\\w+"
else
strip <- c(strip, suffix)
stripPattern <- paste("\\.(", implode(strip,sep="|"), ")$", sep="")
fileStem <- sub(stripPattern, "", fileName, ignore.case=TRUE, perl=TRUE)
if (is.null(suffix))
return (fileStem)
else if (length(suffix) == 0)
return (character(0))
else
{
fileName <- paste(fileStem, suffix, sep=".")
return (fileName)
}
}
#' @rdname execute
#' @export
locateExecutable <- function (fileName, errorIfMissing = TRUE)
{
pathDirs <- unlist(strsplit(Sys.getenv("PATH"), .Platform$path.sep, fixed=TRUE))
possibleLocations <- file.path(pathDirs, fileName)
if (grepl(.Platform$file.sep, fileName, fixed=TRUE))
possibleLocations <- fileName
filesExist <- file.exists(possibleLocations)
if (sum(filesExist) == 0)
{
if (errorIfMissing)
report(OL$Error, "Required executable \"", fileName, "\" is not available on the system path")
else
return (NULL)
}
else
{
realLocations <- possibleLocations[filesExist]
return (realLocations[1])
}
}
#' Find or run an external executable file
#'
#' The \code{execute} function is a wrapper around the \code{\link{system2}}
#' function in base, which additionally echoes the command being run (including
#' the full path to the executable) if the reportr output level is
#' \code{Debug}. \code{locateExecutable} simply returns the path to an
#' executable file on the system \code{PATH}.
#'
#' @param executable,fileName Name of the executable to run.
#' @param params A character vector giving the parameters to pass to the
#' executable, if any. Elements will be separated by a space.
#' @param errorOnFail,errorIfMissing Logical value: should an error be produced
#' if the executable can't be found?
#' @param silent Logical value: should the executable be run without any
#' output?
#' @param \dots Additional arguments to \code{\link{system}}.
#' @return For \code{execute}, the return value of the underlying call to
#' \code{\link{system2}}. For \code{locateExecutable}, the location of the
#' requested executable, or \code{NULL} if it could not be found.
#'
#' @note These functions are designed for Unix systems and may not work on
#' Windows.
#' @author Jon Clayden
#' @seealso \code{\link{system2}}
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @export
execute <- function (executable, params = NULL, errorOnFail = TRUE, silent = FALSE, ...)
{
execLoc <- locateExecutable(executable, errorOnFail)
if (!is.null(execLoc))
{
report(OL$Debug, "#{execLoc} #{implode(params,sep=' ')}")
if (silent && getOutputLevel() > OL$Debug)
system2(execLoc, as.character(params), stdout=FALSE, stderr=FALSE, ...)
else
system2(execLoc, as.character(params), ...)
}
}
#' Promote a vector to a single-column or single-row matrix
#'
#' The \code{promote} function promotes a vector argument to a single-column or
#' single-row matrix. Matrix arguments are returned unmodified.
#'
#' @param x A vector or matrix.
#' @param byrow Logical value: if \code{TRUE}, a vector will be promoted to a
#' single-row matrix; otherwise a single-column matrix will result.
#' @return A matrix version of the \code{x} argument.
#' @author Jon Clayden
#' @seealso \code{\link{matrix}}
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @export
promote <- function (x, byrow = FALSE)
{
if (is.matrix(x))
return (x)
else if (byrow)
return (matrix(x, nrow=1))
else
return (matrix(x, ncol=1))
}
#' Test two numeric vectors for equivalence
#'
#' This function is a wrapper for \code{isTRUE(all.equal(x,y,\dots{}))}, but
#' with the additional capability of doing sign-insensitive comparison.
#'
#' @param x The first numeric vector.
#' @param y The second numeric vector.
#' @param signMatters Logical value: if FALSE then equivalence in absolute
#' value is sufficient.
#' @param \dots Additional arguments to \code{\link{all.equal}}, notably
#' \code{tolerance}.
#' @return \code{TRUE} if all elements of \code{x} match all elements of
#' \code{y} to within tolerance, ignoring signs if required. \code{FALSE}
#' otherwise.
#' @author Jon Clayden
#' @seealso \code{\link{all.equal}}
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @examples
#'
#' equivalent(c(-1,1), c(1,1)) # FALSE
#' equivalent(c(-1,1), c(1,1), signMatters=FALSE) # TRUE
#' equivalent(1:2, 2:3, tolerance=2) # TRUE
#'
#' @export
equivalent <- function (x, y, signMatters = TRUE, ...)
{
if (signMatters)
return (isTRUE(all.equal(x, y, ...)))
else
return (isTRUE(all.equal(abs(x), abs(y), ...)))
}
#' Test whether all elements of a vector are equal
#'
#' This function tests whether all elements of the specified vector are equal
#' to each other, i.e., whether the vector contains only a single unique value.
#' For lists, equality is determined using \code{\link{equivalent}}.
#'
#' @param x A vector of any mode, including a list.
#' @param ignoreMissing If \code{TRUE}, missing elements will be ignored.
#' Otherwise the presence of missing values will result in a return value of
#' \code{FALSE}.
#' @param \dots Additional arguments to \code{all.equal}, via
#' \code{\link{equivalent}}.
#' @return \code{TRUE} if all elements test equivalent; \code{FALSE}
#' otherwise.
#' @author Jon Clayden
#' @seealso \code{\link{equivalent}} for elementwise equivalence of two
#' vectors.
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @examples
#'
#' allEqual(c(1,1,1)) # TRUE
#' allEqual(c(1,1,NA)) # FALSE
#' allEqual(c(1,1,NA), ignoreMissing=TRUE) # TRUE
#'
#' @export
allEqual <- function (x, ignoreMissing = FALSE, ...)
{
if (ignoreMissing)
x <- x[!is.na(x)]
return (isTRUE(all(sapply(x, equivalent, x[[1]], ...))))
}
stripNul <- function (x, method = c("truncate","drop"))
{
method <- match.arg(method)
nul <- which(x == 0L)
if (length(nul) == 0)
return (x)
else if (method == "truncate")
return (x[seq_len(nul[1]-1)])
else
return (x[-nul])
}
#' Obtain thread-safe temporary file names
#'
#' This function is a wrapper around \code{\link{tempfile}}, which creates
#' temporary file names whose path contains the process ID of the calling
#' process. This avoids clashes between threads created by functions such as
#' \code{mclapply} (in the ``parallel'' package), which can easily occur with
#' the standard \code{\link{tempfile}} function.
#'
#' @param pattern Character vector giving the initial part of each file name.
#' @return A character vector of temporary file names. No files are actually
#' created.
#' @author Jon Clayden
#' @seealso \code{\link{tempfile}}
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @export
threadSafeTempFile <- function (pattern = "file")
{
tempDir <- file.path(tempdir(), paste("temp",Sys.getpid(),sep="_"))
if (!file.exists(tempDir))
dir.create(tempDir)
return (tempfile(pattern=pattern, tmpdir=tempDir))
}
#' Compact conditional values
#'
#' This simple function checks whether its first argument is a logical value
#' that evaluates to \code{TRUE}. If so, it returns its second argument. If
#' not, it returns its third argument.
#'
#' This function differs from the standard \code{\link{ifelse}} function in
#' that it does not act elementwise, and that the third argument is optional,
#' defaulting to \code{NULL}.
#'
#' @param condition An expression that resolves to a single logical value.
#' @param value,fallback Any expression.
#' @return \code{value}, if \code{condition} evaluates to \code{TRUE};
#' otherwise \code{fallback}.
#' @author Jon Clayden
#' @seealso ifelse
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @export
where <- function (condition, value, fallback = NULL)
{
conditionString <- deparse(substitute(condition))
assert(is.logical(condition) && length(condition) == 1, "Condition \"#{conditionString}\" does not evaluate to a single logical value", level=OL$Warning)
if (isTRUE(condition))
return (value)
else
return (fallback)
}
#' Resolve a variable to a default when NULL
#'
#' This is a very simple infix function for the common TractoR idiom whereby
#' \code{NULL} is used as a default argument value, but later needs to be
#' resolved to a meaningful value if not overridden in the call. It returns its
#' first argument unless it is \code{NULL}, in which case it falls back on the
#' second argument.
#'
#' @param X,Y R objects, possibly \code{NULL}.
#' @return \code{X}, if it is not \code{NULL}; otherwise \code{Y}.
#' @author Jon Clayden
#' @seealso \code{\link{where}}, which resolves a value if an expression is
#' \code{TRUE}. Several calls to that function can be conveniently chained
#' together with this one.
#' @references Please cite the following reference when using TractoR in your
#' work:
#'
#' J.D. Clayden, S. Muñoz Maniega, A.J. Storkey, M.D. King, M.E. Bastin & C.A.
#' Clark (2011). TractoR: Magnetic resonance imaging and tractography with R.
#' Journal of Statistical Software 44(8):1-18. \doi{10.18637/jss.v044.i08}.
#' @name infix
#' @rawNamespace if (getRversion() < "4.4") export("%||%")
"%||%" <- function (X, Y)
{
if (is.null(X)) Y else X
}
Try the tractor.base package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.