## Do not edit this file manually.
## It has been automatically generated from *.org sources.
setClass("MixComp",
representation(m = "matrix" ## numeric?
), ## prototype, validity, access, where, version, sealed, package,
)
## Currently, the methods assume that each column of `m' represents values for one component
## external functions should not use it, as I may change the internal representation.
#
# todo: write methods that return colwise or rowwise matrix.
#
# Group op may be usable but rhere is a difference here in the natural meaning of the
# multiplicative ops (*,/) and the additive ones (+,-).
#
# todo: Still, maybe could use ops with one of the meanings and define exceptions
# individually.
setGeneric("mix_ncomp",
function(x)
standardGeneric("mix_ncomp"),
useAsDefault = FALSE)
setMethod("mix_ncomp", signature(x = "MixComp"),
function(x){
ncol(x@m)
})
setMethod("Math", # 2012-11-09 new;
signature(x = "MixComp"),
function (x)
{
callGeneric(x@m)
}
)
setMethod("-", signature(e1 = "MixComp", e2 = "missing"), # 2012-11-09 new; unary "-"
function(e1, e2) {
wrk <- - e1@m
new("MixComp", m = wrk)
})
setMethod("dim", signature(x = "MixComp"),
function(x) dim(x@m), valueClass = "integer")
setMethod("-", signature(e1 = "numeric", e2 = "MixComp"),
function(e1, e2) {
mc <- e2@m
## 2020-04-22 was: nrow(mc==1) - but that was certainly not the intent
if(nrow(mc) == 1) ## special case
wrk <- e1 - matrix( rep(mc, length(e1)), ncol = ncol(mc), byrow = TRUE)
else
wrk <- e1 - e2@m # relies on the recycling rule
new("MixComp", m = wrk)
})
setMethod("-", signature(e1 = "MixComp", e2 = "numeric"),
function(e1, e2) {
wrk <- e1@m - e2 # relies on the recycling rule
new("MixComp", m = wrk)
})
setMethod("+", signature(e1 = "numeric", e2 = "MixComp"),
function(e1, e2) {
wrk <- e1 + e2@m # relies on the recycling rule
new("MixComp", m = wrk)
})
setMethod("+", signature(e1 = "MixComp", e2 = "numeric"),
function(e1, e2) {
wrk <- e1@m + e2 # relies on the recycling rule
new("MixComp", m = wrk)
})
setMethod("*", signature(e1 = "MixComp", e2 = "numeric"),
function(e1, e2) {
wrk <- t( t(e1@m) * e2 ) # relies on the recycling rule
new("MixComp", m = wrk)
})
setMethod("*", signature(e1 = "numeric", e2 = "MixComp"),
function(e1, e2) {
wrk <- t( e1 * t(e2@m) ) # relies on the recycling rule
new("MixComp", m = wrk)
})
setMethod("*", signature(e1 = "MixComp", e2 = "MixComp"), # 2011-07-20 new! todo: +,-,/
function(e1, e2) {
wrk <- e1@m * e2@m
new("MixComp", m = wrk)
})
setMethod("/", signature(e1 = "MixComp", e2 = "numeric"),
function(e1, e2) {
wrk <- t( t(e1@m) / e2 ) # relies on the recycling rule
new("MixComp", m = wrk)
})
setMethod("/", signature(e1 = "numeric", e2 = "MixComp"),
function(e1, e2) {
wrk <- t( e1 / t(e2@m) ) # relies on the recycling rule
new("MixComp", m = wrk)
})
setMethod("^",
signature(e1 = "MixComp", e2 = "numeric"),
function (e1, e2)
{
wrk <- e1@m ^ e2 # relies on the recycling rule
new("MixComp", m = wrk)
}
)
setMethod("*", signature(e1 = "function", e2 = "MixComp"),
function(e1, e2) {
wrk <- apply(e2@m, 1:2, e1)
new("MixComp", m = wrk)
})
setMethod("*", signature(e1 = "character", e2 = "MixComp"), ## e1 = names of functions
function(e1, e2) {
if(length(e1)==1){
fchar <- e1
fun <- match.fun(fchar)
wrk <- apply(e2@m, 1:2, fun)
}else{
wrk <- matrix(0, nrow = nrow(e2@m), ncol = ncol(e2@m))
for(i in seq_len(ncol(e2@m))){
fchar <- e1[i]
fun <- match.fun(fchar)
wrk[, i] <- do.call(fun, list(e2@m[, i]))
}
}
new("MixComp", m = wrk)
})
"%of%" <- function(e1, e2) apply(e2, 1:2, e1) ## e1 is function or name of one.
setGeneric("%of%")
# if do.call is used, then the function can be a string or the function itself,
# but it needs to be vectorised (which is the case for pdfs, cdfs, etc.).
#
setMethod("%of%", signature(e1 = "function", e2 = "MixComp"),
function(e1, e2) {
wrk <- apply(e2@m, 1:2, e1) # todo: change to: wrk <- e1(e2@m) !!!
new("MixComp", m = wrk)
})
setMethod("%of%", signature(e1 = "character", e2 = "MixComp"), ## e1 = names of functions
function(e1, e2) {
if(length(e1) == 1)
wrk <- apply(e2@m, 1:2, e1) ## or, todo:(?) do.call(e1, list(e2@m))
else{
wrk <- matrix(0, nrow = nrow(e2@m), ncol = ncol(e2@m))
for(i in seq_len(ncol(e2@m))){
# this does not work: wrk[, i] <- apply(e2@m[, i], 1:2, e1[i])
fchar <- e1[i]
fun <- match.fun(fchar)
wrk[, i] <- do.call(fun, list(e2@m[, i]))
}
}
new("MixComp", m = wrk)
})
setMethod("%of%", signature(e1 = "list", e2 = "MixComp"), ## e1 = names of functions
function(e1, e2) {
if(length(e1)==1)
wrk <- apply(e2@m, 1:2, e1[[1]]) ## or, todo:(?) do.call(e1, list(e2@m))
else{
wrk <- matrix(0, nrow = nrow(e2@m), ncol = ncol(e2@m))
for(i in seq_len(ncol(e2@m)))
# this does not work: wrk[, i] <- apply(e2@m[, i], 1:2, e1[i])
wrk[, i] <- do.call(e1[[i]], list(e2@m[, i]))
}
new("MixComp", m = wrk)
})
.mplus <- function(...){ # note: do.call("+", wrk) will not do since "+" is binary operator
# 2017-05-02: edited
# res <- 0 # todo: replace with apply(cbind(...), 1, sum) ?
# for(cur in list(...)) # note: recycling will occur if lengths are different.
# res <- res + cur # todo: maybe insert zeroes? Any of the two (res & cur)
# res # may be longer at a given moment.
wrk <- list(...)
if(length(wrk) == 0)
0
else{
res <- wrk[[1]]
for(cur in wrk[-1])
res <- res + cur
res
}
}
inner <- function(x, y, star = "*", plus = .mplus){
stopifnot(length(x) == length(y)) # new 2017-05-02
star <- match.fun(star)
plus <- match.fun(plus)
wrk <- vector("list", length = length(x))
for(i in seq_along(x))
wrk[[i]] <- star(x[[i]], y[[i]])
do.call(plus, wrk)
}
setGeneric("inner")
setMethod("inner", signature(x = "MixComp", y = "missing" , star = "missing", plus = "missing"),
function(x){
rowSums(x@m)
})
## todo: define also as %*%?
setMethod("inner", signature(x = "MixComp", y = "numeric" , star = "missing", plus = "missing"),
function(x, y){
drop(x@m %*% y) # note that `drop', returns a vector.
})
setMethod("inner", signature(x = "numeric", y = "MixComp", star = "missing", plus = "missing"),
function(x, y){
drop(x %*% y@m)
})
setMethod("inner", signature(x = "MixComp", y = "numeric" , star = "ANY", plus = "missing"),
function(x, y, star){
star <- match.fun(star)
wrk <- x@m
for(j in 1:ncol(wrk)){
b <- y[j]
wrk[, j] <- sapply(wrk[, j], star, b)
}
rowSums(wrk)
})
setMethod("inner", signature(x = "MixComp", y = "numeric" , star = "ANY", plus = "ANY"),
function(x, y, star, plus){
star <- match.fun(star)
wrk <- x@m
for(j in 1:ncol(wrk)){
b <- y[j]
wrk[, j] <- sapply(wrk[, j], star, b)
}
if(identical(plus, "+")) # todo: give warning here?
plus <- sum # todo: ili da slozha tova v generic?
apply(wrk, 1, plus)
})
mixFilter <- function(x, coef, index, shift = 0, residual = FALSE, scale = 1){ ## todo: check the defaults!
stop("Bosh: no default method for `mixFilter'")
}
setGeneric("mixFilter")
setMethod("mixFilter", signature(x = "numeric", coef = "raggedCoef", index = "numeric"),
function(x, coef, index, shift = 0, residual = FALSE, scale = 1){
## Za shift razchita, che se retsiklira ako ne e vector.
## wrk <- mapply(raghat1, coef@a, shift=shift, MoreArgs=list(x=x, index=index))
# rezultatat se oachakva da e po edna kolonka za vsyaka komponenta.
# Note: coef@a is a list and `mapply' sends its elements wrapped in `list()'
# (zatova slagam krapka v `raghat1')
## Ne, `mapply' ne varshi rabota - ne map-va coef@a a go predava kato edno
## tsyalo!
## krapka, todo: opravi!
k <- length(coef@a)
if(length(shift)==1)
shift <- rep(shift, k)
if(length(scale)==1)
scale <- rep(scale, k)
i <- 0
for(flt in coef@a){
i <- i + 1
#cat("i =", i, ", flt = ", flt, "\n")
y <- raghat1(flt, x, index, shift[i], residual, scale[i])
#cat("y =", y, "\n\n")
if(i==1)
wrk <- y
else
wrk <- cbind(wrk, y)
}
new("MixComp", m = wrk)
})
# 1st arg. is filter for use in sapply()
raghat1 <- function(filter, x, index, shift = 0, residual = FALSE, scale = 1){
if(is.list(filter)) ## krapka, vzh. komentara pri mixFilter. todo: izchisti!
filter <- filter[[1]]
res <- rep(shift, length(index))
for(i in seq_along(filter)){ # expression x[index-i] assumes there are
res <- res + filter[i]*x[index-i] # enough past x's for all elements of index.
}
if(residual)
res <- x[index] - res
if(scale != 1) # probably meaningful only when residual=TRUE
res <- res/scale
## todo: kakto e tragnalo moga da dobavya i argument za cdf, etc.
#browser()
res
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.