Skip to content

Instantly share code, notes, and snippets.

@wdkrnls
Last active November 4, 2017 19:19
Show Gist options
  • Save wdkrnls/5ceceacec59d539dabf70fbea5ba314e to your computer and use it in GitHub Desktop.
Save wdkrnls/5ceceacec59d539dabf70fbea5ba314e to your computer and use it in GitHub Desktop.
make polynomial function
# 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))
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment