#' Infix operations on vectors - append, diff, intersection, union, replication
#'
#' All these functions except \code{\%n_d\%}, \code{\%n_i\%} preserve names of
#' vectors and don't remove duplicates.
#' \itemize{
#' \item{\code{\%a\%}}{ a(ppends) second argument to the first argument. See also
#' \link[base]{append}.}
#' \item{\code{\%u\%} and \code{v_union}}{ u(nite) first and second arguments.
#' Remove elements from the second argument which exist in the first argument. }
#' \item{\code{\%d\%} and \code{v_diff}}{ d(iff) second argument from the first
#' argument. Second argument could be a function which returns logical value. In
#' this case elements of the first argument which give TRUE will be removed. }
#' \item{\code{\%i\%} and \code{v_intersect}}{ i(ntersect) first argument and
#' second argument. Second argument could be a function which returns logical
#' value. In this case elements of the first argument which give FALSE will be
#' removed. }
#' \item{\code{\%e\%} and \code{v_xor}}{ e(xclusive OR). Returns elements that
#' contained only in one of arguments.}
#' \item{\code{\%r\%} }{ r(epeats) first argument second argument times. See
#' also \link[base]{rep}.}
#' \item{\code{\%n_d\%} and \code{n_diff}}{ n(ames) d(iff) - diff second argument
#' from names of first argument. Second argument could be a function which
#' returns logical value. In this case elements of the first argument which names
#' give TRUE will be removed. }
#' \item{\code{\%n_i\%} and \code{n_intersect}}{ n(ames) i(ntersect) - intersect
#' names of the first argument with the second argument. Second argument could be a
#' function which returns logical value. In this case elements of the first argument
#' which names give FALSE will be removed. }
#' }
#' For \code{\%d\%}, \code{\%i\%}, \code{\%n_d\%}, \code{\%n_i\%} one can use
#' criteria functions. See \link{criteria} for details.
#'
#' @param e1 vector or data.frame, matrix, list for \code{\%n_d\%}, \code{\%n_i\%})
#' @param e2 vector or function for \code{\%d\%}, \code{\%i\%}
#'
#' @name vectors
#' @return vector or data.frame, matrix, list for \code{\%n_d\%}, \code{\%n_i\%})
#'
#' @examples
#'
#' 1:4 %a% 5:6 # 1:6
#'
#' 1:4 %a% 4:5 # 1,2,3,4,4,5
#'
#' 1:4 %u% 4:5 # 1,2,3,4,5
#'
#' 1:6 %d% 5:6 # 1:4
#'
#' # function as criterion
#' 1:6 %d% greater(4) # 1:4
#'
#' 1:4 %i% 4:5 # 4
#'
#' # with criteria functions
#' letters %i% (contains("a") | contains("z")) # a, z
#'
#' letters %i% perl("[a-d]") # a,b,c,d
#'
#' 1:4 %e% 4:5 # 1, 2, 3, 5
#'
#' 1:2 %r% 2 # 1, 2, 1, 2
#'
#' # %n_i%, %n_d%
#'
#' # remove column Species
#' iris %n_d% "Species"
#'
#' # leave only columns which names start with "Sepal"
#' iris %n_i% like("Sepal*")
#'
#' # leave column "Species" and columns which names start with "Sepal"
#' iris %n_i% ("Species" | like("Sepal*"))
#' iris %n_i% or("Species", like("Sepal*")) # same result
#'
#' @export
'%a%' = function(e1, e2){
append(e1, e2)
}
#' @export
#' @rdname vectors
v_union = function(e1, e2){
if(is.null(e1)) return(e2)
c(e1, e2[!(e2 %in% e1)])
}
#' @export
#' @rdname vectors
'%u%' = v_union
#' @export
#' @rdname vectors
v_diff = function(e1, e2){
UseMethod("v_diff")
}
#' @export
v_diff.default = function(e1, e2){
if(is.null(e2)) return(e1)
if (is.function(e2)){
crit = e2(e1)
crit = !(crit & !is.na(crit))
e1[crit]
} else {
e1[!(e1 %in% e2)]
}
}
#' @export
v_diff.list = function(e1, e2){
if(is.null(e2)) return(e1)
stopif(!is.function(e2), "For lists 'e2' should be function.")
crit = vapply(e1, FUN = e2, FUN.VALUE = logical(1))
crit = !(crit & !is.na(crit))
if(is.data.table(e1)){
e1[,crit, with = FALSE]
} else {
e1[crit]
}
}
#' @export
v_diff.data.frame = v_diff.list
#' @export
#' @rdname vectors
'%d%' = v_diff
#' @export
#' @rdname vectors
v_intersect = function(e1, e2){
UseMethod("v_intersect")
}
#' @export
v_intersect.default = function(e1, e2){
if (is.function(e2)){
crit = e2(e1)
crit = crit & !is.na(crit)
e1[crit]
} else {
e1[e1 %in% e2]
}
}
#' @export
v_intersect.list = function(e1, e2){
if(is.null(e2)) return(e1[FALSE])
stopif(!is.function(e2), "For lists 'e2' should be function.")
crit = vapply(e1, FUN = e2, FUN.VALUE = logical(1))
crit = crit & !is.na(crit)
if(is.data.table(e1)){
e1[,crit, with = FALSE]
} else {
e1[crit]
}
}
#' @export
v_intersect.data.frame = v_intersect.list
#' @export
#' @rdname vectors
'%i%' = v_intersect
#' @export
#' @rdname vectors
v_xor = function(e1, e2){
if(is.null(e1)) return(e2)
c(e1[!(e1 %in% e2)],e2[!(e2 %in% e1)])
}
#' @export
#' @rdname vectors
'%e%' = v_xor
#' @export
#' @rdname vectors
'%r%' = function(e1, e2){
if(length(e2)==1){
rep(e1, e2)
} else {
stop("Multiplicator 'e2' should be scalar quantity (vector of length 1).")
}
}
#' @export
#' @rdname vectors
n_intersect = function(e1, e2){
UseMethod("n_intersect")
}
#' @export
n_intersect.default = function(e1, e2){
# names %in% .... for duplicated names
e1[names(e1) %in% (names(e1) %i% e2)]
}
#' @export
n_intersect.data.frame = function(e1, e2){
e1[ , names(e1) %in% (names(e1) %i% e2), drop = FALSE]
}
#' @export
n_intersect.data.table = function(e1, e2){
e1[ , names(e1) %in% (names(e1) %i% e2), with = FALSE]
}
#' @export
n_intersect.matrix = function(e1, e2){
e1[ , colnames(e1) %in% (colnames(e1) %i% e2), drop = FALSE]
}
#' @export
#' @rdname vectors
'%n_i%' = n_intersect
#' @export
#' @rdname vectors
n_diff = function(e1, e2){
if(length(e2)==0) return(e1)
UseMethod("n_diff")
}
#' @export
n_diff.default = function(e1, e2){
e1[names(e1) %in% (names(e1) %d% e2)]
}
#' @export
n_diff.data.frame = function(e1, e2){
e1[ , names(e1) %in% (names(e1) %d% e2), drop = FALSE]
}
#' @export
n_diff.data.table = function(e1, e2){
e1[ , names(e1) %in% (names(e1) %d% e2), with = FALSE]
}
#' @export
n_diff.matrix = function(e1, e2){
e1[ , colnames(e1) %in% (colnames(e1) %d% e2), drop = FALSE]
}
#' @export
#' @rdname vectors
'%n_d%' = n_diff
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.