## Do not edit this file manually.
## It has been automatically generated from *.org sources.
ragged2char <- function(raglist, filler = NA_character_){
p <- sapply(raglist, length)
pmax <- max(p)
mat <- sapply(raglist, function(x) c(x, rep(0, max(0,pmax-length(x)))))
mat <- if(pmax ==1) matrix(mat, ncol = 1)
else t(mat)
mat <- apply(mat, 2, function(x) format(x, width = 3))
for(i in seq_along(raglist))
if(p[i] < pmax)
mat[i, (p[i]+1):pmax] <- filler # 2012-11-03 was: NA_character_
mat
}
setClass("raggedCoef",
slots = c(a = "list", p = "numeric"),
validity = function(object){ # the current validity check is very basic.
if(length(object@a) != length(object@p))
"slot `p' should have the same length as slot `a'"
else
TRUE
}
)
setMethod("show", "raggedCoef",
function(object) {
cl <- class(object)
p <- max(object@p)
cat("An object of class \"", cl, "\"\n", sep = "")
cat("Number of rows:", length(object@p), "\n")
cat("Components' lengths:", object@p, "\n")
cat("\n")
if(p > 0){
mcoef <- ragged2char(object@a)
rownames(mcoef) <- paste("Component_", 1:nrow(mcoef), sep = "")
colnames(mcoef) <- paste("co_", seq_len(p), sep = "")
print(mcoef, na.print = "", quote = FALSE)
cat("\n")
## 2018-11-03 commenting out, was:
## str(object)
}else
cat("All components are of length 0.\n")
invisible(object)
})
.init_warn <- "When the coef are in a list, other arguments are ignored."
.init_wrong_args <- "Wrong arguments for raggedCoef initialization."
## Ne slagam argumenti `a' i `p' ponezhe ako chovek reshi da dade imenuvani
## elementi za @a toy ne bi tryabvalo da se trevozhi, che imenata im mozhe
## da savpadat s vatreshni imena na slot-ove v raggedCoef.
##
## 2012-12-03 ako ima tochno dva argumenta i te sa "a" and "p"
## prosto gi izpolzvam, ponezhe ne e chubavo da ne mozhe da se
## sazdade obektat po negovite slotove.
## TODO: dokumentiray!
setMethod("initialize", "raggedCoef",
function(.Object, ...) {
wrk <- list(...)
nams <- names(wrk)
if(length(wrk) == 2 && !is.null(nams) && "a" %in% nams && "p" %in% nams){
.Object@a <- wrk[["a"]]
.Object@p <- wrk[["p"]]
# todo: check for validity?
}else if(length(wrk) > 0 && inherits(wrk[[1]], "list")){
.Object@a <- wrk[[1]]
if(length(wrk) >= 2)
warning(.init_warn)
}else{
numq <- sapply(wrk, is.numeric)
if(all(numq))
.Object@a <- wrk
else
stop(.init_wrong_args)
}
.Object@p <- if(length(.Object@a) > 0)
sapply(.Object@a, length)
else
numeric(0)
.Object
}
)
raggedCoef <- function(p, value = NA_real_){ # create raggedCoef objects
if(missing(value) && is.list(p))
return( new("raggedCoef", p) )
res <- if(is(value, "raggedCoef")){
value
}else if(is.list(value)){
new("raggedCoef", value)
}else if(length(value) == 1){
value <- lapply(p, function(x) rep(value, x))
new("raggedCoef", value)
}else{
one2n <- seq_len(sum(p))
wrk <- do.call("+", lapply(head(cumsum(p),-1), function(x) one2n > x))
value <- lapply(seq_along(p) - 1, function(x) value[wrk == x])
new("raggedCoef", value)
}
if(!missing(p) && !all(res@p == p))
stop("The value of raggedCoef does not match the order.")
res
}
setMethod("[[", signature(x = "raggedCoef",i = "ANY",j = "missing"), # "[["
function(x, i, j, ...) {
x@a[[i,...]]
})
setMethod("[[", signature(x = "raggedCoef"),
function(x, i, j) {
# 2012-11-03 was: x@a[[i,j,...]] - tova vinagi dava greshka (may)! this
# operation makes sense for taking a single element.
x@a[[i]][[j]]
})
## todo: Mozhe da ima nuzhda ot fuktsiya podobna na "[", no zapalvasta strukturnite nuli s NA.
## Tova e nay-dobre da stane kato dobavya dopalnitelen argument tuk,
## no za tazi tsel tryabva da proucha dali tova e dopustimo.
## Here, by definition the methods for "[" treat the ragged array as a matrix,
## so the behaviour should replicate that for "matrix". (or should it?)
##
## Exception Initially I thought it a good idea to make calls with `i' only, like x[2] or
## x[1:2], equivalent to x[2,] and x[1:2,]. Then I abandoned this idea.
## Eventually I made x[2,] and x[2] equivalent since the trouble of making them
## behave differently seemed not worth the effort (see the comments in the method
## with j missing).
##
## Further to the above, there is a difference between x[[2]] and x[2,]. Both choose the
## second component but `[[' extracts it with its natural length, while `[' pads it with
## zeroes to the longest component in the object.
##
setMethod("[", signature(x = "raggedCoef",i = "missing",j = "missing"), # "[", []
function(x, i, j, ..., drop) {
nr <- length(x@p)
nc <- max(0,x@p) ## 0 avoids getting -Inf if x@p is of length 0.
res <- matrix(rep(0,nr*nc), nrow = nr, ncol = nc) # use of rep() is paranoic,
# to cater for the case nr=0 and nc=0
for(k in seq_len(nr)){
r <- x@a[[k]]
res[k,seq_along(r)] <- r ## dali raboti ako p[k]==0? todo: Check !!!
}
res
})
setMethod("[", signature(x = "raggedCoef",i = "numeric",j = "missing"),
function(x, i, j, ..., drop) { # x[2] and x[2,] both are dispatched by this method
# since j is `missing' but nargs() is different.
# cat("nargs:", nargs(),"\n"); print(missing(j))
# So, to implement different behaviour for these cases I
# need to check here nargs() as well, not worth the trouble.
# x[][i, ..., drop=drop]
# todo: check !!! ako `...' e prazen i drop e missing, dali call-at e
# ekvivalenten na [i] ili [i,]? Otgovor: [i] pri vsyako polozhenie!
## todo: A function arg_implied() may be of interest here since similar
## problems arise in other situations of this sort.
x[][i, , ..., drop = drop] # tozi variant e ako iskam x[i] da e kato x[i,]
})
setMethod("[", signature(x = "raggedCoef", i = "missing", j = "numeric"),
function(x, i, j, ..., drop) {
x[][ ,j, ..., drop = drop]
})
setMethod("[", signature(x = "raggedCoef",i = "numeric",j = "numeric"),
function(x, i, j, ..., drop) {
x[][i,j, ..., drop = drop]
})
# 2012-11-03 dobavyam assignment methods
# todo: "ANY" in the methods below should really
# be "numeric" or more carefully specified.
# "[[<-"
setReplaceMethod("[[", signature(x = "raggedCoef",i = "ANY",j = "missing", value = "numeric"),
function(x, i, value) {
if(length(value) != x@p[i])
stop("Replacement value must have the same length as the current value.")
x@a[[i]] <- value
x
})
setReplaceMethod("[[", signature(x = "raggedCoef",i = "ANY",j = "ANY", value = "numeric"),
function(x, i, j, value) {
x@a[[c(i,j)]] <- value # x@a[[i]][[j]] <- value
x
})
setReplaceMethod("[", signature(x = "raggedCoef",i = "ANY",j = "ANY", value = "numeric"),
function(x, i, j, value) {
x@a[[c(i,j)]] <- value # x@a[[i]][[j]] <- value
x
})
# "[<-"
setReplaceMethod("[", signature(x = "raggedCoef",i = "ANY",j = "missing", value = "list"),
function(x, i, value) {
if(!all(x@p[i] == sapply(value, length)))
stop("The length of raggedCoef objects cannot be changed by replacement.")
for(r in seq_along(i))
x@a[[ i[r] ]] <- value[[r]]
x
})
setReplaceMethod("[", signature(x = "raggedCoef",i = "ANY", j = "missing", value = "matrix"),
function(x, i, value) {
p <- x@p
if(ncol(value) < max(p[i]))
stop("Right-hand side must have at least max(x@p[i]) columns.")
for(r in seq_along(i))
x@a[[ i[r] ]] <- value[i[r], seq_len(p[i[r]])] # 2020-03-28 was: ... value[i, ...
x
})
setReplaceMethod("[", signature(x = "raggedCoef",i = "ANY",j = "missing", value = "numeric"),
function(x, i, value) { # here i should be of length one.
p <- x@p
if(length(value) < p[i])
stop("Right-hand side must have at least p[i] elements.")
x@a[[ i ]] <- value[seq_len(p[i])]
x
})
setReplaceMethod("[", signature(x = "raggedCoef",i = "missing",j = "missing", value = "list"), # []
function(x, value) {
if(!all(x@p == sapply(value, length)))
stop("Replacement value should be consistent with the current one.")
x@a <- value
x
})
setReplaceMethod("[", signature(x = "raggedCoef",i = "missing",j = "missing", value = "matrix"),# []
function(x, value) {
p <- x@p
if(ncol(value) < max(p))
stop("Right-hand side must have at least max(p) columns.")
for(k in seq_along(p))
x@a[[k]] <- value[k, seq_len(p[k])]
x
})
setReplaceMethod("[", signature(x = "raggedCoef",i = "missing",j = "missing", value = "numeric"),#[]
function(x, value) {
if(length(value) != sum(x@p))
stop("Wrong length of right-hand side.")
rag_modify(x,value)
})
## TOOD: ensure that the results are integer (max(x@p) for dim()
setMethod("length", signature(x = "raggedCoef"), function(x) sum(x@p))
setMethod("dim", signature(x = "raggedCoef"), function(x) c(length(x@a), max(x@p)) )
## setMethod("dimnames", signature(x = "raggedCoef"), function(x) ???)
setMethod("anyNA", signature(x = "raggedCoef"), function(x) anyNA(x@a, recursive = TRUE))
# 2012-11-03 rename from ragvec to ragged2vec
ragged2vec <- function(x){ # return the ragged coefficients as a vector (a "flatten" op.)
do.call("c",x@a) # todo: better is(?) unlist(x@a)
}
rag_modify <- function(rag,v){ ## modify the coefficients using a vector
wrk <- rag@a ## (barza krapka, nuzhdae se ot po-dobro obmislyane)
p <- rag@p
index <- 0
for(i in seq_along(p)){ # 2011-07-11 # todo:
wrk[[i]] <- v[index + seq_len(p[i])] # c(1,cumsum(p))
index <- index + p[i] # use relist() ?
} # vhz. sasto okolo one2n in raggedCoef()
rag@a <- wrk
rag
}
# todo: dali da machna row_lengths?
row_lengths <- function(x){ ## basically, x is a list here.
## 2020-03-28 was: sapply(x,length)
lengths(x)
}
setGeneric("row_lengths")
setMethod("row_lengths", signature(x = "raggedCoef"),
function(x){
x@p
})
## 2012-11-03 macham; nikoga ne e izpolzvana + trudno ime.
## row_maxlength <- function(x){ ## should work whenever row_lengths is sensible.
## max(row_lengths(x))
## }
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.