internals.R 1.08 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54
make_subS3Class = function(obj,subclass) {
  class(obj) = c(paste(subclass,
                       collapse = "_"),
                 class(obj))
  return(obj)
}

dots.names=function(...) {
  varnames = substitute(list(...))[-1L]
  dots     = list(...)
  isname   = sapply(varnames,is.name)
  charname = as.character(varnames)
  charname[!isname]=""

  n=length(dots)

  explicit = names(dots)

  if (is.null(explicit))
    explicit=character(n)

  ze = !nzchar(explicit)

  explicit[ze]=charname[ze]
  ze = !nzchar(explicit)

  dnames <- paste('V',seq_len(n),sep='')
  explicit[ze]=dnames[ze]

  return(explicit)
}

make_procmod_subS3Class = function(obj,subclass) {
  class(obj) = c(paste("procmod",subclass,
                       sep="_",collapse = "_"),
                 class(obj))

  return(obj)
}

make_procmod_data = function(obj,subclass) {

  eud = inherits(obj,'procmod_data',which = TRUE)

  if (eud > 0)
    class(obj) = class(obj)[-1:-(eud-1)]
  else
    obj = make_procmod_subS3Class(obj,'data')

  if (! missing(subclass))
    obj = make_procmod_subS3Class(obj,subclass)

  return(obj)
}