make polynomial function

polyfun.R

# Author: Kyle Andrews
# License: GPL3+
# Date: 2017-11-04
# Description: Make a higher order function that returns a function that returns a function for exploring polynomial equations.

#' Test if all elements in vector are unique.
#' @param x Vector.
#' @return Logical Scalar.
all_unique <- function(x) {
    length(x) == length(unique(x))
}


#' Produce list of vectors of all combinations of variables.
#' @param var Vector.
#' @return List of Vector.
combinations <- function(var) {
    stopifnot(all_unique(var))
    n  <- length(var)
    vc <- lapply(1:n, function(i) combn(var, i, simplify = FALSE))
    unlist(vc, recursive = FALSE)
}


#' Helper function to generate squared terms for variables.
power_terms <- function(var) {
    paste0("I(", var, "^2)")
}


#' Helper function to generate parameters for squared variables.
power_params <- function(param, psep = ".") {
    unlist(lapply(param, function(p) paste(rep(p, 2), collapse = psep)))
}
                 
                 
#' Make a polynomial function out of variable names.
#' @param var String variable names. Must be unique.
#' @param param String parameter names. Must be unique.
#' @param psep String Scalar separator for building higher order parameters out of main ones.
#' @return Function(params) -> Function(variables) -> Numeric
make_polynomial_function <- function(var, param = paste(var, "par", sep = "."), psep = ".") {
    stopifnot(all_unique(var))
    stopifnot(all_unique(param))
    trm <- unlist(lapply(combinations(var),   function(x) paste(x, collapse = "*")))
    prm <- unlist(lapply(combinations(param), function(x) paste(x, collapse = psep)))
    pp  <- power_params(param, psep)
    pv  <- paste(paste0(pp, "*", power_terms(var)), collapse = "+")
    pex <- paste(paste(prm, trm, sep = "*"), collapse = "+")
    pex <- paste(pex, pv, "icept", sep = "+")
    fex <- paste0("function(", paste(paste0(c(prm, pp, "icept"), "=0"), collapse = ", "), ") {\n  ",
                  "function(", paste(paste0(var, "=0"), collapse = ", "), ") {\n    ", pex, " \n  }\n}")
    eval(parse(text = fex))
}