methods and tests for simulate-formula methods

simulate_formula.R

simulate.formula <- function(object, nsim=1, seed=NULL, ...) {

    ## utility fun for generating new class
    cfun <- function(cc) {
        c(paste0("formula_lhs_", cc), "formula_lhs", class(object))
    }

    if(length(object)==3) {  ## two-sided formula
        lhs <- object[[2L]]
        .Basis <-  try(eval(lhs, envir=environment(object),
                            enclos=parent.frame()), silent=TRUE)
        if (inherits(.Basis,"try-error")) {
            ## can't evaluate LHS: either a mistake, or
            ##  a weird environment chain, or a symbol without a referent?
            attr(object, ".Basis") <- lhs
            class(object) <- cfun(class(lhs)[1])
        } else {
            attr(object,".Basis") <- .Basis
            ## take only *first* element of .Basis class
            class(object) <- cfun(class(.Basis)[1])
        }
    } else {  ## one-sided
        class(object) <- cfun("")
    }
    UseMethod("simulate", object)
}

## factory for making methods
mk_method <- function(class, print_dims=FALSE) {
    method <- sprintf("simulate.formula_lhs_%s",class)
    sim_generic <- function(object, nsim=1, seed=NULL, ...) {
        message(sprintf("%s called",method))
        print(ls(all.names=TRUE))
        cat(".Basis from env:\n")
        try(print(.Basis))
        cat(".Basis from attributes:\n")
        print(attr(object,".Basis")) # NULL
        if (print_dims) {
            print(dim(.Basis))
        }
    }
    assign(method,sim_generic,.GlobalEnv)
    invisible(NULL)
}

## catch two-sided formulae ...
simulate.formula_lhs_name <- function(object, nsim=1, seed=NULL, ...) {
    warning("simulate() is intended for one-sided formulas")
    simulate.formula(object[-2])
}


mk_method("NULL")
mk_method("numeric")
mk_method("matrix",print_dims=TRUE)
mk_method("array",print_dims=TRUE)
mk_method("")
## mk_method("name")


## Test code:

simulate(1~.)
# One-sided formula is not the same as an LHS that evaluates to NULL:
simulate(NULL~.)
simulate(~.)

simulate(x~.)

# Multielement classes:
simulate(diag(5)~.)
simulate(array(1,c(2,2,2))~.)

## TEST recursion etc.

simulate.formula_lhs_matrix <- function(object, nsim=1, seed=NULL, ...){
  message("simulate.formula_lhs_matrix() called.")
  NextMethod()
}

simulate.formula_lhs_array <- function(object, nsim=1, seed=NULL, ...){
  message("simulate.formula_lhs_array() called.")
  print(ls(all.names=TRUE))
  try(dim(.Basis)) # Error: .Basis is not defined.
}

simulate(diag(5)~.)
simulate(array(1,c(2,2,2))~.)

simulate.formula_lhs_character <- function(object, nsim=1, seed=NULL, ...){
  message("simulate.formula_lhs_character() called.")
  print(ls(all.names=TRUE))
  NextMethod() # Calls simulate.formula(), resulting in an infinite recursion.
}

simulate("a"~.)

simulate(~y+z)