# R/hlpr.R In solavrov/hlpr: General Helper

```#' Add an element to a given list
#'
#' @param givenList Given list
#' @return New list with added element
#' @export

return(givenList)

}

#' Calculate vector of simple percent changes of input vector
#'
#' @param v Given vector
#'
#' @return Vector of simple percent changes
#' @export
calcPercentChanges <- function(v) {
tail(v, -1) / head(v, -1) - 1
}

#' Calculate vector of log percent changes of input vector
#'
#' @param v Given vector
#'
#' @return Vector of log percent changes
#' @export
calcLogChanges <- function(v) {
}

#' Get last element of vector
#'
#' @param v given vector
#'
#' @return last element
#' @export
getLast <- function(v) {
tail(v, 1)
}

#' Calculate percentage of vector's elements inside given range inclusive
#'
#' @param v given vector
#' @param range given range
#'
#' @return percentage of vector's elements inside range
#' @export
calcPercentInsideInclusive <- function(v, range) {
length(v[v>=range[1] & v<=range[2]]) / length(v)
}

#' Get indices of max element of matrix
#'
#' @param m given matrix
#'
#' @return indices of max element of matrix
#' @export
getIndicesOfMax <- function(m) {
which(m == max(m), arr.ind = TRUE)
}

#' Return set of colors for 3d surface
#' Author: [email protected]
#'
#' @param z matrix of z-values of the surface
#' @param col palette
#'
#' @return vector of colors for 3d surface
#' @export
getSurfColors <- function(z, col = cm.colors(40)) {

# First we drop the 'borders' and average the facet corners
# we need (nx - 1)(ny - 1) facet colours!
avg <- (z[-1, -1] + z[-1, -(ncol(z) - 1)] +
z[-(nrow(z) -1), -1] + z[-(nrow(z) -1), -(ncol(z) - 1)]) / 4

# Now we construct the actual colours matrix
colors = col[cut(avg, breaks = length(col), include.lowest = T)]

return (colors)

}

#' Build vector filled with repeating 1, 2, 3...
#'
#' @param periodLength How many times to repeat each number
#' @param numOfPeriods Number of periods
#'
#' @return Vector filled with repeating 1, 2, 3...
#' @export
buildPeriodVector <- function(periodLength, numOfPeriods) {

v <- numeric()

for (j in 1:numOfPeriods) {
for (i in 1:periodLength) {
v <- append(v, j)
}
}

return (v)

}

#' Aggregate data of data frame summing up given periods
#'
#' @param data Given data frame
#' @param periodLength Length of period
#'
#' @return Aggregated data frame
#' @export
sumPeriod <- function(data, periodLength) {

numOfPeriods <- trunc(length(data[,1]) / periodLength)
v <- buildPeriodVector(periodLength, numOfPeriods)

data <- head(data, periodLength * numOfPeriods)
data <- aggregate(data, list(v), sum)
data <- subset(data, select = -Group.1)

return (data)

}

#' Chart nice histogram
#'
#' @param v Data vector
#' @param numOfBars Number of bars
#' @param color Color of histogram
#' @param xlab Label of x
#' @param main Title
#'
#' @return Histogram
#' @export
chartHist <- function(v, numOfBars = 50, color = rgb(0,0,1,1/2),
xlab = deparse(substitute(v)),
main = "Frequency") {

histBreakStep <- (max(v) - min(v))/ numOfBars
breaks <- seq(min(v) - histBreakStep, max(v) + histBreakStep, histBreakStep)
hist(v, col = color, breaks = breaks, xlab = xlab, main = main)

}

#' Make a function of two arguments take a vector as a second argument
#'
#' @param f Function
#' @param k First argument as a constant
#' @param v Second argument as a vector
#'
#' @return Vector of outputs
#' @export
KV <- function(f, k, v) {

l <- length(v)
y <- numeric(l)

for (i in 1:l) {
y[i] <- f(k, v[i])
}

return (y)

}

#' Make a function of three arguments take vectors as a second and third arguments
#'
#' @param f Function
#' @param k First argument as a constant
#' @param v1 Second argument as a vector
#' @param v2 Third argument as a vector
#'
#' @return Vector of outputs
#' @export
KVV <- function(f, k, v1, v2) {

l <- length(v1)
y <- numeric(l)

for (i in 1:l) {
y[i] <- f(k, v1[i], v2[i])
}

return (y)

}

#' Make a function of four arguments take vectors as a second, third and fourth arguments
#'
#' @param f Function
#' @param k First argument as a constant
#' @param v1 Second argument as a vector
#' @param v2 Third argument as a vector
#' @param v3 Fourth argument as a vector
#'
#' @return Vector of outputs
#' @export
KVVV <- function(f, k, v1, v2, v3) {

l <- length(v1)
y <- numeric(l)

for (i in 1:l) {
y[i] <- f(k, v1[i], v2[i], v3[i])
}

return (y)

}

#' Make a function of four arguments take a vector as a fourth argument
#'
#' @param f Function
#' @param k First argument as a constant
#' @param v1 Second argument as a constant
#' @param v2 Third argument as a constant
#' @param v3 Fourth argument as a vector
#'
#' @return Vector of outputs
#' @export
KKKV <- function(f, k1, k2, k3, v) {

l <- length(v)
y <- numeric(l)

for (i in 1:l) {
y[i] <- f(k1, k2, k3, v[i])
}

return (y)

}

#' Common switch that takes expression as vector (helper.R)
#'
#' @param expression Expression vector
#' @param ... Cases and results. Results must be same class
#'
#' @return Result of case that matches expression[i]
#' @export
#'
#' @examples
#' vectorSwitch(c("a","c"), a = 1, b = 2, c = 3, 4)
#'
vectorSwitch <- function(expression, ...) {

result <- NA
class(result) <- class(list(...)[[1]])

for (i in 1:length(expression))
result[i] <- switch(expression[i], ...)

return (result)

}

#' Switch that takes expression and results as vectors (helper.R)
#'
#' @param expression Expression vector
#' @param ... Cases and vectors of results. Results must be same class
#'
#' @return Result[i] of case that matches expression[i]
#' @export
#'
#' @examples
#' matrixSwitch(c("a","b","c"), a = 1:3, b = 11:13, c = 101:103, NA)
#'
matrixSwitch <- function(expression, ...) {

result <- NA
class(result) <- class(list(...)[[1]])

for (i in 1:length(expression))
result[i] <- switch(expression[i], ...)[i]

return (result)

}

#' Return vector of lengths of list elements
#'
#' @param l List
#' @param atoms Vector of class names that lengths are assumed to be 1
#'
#' @return Vector of lengths
#' @export
getLengths <- function(l, atoms = c("atom")) {

lens <- numeric()

for (i in 1:length(l)) {
if (any(class(l[[i]]) == atoms)) {
lens[i] <- 1
} else {
lens[i] <- length(l[[i]])
}
}

return (lens)

}

#' Check that all params have length = 1 or same length > 1
#'
#' @param ... Any number of atoms, vectors, lists
#' @param atoms Vector of class names that lengths are assumed to be 1
#'
#' @return Maximum length of params
#' @export
getLength <- function(..., atoms = c("atom")) {

lens <- getLengths(list(...), atoms)
maxLen <- max(lens)

if (!all(lens == 1 | lens == maxLen))
stop("ERROR! Vector length mismatch\n")

return (maxLen)

}

#' Return element "i" of "a" assuming that "a" has infinite tail filled with its last element
#'
#' @param a Any atom, vector, list
#' @param i Index of value
#' @param atoms Vector of class names that cannot be broken apart by index referencing
#'
#' @return Value with index i
#' @export
getByIndex <- function(a, i, atoms = c("atom")) {

if (any(class(a) == atoms)) {

b <- a

} else {

len <- length(a)

if (i <= len)
b <- a[[i]]
else
b <- a[[len]]

}

return (b)

}

#' Return attribute of object
#'
#' @param obj Object or list of objects
#' @param attrName Attribute name as character
#'
#' @return Attribute of object
#' @export
getAttribute <- function(obj, attrName) {

if (is.atomic(obj)) {

a <- NA

} else {

if (class(obj) != "list") {

a <- obj[[attrName]]
if (is.null(a)) a <- NA

} else {

a <- list()
len <- length(obj)

for (i in 1:len) {
a[[i]] <- obj[[i]][[attrName]]
if (is.null(a[[i]])) a[[i]] <- NA
}

if (is.atomic(a[[1]])) a <- do.call("c", a)

}

}

return (a)

}

#' Apply function to arguments
#'
#' @param fun Function name
#' @param ... Argumetns
#' @param atoms Vector of class names that cannot be broken apart by index referencing
#'
#' @return Function's result
#' @export
applyFun <- function(fun, ..., atoms = c("atom")) {

result <- list()

len <- getLength(..., atoms = atoms)

params <- list(...)

for (i in 1:len) {

localParams <- list()

for (j in 1:length(params)) {
localParams[[j]] <- getByIndex(params[[j]], i, atoms)
}

result[[i]] <- do.call(fun, localParams)

}

if (all(mapply(is.atomic, result))) result <- mapply(c, result)

return (result)

}
```
solavrov/hlpr documentation built on Nov. 23, 2017, 10:58 p.m.