I have a formula with an arbitrary number of variables on the left and right-hand sides:
a + b * c ~ d + e
This formula can include various operators like + or *. I would like to wrap each variable of the formula in a transformation. For example, if my transformation is called Factor, then the formula above becomes:
Factor(a) + Factor(b) * Factor(c) ~ Factor(d) + Factor(e)
Notice that it preserved the same signs.
1) rrapply We can use rrapply to recursively walk the formula and surround every node that is a syntactic name with Factor(...). Alternately we could use is.word <- function(x) grepl("^\\w+$", x) to check for names that only contain word characters.
library(rrapply)
fo <- a + b * c ~ d + e
is.word <- function(x) make.names(x) == x
insert.Factor <- function(x) substitute(Factor(x), list(x = x))
rrapply(fo, is.word, insert.Factor)
## Factor(a) + Factor(b) * Factor(c) ~ Factor(d) + Factor(e)
If we can have formulas such as
fo2 <- a + b * c ~ I(d) + e
and we want I(Factor(d)) rather than Factor(I)(Factor(d)) then use this for is.word:
is.word <- function(x) make.names(x) == x && format(x) %in% all.vars(fo2)
2) gsub Convert to character string, perform the substitution and convert back. The input, fo, is defined above.
formula(gsub("(\\w+)", "Factor(\\1)", format(fo)), environment(fo))
## Factor(a) + Factor(b) * Factor(c) ~ Factor(d) + Factor(e)
3) Transform data frame If these variables will be obtained from a data frame DF then we could transform its columns and leave the formula as is.
DF[] <- lapply(DF, Factor)
Here is a way to update a formula with a recursive function:
update_formula <- function(x){
if(length(x) == 3){
x[[2]] <- update_formula(x[[2]])
x[[3]] <- update_formula(x[[3]])
return(x)
}else{
return(substitute(Factor(var), list(var = x)))
}
}
f <- a + b * c ~ d + e
update_formula(f)
# Factor(a) + Factor(b) * Factor(c) ~ Factor(d) + Factor(e)
The main idea is that each binary operator corresponds to a list of length 3. For example:
> as.list(f)
[[1]]
`~`
[[2]]
a + b * c
[[3]]
d + e
> as.list(f[[2]])
[[1]]
`+`
[[2]]
a
[[3]]
b * c
> as.list(f[[3]])
[[1]]
`+`
[[2]]
d
[[3]]
e
So we update the second and third component each time we encounter a binary operator.
To apply arbitrary transformation:
update_formula2 <- function(x, trans){
if(length(x) == 3){
x[[2]] <- update_formula2(x[[2]], trans)
x[[3]] <- update_formula2(x[[3]], trans)
return(x)
}else{
return(substitute(fun(var), list(fun = trans, var = x)))
}
}
f <- a + b * c ~ d + e
update_formula2(f, quote(Factor))
# Factor(a) + Factor(b) * Factor(c) ~ Factor(d) + Factor(e)
update_formula2(f, quote(log))
# log(a) + log(b) * log(c) ~ log(d) + log(e)
Related
When I call the user defined function sRGB_to_CAM16UCS in the console, it displays the result as intended. But when I try to call it within a while loop it throws an error. Can somebody help me understand the error?
library(purrr)
library(tibble)
library(tidyr)
sRGB_to_CAM16UCS <- function(R255, G255, B255){
# Convert sRGB to 1931 CIE XYZ [IEC 61966-2–1:2003(E)]
## Convert to the range of 0 to 1
R1 <- R255 / 255
G1 <- G255 / 255
B1 <- B255 / 255
## Gamma Expansion of sRGB values
gamma_inverse <- function(RGB1){
if (RGB1 < -0.04045 | RGB1 > 0.04045){
((RGB1 + 0.055)/1.055)^2.4
} else {
RGB1/12.92
}
}
R_li <- gamma_inverse(R1)
G_li <- gamma_inverse(G1)
B_li <- gamma_inverse(B1)
# Convert linear RGB values to CIE XYZ
X <- 41.24 * R_li + 35.76 * G_li + 18.05 * B_li
Y <- 21.26 * R_li + 71.52 * G_li + 07.22 * B_li
Z <- 01.93 * R_li + 11.92 * G_li + 95.05 * B_li
# Convert XYZ to CAM16
## User defined Parameters
X_w <- 96.4212
Y_w <- 100
Z_w <- 82.5188
L_A <- 40
Y_b <- 20
surround <- 2
discounting <- FALSE
## Predefined functions and constants
### M16
M16 <- matrix(c(0.401288,-0.250268,-0.002079,
0.650173, 1.204414, 0.048952,
-0.051461, 0.045854, 0.953127), nrow = 3, ncol=3)
### lerp
lerp <- function(a,b,c){
(1 - c) * a + c * b
}
### Crop
crop <- function(a,b,c){
pmin(pmax(c, a), b)
}
### Define adapt
adapt <- function(component){
con <- (F_L * abs(component) * 0.01)^0.42
sign(component) * 400 * con / (con + 27.13)
}
### Define unadapt
unadapt <- function(component){
sign(component) * 100 / F_L * ((27.13* abs(component))/(400-abs(component)))^2.38095238095
}
# Calculations
## Calculate "c"
if (surround >=1){
c <- lerp(0.59, 0.69, surround-1)
}else{
c <- lerp(0.525, 0.59, surround)
}
## Calculate "F" and "N_c"
if (c >= 0.59){
N_c <- lerp(0.9, 1.0, (c - 0.59)/.1)
} else {
N_c <- lerp(0.8, 0.9, (c - 0.525)/0.065)
}
## Calculate "k"
k <- 1/(5*L_A + 1)
## Calculate F_L
F_L <- k^4 * L_A + 0.1 * (1-k^4)^2 * (5 * L_A)^0.33333333333
## Calculate n
n <- Y_b / Y_w
## Calculate z
z <- 1.48 + sqrt(n)
## Calculate N_bb
N_bb <- 0.725 * n^-0.2
## Calculate D
if (discounting == FALSE){
D <- crop(0,1,N_c* (1 - 1/3.6 * exp((-L_A - 42)/92)))
}else {
D <- 1
}
## Calculate the "RGB_w"
RGB_w <- matrix(c(M16[1,1] * X_w + M16[1,2] * Y_w + M16[1,3] * Z_w,
M16[2,1] * X_w + M16[2,2] * Y_w + M16[2,3] * Z_w,
M16[3,1] * X_w + M16[3,2] * Y_w + M16[3,3] * Z_w), nrow = 3, ncol=1)
# Calculate the "D_RGB"
D_RGB <- apply(RGB_w, c(1, 2), function(x)((1 - D) * 1 + D * Y_w/x))
# Calculate the "D_RGB_inv"
D_RGB_inv <- apply(D_RGB,c(1, 2),function(x)1/x)
# Calculate the "RGB_cw"
RGB_cw <- RGB_w*D_RGB
# Calculate RGB_aw
RGB_aw <- apply(RGB_cw, c(1,2), adapt)
# Calculate A_w
A_w <- N_bb * ( 2 * RGB_aw[1,1] + RGB_aw[2,1] + 0.05 * RGB_aw[3,1])
# Calculate RGB_a
R_a <- adapt((M16[1,1] * X + M16[1,2] * Y + M16[1,3] * Z) * D_RGB[1,1])
B_a <- adapt((M16[2,1] * X + M16[2,2] * Y + M16[2,3] * Z) * D_RGB[2,1])
G_a <- adapt((M16[3,1] * X + M16[3,2] * Y + M16[3,3] * Z) * D_RGB[3,1])
# Calculate Hue
a <- R_a + (-12 * G_a + B_a) / 11
b <- (R_a + G_a - 2 * B_a) / 9
h_rad <- atan2(b, a)
h_ucs <- h_rad*(180.0/pi)
# Calculate Lightness (J)
e_t <- 0.25 * (cos(h_rad + 2) + 3.8)
A <- N_bb * (2*R_a + G_a + 0.05*B_a)
J <- 100 * ((A / A_w)^(c*z))
J_ucs <- 1.7 * J / (1 + 0.007 * J)
# Calculate brightness (Q)
Q <- 4/c * sqrt(J/100) * (A_w + 4) * (F_L^0.25)
# Calculate chroma (C)
t <- (5000 / 13 * N_c * N_bb * e_t * sqrt(a*a + b*b)) / (R_a + G_a + 1.05 * B_a + 0.305)
alpha <- t^0.9*(1.64 - 0.29^n)^0.73
C <- alpha * sqrt(J/100)
# Calculate colorfulness (M)
M <- C * F_L^0.25
M_ucs <- log(1 + 0.0228 * M) / 0.0228
# Calculate redness-greenness(a)
a_ucs <- M * cos(h_rad)
# Calculate yellowness-blueness(b)
b_ucs <- M * sin(h_rad)
# Calculate Saturation (s)
s <- 50 * sqrt(alpha*c /(A_w + 4))
return(tibble(R255, G255, B255, h_ucs, J_ucs ,M_ucs ,a_ucs, b_ucs))
}
nc <- 5
rgb_vals <- tibble(r1 = rdunif(nc, b=255, a=0), g1 = rdunif(nc, b=255, a=0), b1 = rdunif(nc, b=255, a=0))
test <- 1
test_df <- tibble(h_ucs = numeric(), J_ucs = numeric(), M_ucs = numeric(), a_ucs = numeric(), b_ucs = numeric())
while(test <= nrow(rgb_vals)){
test_r <- sRGB_to_CAM16UCS(rgb_vals[test, 1],rgb_vals[test, 2],rgb_vals[test, 3])
test_df <- rbind(test_df, test_r)
test <- test + 1
}
output <- cbind(rgb_vals, test_df)
print(output)
openxlsx::write.xlsx(output, "rgb2camucs.xlsx")
threw an error as following
Error in atan2(b, a) : non-numeric argument to mathematical function
>
> output <- cbind(rgb_vals, test_df)
Error in data.frame(..., check.names = FALSE) :
arguments imply differing number of rows: 5, 0
> print(output)
Error in print(output) : object 'output' not found
UPDATE: If I wrap the a and b with as.numeric() function, it throws the following error message:
Error:
! Column names `r1`, `r1`, `r1`, `r1`, `r1`, and 1 more must not be duplicated.
Use .name_repair to specify repair.
Caused by error in `repaired_names()`:
! Names must be unique.
x These names are duplicated:
* "r1" at locations 1, 2, 3, 5, 6, etc.
Run `rlang::last_error()` to see where the error occurred.
>
This is because b and a are indeed non-numeric arguments. They are data.frames.
Replacing that line with h_rad <- atan2(b$r1, a$r1) makes it work as class(b$r1) results in numeric. Note that the last line of code where output is exported to an XLSX does not work.
You can also "unpack" your 1x1 data.frame using double brackets before calling your method, i.e., say test_r <- sRGB_to_CAM16UCS(rgb_vals[[test, 1]],rgb_vals[[test, 2]],rgb_vals[[test, 3]]) instead of test_r <- sRGB_to_CAM16UCS(rgb_vals[test, 1],rgb_vals[test, 2],rgb_vals[test, 3]) near the end of your code. This way you are passing the plain numbers to your function. This way, also the export to XLSX works.
I found this using RStudio's debugger, setting a breakpoint to that line and then entering class(b) into the console on the bottom.
From a derivation I get a "call" object as seen in the code snippet. I want to transform this into a function with arguments but I can't figure out how to get it right. It returns just the call object.
someDeriv <- D(expression(a * x^2 + x), "x")
someDeriv
#returns: a * (2 * x) + 1
class(someDeriv)
#returns: "call"
#here comes the important part
fn <- as.function(alist(a=,x=,someDeriv))
fn(a=1, x=2)
#returns: a * (2 * x) + 1
#should return: 5
alist quotes its arguments, so when you pass names of variables, their values aren't substituted in the returned list. This means that alist(a =, x =, someDeriv) is not equivalent to alist(a =, x =, a * (2 * x) + 1).
someDeriv <- D(expression(a * x^2 + x), "x")
l1 <- alist(a =, x =, someDeriv)
l1
$a
$x
[[3]]
someDeriv
l2 <- alist(a =, x =, a + (2 * x) + 1)
l2
$a
$x
[[3]]
a + (2 * x) + 1
Your function fn is actually defined as:
fn <- as.function(l1)
fn
function (a, x)
someDeriv
No matter what values you pass for a and x, fn returns the value of someDeriv, which in your global environment is the call a * (2 * x) + 1.
To get the behaviour you want, you can do this:
l3 <- c(alist(a =, x =), list(someDeriv))
l3
$a
$x
[[3]]
a * (2 * x) + 1
fn <- as.function(l3)
fn(a = 1, x = 2)
[1] 5
I have a character string:
FUN.n = "exp( 3 * x^2 + 2 * x + 1)";
I want to cast it as a function:
myFunction = castAsFunction ( FUN.n );
So that I can access it like:
myFunction(x)
and it will evaluate appropriately.
FUN.n = "exp( 3 * x^2 + 2 * x + 1)";
myFunction = castAsFunction ( FUN.n );
# [...]
myFunction = function(x)
{
exp( 3 * x^2 + 2 * x + 1);
}
x = -3:3;
myFunction(x);
# [1] 3.6e+09 8.1e+03 7.4e+00 2.7e+00 4.0e+02 2.4e+07 5.8e+14
I have tried as.function and eval(parse(text and none of them behave as I would expect.
I am looking for a variadic solution.
We could actually create a function called castAsFunction. We would need to give it not only a string as function body, but also the formal arguments. It feels like the function could be simplified, but it works with the example above.
FUN.n = "exp( 3 * x^2 + 2 * x + 1)"
x = -3:3
castAsFunction <- function(body, ...) {
dots <- match.call(expand.dots = FALSE)$...
form_ls <- rep(list(bquote()), length(dots))
names(form_ls) <- as.character(dots)
f <- function(){}
formals(f) <- form_ls
body(f) <- str2lang(body)
environment(f) <- parent.frame()
f
}
myfun <- castAsFunction(FUN.n, x)
myfun
#> function (x)
#> exp(3 * x^2 + 2 * x + 1)
myfun(x)
#> [1] 3.584913e+09 8.103084e+03 7.389056e+00 2.718282e+00 4.034288e+02
#> [6] 2.415495e+07 5.834617e+14
Created on 2021-02-18 by the reprex package (v0.3.0)
I have 3 vectors of equal length y, h and hp defined as follows:
y <- c(2, 5, 6)
h <- c(4, 25, 35)
hp <- c(3, 10, 12)
The values are simply illustrative.
I want to create an output list final_list of functions in x as follows
function(x) y + (h - hp) * x
(only ideal illustrative output shown):
[[1]]
[1] function(x) 2 + (1) * x
[[2]]
[1] function(x) 5 + (15) * x
[[3]]
[1] function(x) 6 + (23) * x
I am aware that this can be done with eval/parse, but this does not produce transparent output for the functions.
I would like to create the functions from these 3 vectors and output without using eval/parse. If this is possible I would be really happy to learn and be impressed!
You can use Map() with substitute(). The middle expressions are not yet evaluated, but I don't think that's such a big deal. They will be evaluated when the functions are called. Basically we just assemble the function in parts.
funs <- Map(
function(a, b, c) {
f <- function(x) x
body(f) <- substitute(y + (h - hp) * x, list(y = a, h = b, hp = c))
f
},
a = y, b = h, c = hp
)
funs
# [[1]]
# function (x)
# 2 + (4 - 3) * x
# <environment: 0x4543fd0>
#
# [[2]]
# function (x)
# 5 + (25 - 10) * x
# <environment: 0x4549e20>
#
# [[3]]
# function (x)
# 6 + (35 - 12) * x
# <environment: 0x454e5d8>
Now let's call the functions -
sapply(funs, function(a) a(1))
# [1] 3 20 29
Note: If you really need those middle expressions evaluated in the function bodies, you can use the following instead.
make <- function(a, b, c) {
d <- b - c
f <- function(x) x
body(f) <- substitute(y + (e) * x, list(y = a, e = d))
f
}
funs <- Map(make, y, h, hp)
y <- c(2,5,6)
h <- c(4, 25, 35)
hp <- c(3, 10, 12)
fun_create <- function(y, h, hp){
fun <- function(x){y + (h - hp)*x}
return(fun)
}
out <- mapply(y, h, hp, FUN = fun_create)
The output doesn't give what you might expect but it works correctly:
> out
[[1]]
function (x)
{
y + (h - hp) * x
}
<environment: 0x282ee40>
[[2]]
function (x)
{
y + (h - hp) * x
}
<environment: 0x282e610>
[[3]]
function (x)
{
y + (h - hp) * x
}
<environment: 0x282dde0>
> out[[1]](1)
[1] 3
Just using the function-function will succeed if it is executed in the correct environment.
> mapply( function(y,h,hp) function(x){ y+(h-hp)*x }, y,h,hp)
[[1]]
function (x)
{
y + (h - hp) * x
}
<environment: 0x7fb570828710>
[[2]]
function (x)
{
y + (h - hp) * x
}
<environment: 0x7fb570823718>
[[3]]
function (x)
{
y + (h - hp) * x
}
<environment: 0x7fb57081b5c8>
> myfuns[[1]](x=1:10)
[1] 3 4 5 6 7 8 9 10 11 12
> 2+(h[1]-hp[1])*1:10
[1] 3 4 5 6 7 8 9 10 11 12
> myfuns[[2]](x=1:10)
[1] 20 35 50 65 80 95 110 125 140 155
Each of those function definitions (actually closures) carries along the first matching values that existed at the time of its creation when the interpreted traveled along the search path.
> environment(myfuns[[1]])[["y"]]
[1] 2
> environment(myfuns[[1]])[["h"]]
[1] 4
> environment(myfuns[[1]])[["hp"]]
[1] 3
Is it possible to write a flexible function expression?
I want to use input arguments to control the expression of function.
For example
input arg -> function
c(1,1) -> func1 = function(x) x+1
c(1,3,2) -> func2 = function(x) x^2+3*x+2
c(6,8,-1) -> func3 = function(x) 6*x^2+8*x-1
makepoly <- function(b)
{
p <- rev(seq_along(b) - 1)
function(x)
{
xp <- outer(x, p, '^')
rowSums(xp * rep(b, each=length(x)))
}
}
# x^2 + 2x + 3
f <- makepoly(1:3)
f(0:4)
[1] 3 6 11 18 27
Here is my take on this task
create_poly <- function(coef)
paste(rev(coef),
paste("x", seq_along(coef) - 1, sep = "^"),
sep = "*", collapse = " + ")
make_polyfun <- function(input) {
myfun <- paste("function(x)", create_poly(input))
eval(parse(text = myfun))
}
With the example the OP gave we have :
make_polyfun(c(1, 1))
## function(x) 1*x^0 + 1*x^1
## <environment: 0x243a540>
make_polyfun(c(1, 3, 2))
## function(x) 2*x^0 + 3*x^1 + 1*x^2
## <environment: 0x1bd46e0>
make_polyfun(c(6, 8, 1))
## function(x) 1*x^0 + 8*x^1 + 6*x^2
## <environment: 0x22a59c0>
You can use polynom
library(polynom)
as.polynomial(c(2,3,1))
2 + 3*x + x^2
as.polynomial(c(6,8,1)
1 + 8*x + 6*x^2
EDIT you can of course coerce the result to a function using the genericas.function.polynomial. better here you can use ,as.polylist` to create many polynomials given a list of coefficients lists. For example:
lapply(as.polylist(list(c(2,3,1),c(6,8,1),c(6,8,-1))),
as.function)
[[1]]
function (x)
{
w <- 0
w <- 1 + x * w
w <- 3 + x * w
w <- 2 + x * w
w
}
<environment: 0x00000000113bd778>
[[2]]
function (x)
{
w <- 0
w <- 1 + x * w
w <- 8 + x * w
w <- 6 + x * w
w
}
<environment: 0x0000000011524168>
[[3]]
function (x)
{
w <- 0
w <- -1 + x * w
w <- 8 + x * w
w <- 6 + x * w
w
}
<environment: 0x0000000011527f28>
It's not clear how general you want to be from OP. For the particular case of polynomials, you can do:
f = function(x, coeffs) {
sum(outer(x, seq_along(coeffs) - 1, `^`) * coeffs)
}
f(2, c(1,2,3)) # 1 + 2*x + 3*x^2, with x = 2
#[1] 17
I read this as the desire to make functions and I think the agstudy/eddi responses would probably do this, but I thought trying it from scratch might be instructive:
poly.maker <- function(coefs) { func <- function(x){} #empty func in x
body(func) <- parse(text= paste( seq_along(coefs),"*x^",
(length(coefs)-1):0,collapse="+" ) )
return(func) }
func2 <- poly.maker(c(1,2,3)) # return a function
func2(3) # now test it out
#[1] 18
Note I needed to swap the order to agree with the OP request, which I only noticed after getting different results than #dickoa. This seems less clunky:
poly.make2 <- function(coefs) { func <- function(x){}
body(func) <- bquote(sum(.(coefs)*x^.( (length(coefs)-1):0 ) ) )
return(func) }
func <- poly.make2(c(1,2,5))
func
#function (x)
#sum(c(1, 2, 5) * x^c(2L, 1L, 0L))
#<environment: 0x29023d508>
func(3)
#[1] 20
One liner:
polymaker2 <- function(coefs)
{
eval(parse(text=paste0( "function(x) sum(x^(",length(coefs)-1,":0) * ",capture.output(dput(coefs)),")" )))
}
Vectorized form:
polymaker3 <- function(coefs)
{
eval(parse(text=paste0( "function(x) colSums(t(outer(x, ",length(coefs)-1,":0, `^`))*",capture.output(dput(coefs)),")" )))
}