I can construct a formula that does what I desire starting with the character versions of terms in a formula, but I'm stumbling in starting with a formula object:
form1 <- Y ~ A + B
form1[-c(1,2)][[1]]
#A + B
Now how to build a formula object that looks like:
Y ~ poly(A, 2) + poly(B, 2) + poly(C, 2)
Or:
Y ~ pspline(A, 4) + pspline(B, 4) + pspline(C, 4)
Seems that it might involve a recursive walk along the RHS but I'm not getting progress. It just occurred to me that I might use
> attr( terms(form1), "term.labels")
[1] "A" "B"
And then use the as.formula(character-expr) approach, but I's sorly of like to see an lapply (RHS_form, somefunc) version of a polyize (or perhaps polymer?) function.
If I borrow some functions I originally wrote here, you could do something like this. First, the helper functions...
extract_rhs_symbols <- function(x) {
as.list(attr(delete.response(terms(x)), "variables"))[-1]
}
symbols_to_formula <- function(x) {
as.call(list(quote(`~`), x))
}
sum_symbols <- function(...) {
Reduce(function(a,b) bquote(.(a)+.(b)), do.call(`c`, list(...), quote=T))
}
transform_terms <- function(x, f) {
symbols_to_formula(sum_symbols(sapply(extract_rhs_symbols(x), function(x) do.call("substitute",list(f, list(x=x))))))
}
And then you can use
update(form1, transform_terms(form1, quote(poly(x, 2))))
# Y ~ poly(A, 2) + poly(B, 2)
update(form1, transform_terms(form1, quote(pspline(x, 4))))
# Y ~ pspline(A, 4) + pspline(B, 4)
There's a formula.tools package that provides various utility functions for working with formulas.
f <- y ~ a + b
rhs(f) # a + b
x <- get.vars(rhs(f)) # "a" "b"
r <- paste(sprintf("poly(%s, 4)", x), collapse=" + ") # "poly(a, 4) + poly(b, 4)"
rhs(f) <- parse(text=r)[[1]]
f # y ~ poly(a, 4) + poly(b, 4)
Related
Given any formula object (e.g., f) below, I was wondering how I could separate tilda sign and everything after it and convert it into a formula object?
My desired output only in this example case is: ~ es.type+weeks as a formula object.
NOTE: f could be ANY formula, the above f is just an example. I'm looking for a general solution.
f <- formula(dint ~ es.type+weeks) # Only as an example
g <- paste0(f[[1]], f[[3]]) # No success
as.formula(g) # No success
You can just manipulate the formula directly:
f <- y ~ x1 + x2:x3
f[[2]] <- f[[3]]
f[[3]] <- NULL
identical(f, ~ x1 + x2:x3)
# TRUE
An option is to drop the terms based on the number of terms in the formula
g <- formula(drop.terms(terms(f), 3))
g
#~es.type + weeks
f1 <- formula(dint ~ es.type:weeks)
formula(drop.terms(terms(f1), 3))
#~es.type:weeks
It would be better to create a function to applied for different formulas
form1 <- function(form) {
i1 <- length(terms(form)) + 1
formula(drop.terms(terms(form), i1))
}
f1 <- formula(dint ~ es.type+weeks+dd)
f2 <- formula(dint ~ es.type+weeks)
form1(f1)
#~es.type + weeks + dd
form1(f2)
#~es.type + weeks
If we need to add a new term
update(form1(f2), ~time +.)
#~time + es.type + weeks
I am using R and trying to make an function by giving 2 parameters which are function and x, try to look for the answer of the function. But I kept getting error. I do not want to use any packages just solely R base.
Heres the Code so far.
test2 <- function(x) {
func <- expression(x)
der<- D(eval(func), 'x')
return(der(x))
}
test2(function(x) return(x^2))
I kept getting this error: "expression must not be type 'closure'"
Is there any way that I can structure of the function?
Here's a slight adjustment to get the derivation function working:
test2 <- function(x) D(parse(text=x), "x")
test2("sin(cos(x + y^2))")
# -(cos(cos(x + y^2)) * sin(x + y^2))
test2("x^2")
# 2 * x
test2("x^3")
# 3 * x^2
Use substitute to pass the expression to D:
test2 <- function(e, d) D(substitute(e), deparse(substitute(d)))
test2(sin(cos(x + y^2)), x)
#-(cos(cos(x + y^2)) * sin(x + y^2))
You cannot pass a function to D since it's designed for creating derivatives symbolically, which means it needs expressions containing simple functions known to D.
The function f returns a character vector, and string_der gives the derivative. (I used string manipulation inside since it seems you want to pass an argument.)
string_der <- function(x) {
D(parse(text = x), "x")
}
library(stringr)
f <- function(x) {
str <- "sin(cos(z + y^2))"
str <- str_replace(str, "z", x)
return(str)
}
string_der(f(x = "x"))
# -(cos(cos(x + y^2)) * sin(x + y^2))
I guess following is pretty much Adam Queck has done. It uses quote and let's you pass an object wrapped in quote.
quote_der <- function(x) {
D(eval(x), 'x')
}
f <- function(x) {
qt <- substitute(expression(sin(cos(z + y^2))), list(z = x))
return(qt)
}
quote_der(f(x = quote(x)))
#-(cos(cos(x + y^2)) * sin(x + y^2))
Assuming that:
the function passed as the argument has a one-line body and
if x is not specified it defaults to the name of the first argument to the input function
then we can write
test3 <- function(fun, x = names(formals(fun))[1]) D(body(fun), x)
test3(function(x) x^2)
## 2 * x
The Simple Request:
I'd like to take formulas/strings similar to the following:
"A ~ 1 + B + C + L(diff(B), -k:k) + L(diff(C), -k:k)"
and change them to treat functions as character as follows:
"A ~ 1 + B + C + `L(diff(B), -k:k)` + `L(diff(C), -k:k)`"
There may be any number of "L(diff(___), -____:____)" in a string.
The Background:
This is so that I may take the output models made with dynlm and run them with functions that rely on "lm" objects only.
# package
library(dynlm)
# data
A <- as.ts(rnorm(20, 10, 2))
B <- as.ts(A + rnorm(20, 6, 2))
C <- as.ts(rnorm(20, 3, 1))
# lags/leads
k <- 1
# dynlm model
dyn.mod <- dynlm(A ~ 1 + B + C + L(diff(B), -k:k) + L(diff(C), -k:k))
# capture the formula and data
dyn.mod.call <- gsub(" ", "", paste(deparse(dyn.mod$call$formula), collapse = "")) # just in case formula is too long
dyn.mod.model <- dyn.mod$model # the matrix that was created from the call formula
# Do the following
lm(dyn.mod.call, data = dyn.mod.model) # Will not run obviously,
lm(A ~ 1 + B + C + `L(diff(B), -k:k)` + `L(diff(C), -k:k)`, data = dyn.mod.model) # will run
# how do I change
dyn.mod.call
# [1] "A ~ 1 + B + C + L(diff(B), -k:k) + L(diff(C), -k:k)"
# to ad " ` " around each dynlm "L()" function so the process is not manual?
Thanks for your help.
Note that we don't really want to replace all function calls since + is a function (and even ~ can be regarded as a function) but we only want to replace just certain ones. Suppose that the only function call that we want to process is L. Modify the second if appropriately according to what it is that is to be matched. The function shown works recursively. No packages are used.
enquote_L <- function(x) {
if (length(x) == 1) return(x)
if (x[[1]] == as.name("L")) return(as.name(format(x)))
replace(x, -1, lapply(x[-1], enquote_L))
}
s <- "A ~ 1 + B + C + L(diff(B), -k:k) + L(diff(C), -k:k)"
enquote_L(as.formula(s))
## A ~ 1 + B + C + `L(diff(B), -k:k)` + `L(diff(C), -k:k)`
ADDED
If there were a variety of functions and + and ~ were the only ones not to be processed then a variation might be to replace the second if with:
if (x[[1]] != as.name("+") && x[[1]] != as.name("~")) return(as.name(format(x)))
You can use string manipulation to change the formula.
x <- deparse(A ~ 1 + B + C + L(diff(B), -k:k) + L(diff(C), -k:k))
parts <- unlist(strsplit(x, " \\+ "))
parts <- c(parts[1:3], paste0("`", parts[4:5], "`"))
as.formula(paste(parts, collapse = " + "))
I'm trying to adjust the names of an argument inside a function. I want to create a procedure that takes the body of a function, looks for x, changes every x into x0, and then restores the function to what it was before. To provide an example:
f = function(x, y) -x^2 + x + -y^2 + y
# Take old names
form_old = names(formals(f))
# Make new names
form_new = paste0(form_old, 0)
# Give f new formals
formals(f) = setNames(vector("list", length(form_new)), form_new)
# Copy function body
bod = as.list(body(f))
for (i in 1:length(form_new)) {
bod = gsub(form_old[i], form_new[i], bod)
}
# return from list to call ?
body(f) = as.call(list(bod))
f(1, 1) # produces an error
So far, this code will change all variable names from x to x0 and from y to y0. However, the final output of bod is a character vector and not a call. How can I now change this back to a call?
Thanks in advance!
Surely there is a better way to do what you are trying to do that doesn't require modifying functions. That being said, you definetly don't want to be replacing variables by regular expressions, that could have all sorts of problems. Generally, trying to manipulate code as strings is going to lead to problems, for example, a function like tricky <- function(x, y) { tst <- "x + y"; -xx*x + yy*y }, where there are strings and variable names overlap, will lead to the wrong results.
Here is a function that takes a recursive approach (Recall) to traverse the expression tree (recursion could be avoided using a 'stack' type structure, but it seems more difficult to me).
## Function to replace variables in function body
## expr is `body(f)`, keyvals is a lookup table for replacements
rep_vars <- function(expr, keyvals) {
if (!length(expr)) return()
for (i in seq_along(expr)) {
if (is.call(expr[[i]])) expr[[i]][-1L] <- Recall(expr[[i]][-1L], keyvals)
if (is.name(expr[[i]]) && deparse(expr[[i]]) %in% names(keyvals))
expr[[i]] <- as.name(keyvals[[deparse(expr[[i]])]])
}
return( expr )
}
## Test it
f <- function(x, y) -x^2 + x + -y^2 + y
newvals <- c('x'='x0', 'y'='y0') # named lookup vector
newbod <- rep_vars(body(f), newvals)
newbod
# -x0^2 + x0 + -y0^2 + y0
## Rename the formals, and update the body
formals(f) <- pairlist(x0=bquote(), y0=bquote())
body(f) <- newbod
## The new 'f'
f
# function (x0, y0)
# -x0^2 + x0 + -y0^2 + y0
f(2, 2)
# [1] -4
With a more difficult function, where you want to avoid modifying strings or the other variables named yy and xx for example,
tricky <- function(x, y) { tst <- "x + y"; -xx*x + yy*y }
formals(tricky) <- pairlist(x0=bquote(), y0=bquote())
body(tricky) <- rep_vars(body(tricky), newvals)
tricky
# function (x0, y0)
# {
# tst <- "x + y"
# -xx * x0 + yy * y0
# }
#
There are a few ways to go here. Following your code, I would go with something like this:
f = function(x, y) -x^2 + x + -y^2 + y
# Take old names
form_old = names(formals(f))
# Make new names
form_new = paste0(form_old, 0)
deparse(body(f)) -> bod
for (i in 1:length(form_new)) {
bod = gsub(form_old[i], form_new[i], bod, fixed = TRUE)
}
formals(f) = setNames(vector("list", length(form_new)), form_new)
body(f) <- parse(text = bod)
f(1, 1)
I have an R formula object:
R> formula.obj <- Y ~ 1 + X + offset(Z)
I want to get rid of offset(Z) and obtain:
R> formula.obj.want <- Y ~ 1 + X
It seems that update function does NOT work in this scenario:
R> update(formula.obj,.~.-offset(Z))
Y ~ X + offset(Z)
Is there way to get formula.obj.want from formula.obj?
You can't do this in update. "-" is not supported for offset formulas http://stat.ethz.ch/R-manual/R-patched/library/stats/html/offset.html
Define another function as u did
You can use the list structure and the language
> formula.obj[[3]] <- quote(1 + X)
> formula.obj
Y ~ 1 + X
> class(formula.obj)
[1] "formula"
Note that I did try update, and it did not want to include the 1
> update(formula.obj, .~ 1 + X)
Y ~ X