How can I dynamically update a formula?
Example:
myvar <- "x"
update(y ~ 1 + x, ~ . -x)
# y ~ 1 (works as intended)
update(y ~ 1 + x, ~ . -myvar)
# y ~ x (doesn't work as intended)
update(y ~ 1 + x, ~ . -eval(myvar))
# y ~ x (doesn't work as intended)
You can use paste() within the update()call.
myvar <- "x"
update(y ~ 1 + x, paste(" ~ . -", myvar))
# y ~ 1
Edit
As #A.Fischer noted in the comments, this won't work if myvar is a vector of length > 1
myvar <- c("k", "l")
update(y ~ 1 + k + l + m, paste(" ~ . -", myvar))
# y ~ l + m
# Warning message:
# Using formula(x) is deprecated when x is a character vector of length > 1.
# Consider formula(paste(x, collapse = " ")) instead.
Just "k" gets removed, but "l" remains in the formula.
In this case we could transform the formula into a strings, add/remove what we want to change and rebuild the formula using reformulate, something like:
FUN <- function(fo, x, negate=FALSE) {
foc <- as.character(fo)
s <- el(strsplit(foc[3], " + ", fixed=T))
if (negate) {
reformulate(s[!s %in% x], foc[2], env=.GlobalEnv)
} else {
reformulate(c(s, x), foc[2], env=.GlobalEnv)
}
}
fo <- y ~ 1 + k + l + m
FUN(fo, c("n", "o")) ## add variables
# y ~ 1 + k + l + m + n + o
FUN(fo, c("k", "l"), negate=TRUE)) ## remove variables
# y ~ 1 + m
Related
I have a SpatialPointsDataframe called rain and I would like to fit a variogram and perfom cross-validation for each one of its last 10 columns (dependent variables) like below:
fit.reg.vgm <- autofitVariogram(
column (dependent variable) ~ X + Y + Z + AS + SL,
rain,
model = c("Sph", "Exp", "Gau", "Lin", "Log"),
fix.values = c(NA, NA, NA),
verbose = FALSE,
GLS.model = NA,
start_vals = c(NA, NA, NA),
miscFitOptions = list()
)
cv <-krige.cv(column (dependent variable) ~ X + Y + Z + AS + SL, rain, fit.reg.vgm$var_model)
Does anyone know how to construct such a for-loop?
Thanks in advance!
You will need to construct a formula. Try formula() and paste(). Something along the lines of
x <- c("a", "b", "c")
out <- list()
for (i in seq_along(x)) {
out[[i]] <- formula(paste(x[i], "~ X + Y + Z"))
}
> out
[[1]]
a ~ X + Y + Z
[[2]]
b ~ X + Y + Z
[[3]]
c ~ X + Y + Z
An option with reformulate
out <- vector('list', length(x))
for(i in seq_along(x)) {out[[i]] <- reformulate(c("X", "Y", "Z"), response = x[i]) }
out
#[[1]]
#a ~ X + Y + Z
#[[2]]
#b ~ X + Y + Z
#[[3]]
#c ~ X + Y + Z
After looking at many examples and lots of trying, I'm still failing to combine text strings and an expression into ggplot2 axis labels to exactly what I want.
what I am trying to get here is the x-axis label to be:
the ingredients:
parname <- 'FL.Red.Total'
xmean <- 123.34
xsigma <- 2580.23
to change the numbers to 10^n notations I use this formula:
sci_form10 <- function(x) {
paste(gsub("e\\+", " \xB7 10^", scientific_format()(x)))
}
the name would then be build by:
labs( x = bquote(.(gsub('\\.', '\\ ', parname)) ~ " (a.u.) (" ~ mu ~ "=" ~ .(sci_form10(xmean)) ~ ", " ~ sigma ~ " =" ~ .(sci_form10(xsigma)) ~ ")" ))
I'm hoping to replace 10^04 with 10 followed by a 4 in superscript and to add a linebreak to the labels as the first image shows
The test code:
library(ggplot2)
library(scales)
sci_form10 <- function(x) {
paste(gsub("e\\+", " * 10^", scientific_format()(x)))
}
parname <- 'FL.Red.Total'
xmean <- 123.34
xsigma <- 2580.23
ggplot(mtcars, aes(x=mpg,y=cyl)) +
geom_point() +
labs( x = bquote(.(gsub('\\.', '\\ ', parname)) ~ " (a.u.) (" ~ mu ~ "=" ~ .(sci_form10(xmean)) ~ ", " ~ sigma ~ " =" ~ .(sci_form10(xsigma)) ~ ")" ))
gives:
p.s. I also tried
sci_form10 <- function(x) {
paste(gsub(".*e\\+", "10^", scientific_format()(x)))
}
which only gives the 10^03 part to see if that would change the outcome of my label, but no.
An option would be wrap with atop to create line breaks
sci_form10 <- function(x) {
paste(gsub("e\\+", " \u00B7 10^", scientific_format()(x)))
}
x1 <- sci_form10(xmean)
x2 <- sci_form10(xsigma)
lst1 <- strsplit(c(x1,x2), "\\s(?=10)", perl = TRUE)
pre <- sapply(lst1, `[`, 1)
post <- sapply(lst1, `[`, 2)
xmean1 <- parse(text = paste0("'", pre[1], "'"))[[1]]
xsigma1 <- parse(text = paste0("'", pre[2], "'"))[[1]]
post1 <- parse(text = post[1])[[1]]
post2 <- parse(text = post[2])[[1]]
ggplot(mtcars, aes(x=mpg,y=cyl)) +
geom_point() +
labs( x = bquote(atop(.(gsub("\\.", "\\ ",
parname))~"(a.u.)"~phantom(), "(" ~ mu~ " = "~ .(xmean1) ~ .(post1) ~ ", " ~ sigma ~ " = " ~ .(xsigma1) ~ .(post2)~ ")")))
-output
I have something that does most of what you wanted.
changeSciNot <- function(n) {
output <- format(n, digits=3, scientific = TRUE) # Transforms the number into scientific notation even if small
output <- sub("e", "*10^", output) # Replace e with 10^
output <- sub("\\+0?", "", output) # Remove + symbol and leading zeros on exponent, if > 1
output <- sub("-0?", "-", output) # Leaves - symbol but removes leading zeros on exponent, if < 1
output
}
# example data
parname <- "FL.Red.Total"
xmean <- 123.34
xsigma <- 2580.23
label <- bquote(atop(.(gsub("\\.", "\\ ", parname)) ~ "(a.u.)",
mu*"="*.(changeSciNot(xmean))*"," ~ sigma*"="*.(changeSciNot(xsigma))))
ggplot(mtcars, aes(x=mpg,y=cyl)) +
geom_point() +
labs(x = label)
The changeSciNot function came from this thread. I had some problems using \xB7 for the multiplication, so I left *. I also hard coded the number of digits for the format, but you can also make it into an argument. Hopefully, this will get you closer to the exact desired output.
I have a formula in R for example
y ~ x + z + xx + zz + tt + x:xx + x:zz + xx:z + zz:xx + xx:zz:tt
or even more complicated (y~x*z*xx*zz*tt)
Note that the names on the right-hand side of the formula are intentionally selected to be somehow similar to at least one other term.
The question is now how to remove the interaction terms that are related to a specific main effect. For example, if I remove the term x (main effect) I want to remove the interaction terms that also include x, here x:xx.
I have tried grepl() but it would remove any term that contains partially or fully the word. In my example it removes x,xx,x:xx,xx:z,zz:xx,xx:zz:tt
any ideas about a function to do it?
Update:
What I have already tried:
f = y ~ x + z + xx + zz + tt + x:xx + x:zz + xx:z + zz:xx + xx:zz:tt
modelTerms = attr(terms(f) , which = 'term.labels')
modelTerms[!grepl(pattern = 'x', x = modelTerms)]
Use update.formula:
f <- y~x*z*xx*zz*tt
update(f, . ~ . - x - x:.)
#y ~ z + xx + zz + tt + z:xx + z:zz + xx:zz + z:tt + xx:tt + zz:tt +
# z:xx:zz + z:xx:tt + z:zz:tt + xx:zz:tt + z:xx:zz:tt
f <- y ~ x + z + xx + zz + tt + x:xx + x:zz + xx:z + zz:xx + xx:zz:tt
update(f, . ~ . - x - x:.)
#y ~ z + xx + zz + tt + z:xx + xx:zz + xx:zz:tt
Are you looking for this?
> modelTerms[!grepl(pattern='^x\\:x+', x=modelTerms)]
[1] "x" "z" "xx" "zz" "tt" "x:zz" "z:xx" "xx:zz"
[9] "xx:zz:tt"
Simple:
f = y~x*z*xx*zz*tt
modelTerms = attr(terms(f) , which = 'term.labels')
l = sapply(
strsplit(x = modelTerms, split = '[:*]'),
FUN = function(x) {
'x' %in% x
}
)
modelTerms[!l]
What is the proper string parsing required to use reformulate() when the termlabels have embedded spaces?
This works:
reformulate(c("A", "B"), "Y")
Y ~ A + B
These all fail:
reformulate(c("A var", "B"), "Y")
reformulate(quote(c("A var", "B")), "Y")
reformulate(as.formula(quote(c("A var", "B"))), "Y")
Expected results:
Y ~ `A var` + B
# or
Y ~ `A var` + `B`
NOTE
I cannot hard code the backticks. This is part of a larger shiny application, therefore, if backticks are the answer, I need a method to do this programmatically.
Here are a few other ways that work with symbols rather than strings (so no need for explicit backticks).
input <- "A var"
eval(bquote( Y ~ .(as.name(input)) + B))
# Y ~ `A var` + B
eval(substitute( Y ~ INPUT + B, list(INPUT = as.name(input))))
# Y ~ `A var` + B
library(rlang)
eval(expr(Y ~ !!sym(input) + B))
# Y ~ `A var` + B
Use backticks, e.g.
reformulate(c("`A var`", "B"), "Y")
#Y ~ `A var` + B
Or better yet, don't use spaces in variable names.
Or with a helper function
bt <- function(x) sprintf("`%s`", x)
reformulate(c(bt(var1), var2), "Y")
#Y ~ `A var` + B
I want to write an R function that takes a mathematical function in x and returns a new function in x as an output. For example:
The input should be passed in as a mathematical function (or relation) in x:
g <- x^2 + 9*x + log(x)
And the resulting output should be:
function(x) (exp(g))
i.e. I want to return the symbolic exponential expression of the original function in x i.e. exp(x^2 + 9*x + log(x)) in this illustrative example
So ideally it would return the function object:
function(x) (exp(x^2 + 9*x + log(x)))
I tried as follows:
test <- function(g){
h <- function(x){exp(g)}
return(h)
}
m <- test(x^2 + 9*x + log(x))
m(10)
So m(10) should return:
exp(10^2 + 9*10 + log(10))
which is exp(192.3026) in this case.
Could anyone show how to do this please?
You could use package functional:
library(functional)
fun <- Compose(function(x) x^2 + 9*x + log(x), exp)
fun(1)
#[1] 22026.47
Here is one approach:
test <- function(e) {
ee <- substitute(e)
eee <- substitute(exp(X), list(X=ee))
f <- function(x) {}
body(f) <- eee
environment(f) <- parent.frame()
f
}
## Check that it works
m <- test(x^2 + 9*x + log(x))
m
# function (x)
# exp(x^2 + 9 * x + log(x))
m(1)
# [1] 22026.47
m(1) == exp(10)
# [1] TRUE
edit - for functionality in question
f <- function(...) {
l <- eval(substitute(alist(x = x, ...)))
l[[2]] <- substitute(exp(X), list(X = l[[2]]))
as.function(`names<-`(l, l[sapply(l, is.symbol)]))
}
g <- f(x^2 + 2*x + 5)
# function (x = x)
# exp(x^2 + 2 * x + 5)
g(1)
# [1] 2980.958
Here is another way for a general case:
f <- function(...) {
l <- eval(substitute(alist(...)))
as.function(`names<-`(l, l[sapply(l, is.symbol)]))
}
g <- f(x, x^2 + 9*x + log(x))
# function (x = x)
# x^2 + 9 * x + log(x)
g(10)
# [1] 192.3026
This version will also work for any number of variables, just define them followed by the function:
g <- f(x, y, z, x + 2 * y + z ** 3)
# function (x = x, y = y, z = z)
# x + 2 * y + z^3
g(1, 2, 0)
# [1] 5
There may be a better way to add ... to functions, but here is how you can do that
f <- function(..., use_dots = FALSE) {
l <- eval(substitute(alist(...)))
if (use_dots)
l <- c(head(l, -1), list('...' = as.symbol('...')), tail(l, 1))
as.function(`names<-`(l, l[sapply(l, is.symbol)]))
}
So now you don't have to name all the variables/arguments
g <- f(x, y, plot(x, y, ...), use_dots = TRUE)
g(1:5, 1:5, main = 'main title', pch = 16, col = 3, cex = 3, xpd = NA)