I want to apply a function over a list of models. I would like to organize the output by having the name of the model precede its output. Here is a (very) simplified example using match.call() based on this r-help thread:
x <- rnorm(10)
y <- rnorm(10)
mod <- lm(y~x)
fun <- function(model){
name <- as.character(match.call()[[2]])
p <- summary(model)$coefficients[2,4]
return(paste(name, "; p =", p))
}
If I feed it a single model, it works fine:
> fun(model=mod)
[1] "mod ; p = 0.901618595026321"
But if I apply it to a list, named or not, it does not work:
> lapply(list(mod, mod), fun)
[[1]]
[1] "[[ ; p = 0.901618595026321" "X ; p = 0.901618595026321"
[3] "i ; p = 0.901618595026321"
[[2]]
[1] "[[ ; p = 0.901618595026321" "X ; p = 0.901618595026321"
[3] "i ; p = 0.901618595026321"
> lapply(list(modA=mod, modB=mod), fun)
$modA
[1] "[[ ; p = 0.901618595026321" "X ; p = 0.901618595026321"
[3] "i ; p = 0.901618595026321"
$modB
[1] "[[ ; p = 0.901618595026321" "X ; p = 0.901618595026321"
[3] "i ; p = 0.901618595026321"
For clarity, what I want is:
[[1]]
[1] "modA ; p = 0.901618595026321"
[[2]]
[1] "modB ; p = 0.901618595026321"
Is there a reason why you don't want to use lapply over the names of the list instead?
fun2 = function(models, name){
model <- models[[name]]
p <- summary(model)$coefficients[2,4]
return(paste(name, "; p =", p))
}
mods = list(modA = mod, modB = mod)
lapply(names(mods), fun2, models = mods)
# [[1]]
# [1] "modA ; p = 0.828746440943558"
# [[2]]
# [1] "modB ; p = 0.828746440943558"
Try this,
mLst <- list(modA=mod, mobB=mod)
p <- lapply(mLst, function(m) summary(m)$coefficients[2,4])
as.list(mapply(function(n,p) paste(n,p, sep=" ; "), names(mLst), p))
Related
Let's say I have an object of type "symbol" representing the name of a function. For example:
nm <- quote(mean)
I want to construct a function f whose body uses the function named by the symbol nm. For example:
f <- function(x, do = c("something", "nothing")) {
switch(match.arg(do), something = mean(x), nothing = x)
}
I want to construct this function identically, which implies that I would not be satisfied with the following approach:
factory <- function(name) {
func <- match.fun(name)
function(x, do = c("something", "nothing")) {
switch(match.arg(do), something = func(x), nothing = x)
}
}
g <- factory(nm)
since the body of g is not body(f) and the environment of g is not environment(f).
One approach that I've considered is bquote:
h <- eval(bquote({
function(x, do = c("something", "nothing")) {
switch(match.arg(do), something = .(nm)(x), nothing = x)
}
}))
bquote gets me most of the way there, but one issue is that the print output of h doesn't contain the substituted value of nm by default:
h
## function(x, do = c("something", "nothing")) {
## switch(match.arg(do), something = .(nm)(x), nothing = x)
## }
print(h, useSource = FALSE)
## function (x, do = c("something", "nothing"))
## {
## switch(match.arg(do), something = mean(x), nothing = x)
## }
The cause seems to be the srcref attribute of h:
identical(f, h)
## [1] TRUE
identical(f, h, ignore.srcref = FALSE)
## [1] FALSE
My question is: How might one approach the general problem of constructing f from nm?
My conditions on the constructed function h are that identical(f, h) should be TRUE and that the output of print(h) should contain the substituted value of nm, similar to print(f).
I would welcome answers improving on my existing bquote approach, or answers suggesting a new approach, or answers explaining why what I want to do is not actually possible...
Not especially elegant, but a parse(deparse( seems to work:
nm <- quote(mean)
f <- function(x, do = c("something", "nothing")) {
switch(match.arg(do), something = mean(x), nothing = x)
}
eval(parse(text=deparse(bquote(h <- function(x, do = c("something", "nothing")) {
switch(match.arg(do), something = .(nm)(x), nothing = x)
}))))
identical(f, h)
#> [1] TRUE
print(f)
#> function(x, do = c("something", "nothing")) {
#> switch(match.arg(do), something = mean(x), nothing = x)
#> }
print(h)
#> function(x, do = c("something", "nothing")) {
#> switch(match.arg(do), something = mean(x), nothing = x)
#> }
srcref is not identical, as expected:
identical(f, h, ignore.srcref = FALSE)
#> [1] FALSE
attributes(attributes(f)$srcref)$srcfile$lines
#> [1] "f <- function(x, do = c(\"something\", \"nothing\")) {"
#> [2] " switch(match.arg(do), something = mean(x), nothing = x)"
#> [3] "}"
attributes(attributes(h)$srcref)$srcfile$lines
#> [1] "h <- function(x, do = c(\"something\", \"nothing\")) {"
#> [2] " switch(match.arg(do), something = mean(x), nothing = x)"
#> [3] "}"
Reading through ?srcref, it seems that there are two idiomatic ways to improve the bquote approach. The first uses removeSource to recursively clean a function that preserves its source code:
h <- removeSource(eval(bquote({
function(x, do = c("something", "nothing")) {
switch(match.arg(do), something = .(nm)(x), nothing = x)
}
})))
h
function (x, do = c("something", "nothing"))
{
switch(match.arg(do), something = mean(x), nothing = x)
}
The second avoids preserving the source code altogether:
op <- options(keep.source = FALSE)
h <- eval(bquote({
function(x, do = c("something", "nothing")) {
switch(match.arg(do), something = .(nm)(x), nothing = x)
}
}))
options(op)
h
function (x, do = c("something", "nothing"))
{
switch(match.arg(do), something = mean(x), nothing = x)
}
Actually, ?options states that the default value of keep.source is interactive(), so both approaches are somewhat redundant in non-interactive contexts.
I would like to concatenate an equation for a logistic model first followed by a linear model.
For model 1, o1=p1+p2+p3 (binomial will be input to family parameter in glm function)
For model 2, o2=p1+p2+p3 (gaussian will be input to family parameter in glm function)
In the real life example, there will be many more models.
Here is the basic scenario:
outcome <- c("o1", "o2")
predictor <- c("p1", "p2", "p3")
link=c("binomial", "gaussian")
try <- function(outcomes, predictors) {
for(o in outcome) {
eq <- paste(o, "~")
for(p in predictor) {
eq=paste0(eq, p, "+")
}
# remove extra +
eq <- substr(eq,1,nchar(eq)-1)
# model will go here
eq <- lapply(link, function(x) paste0(x, " - ", eq))
print(eq)
}
}
try(outcomes=outcome, predictors=predictor)
Output:
[[1]]
[1] "binomial - o1 ~p1+p2+p3"
[[2]]
[1] "gaussian - o1 ~p1+p2+p3"
[[1]]
[1] "binomial - o2 ~p1+p2+p3"
[[2]]
[1] "gaussian - o2 ~p1+p2+p3"
Instead, I want:
[1] "binomial - o1 ~p1+p2+p3"
[1] "gaussian - o2 ~p1+p2+p3"
We can do
try1 <- function(outcomes, predictors) {
Map(function(x, y) paste(y, '-',
deparse(reformulate(predictors, x))), outcomes, link)
}
-testing
try1(outcomes=outcome, predictors=predictor)
#$o1
#[1] "binomial - o1 ~ p1 + p2 + p3"
#$o2
#[1] "gaussian - o2 ~ p1 + p2 + p3"
Maybe try can be written like below
try <- function(outcomes, predictors) {
as.list(
paste0(
do.call(
paste,
c(data.frame(link, outcomes), sep = " - ")
),
paste0(" ~ ", paste0(predictors, collapse = " + "))
)
)
}
such that
> try(outcome, predictor)
[[1]]
[1] "binomial - o1 ~ p1 + p2 + p3"
[[2]]
[1] "gaussian - o2 ~ p1 + p2 + p3"
Consider this code
fn = function(...) {
# print the content of ... without evaluation?
}
I want the output of fn(a = b) to be "a = b" and fn(a = gn(b), 3~b~a, dd, e = 2 + f, h = hn(jn(cdf))) to be list("a=gn(b)", "3~b~a", "dd", "e=2+f", "h= hn(jn(cdf)))".
I can't seem to find the right NSE function for it. I prefer Base R so I understand the process better. The closest I got was this
fn = function(...) {
res = rlang::enexprs(...)
paste0(names(res), ifelse(names(res)=="",names(res) , "=") , sapply(res, capture.output))
}
An alternative to match.call (see here) is the undocumented ...().
fn <- function(...) {
x <- substitute(...())
y <- ifelse(nchar(names(x)) > 0, paste(names(x), "=", x), as.character(x))
as.list(y)
}
fn(a = b)
fn(a = gn(b), 3~b~a, dd, e = 2 + f, h = hn(jn(cdf)))
You can use match.call :
fn = function(...) {
temp <- as.list(match.call())[-1]
as.list(sub('^=', '', paste0(names(temp), '=', temp)))
}
fn(a = b)
#[[1]]
#[1] "a=b"
fn(a = gn(b), 3~b~a, dd, e = 2 + f, h = hn(jn(cdf)))
#[[1]]
#[1] "a=gn(b)"
#[[2]]
#[1] "3 ~ b ~ a"
#[[3]]
#[1] "dd"
#[[4]]
#[1] "e=2 + f"
#[[5]]
#[1] "h=hn(jn(cdf))"
When I write a setter method in a class, the setter method does not change the value. I just cannot find the error here.
point <- function(x,y){
structure(class = "point", list(
# attributes
x = x,
y = y,
# methods
get_x = function() paste("(", x,",",y,")"),
set_x = function(x,y){ self.x = x; self.y = y}
))}
> p <- point(0,1)
> p$get_x()
[1] "( 0 , 1 )"
> p$set_x(6,5)
> p$get_x()
[1] "( 0 , 1 )"
Try to follow this change to your code.
In function set_x, it is the values of variables x and y created in function point that are assigned new values with <<-, not the x and y that exist in the .GlobalEnv.
point <- function(x, y){
structure(class = "point", list(
x = x,
y = y,
get_x = function() paste("(", x,",",y,")"),
set_x = function(x, y){
x <<- x
y <<- y
}
))
}
x <- 0
y <- 1
p <- point(0,1)
p$get_x()
#[1] "( 0 , 1 )"
p$set_x(6,5)
p$get_x()
#[1] "( 6 , 5 )"
x
#[1] 0
y
#[1] 1
a <- function(x){
a = 2*x*x
return(a)
}
b (x) <- a(1) + a(2) + ... + a(x)
there is function a, I want to write a function b,which is a accumulation of function a.
I write it in R.
Maybe like this:
a <- function(x)
{2*x*x}
b<- function(y)
{sum(sapply(seq(y),a))}
so
b(3) = 28
since
b(3) = a(1) + a(2) + a(3)
= 2*1*1 + 2*2*2 + 2*3*3
= 2 + 8 + 18
= 28
Function b creates an expression and evaluates that expression to return the result.
a <- function(x){
return(2*x*x)
}
b <- function(x){
eval( parse( text = paste0( strsplit( paste0( "a(", x, ")"), " "), collapse = "+") ))
}
b(1:2)
# [1] 10
b(1:3)
# [1] 28
b(1:5)
# [1] 110
b(c(2,4,6))
# [1] 112