This is the function I need to create in R
I have used ifelse for the first parts, but I am not quite sure how to input the third of the three equations in the piece-wise function
Personally, I would avoid using ifelse here because the the function is recursive. It needs to be defined for the atomic case and then vectorized:
g <- function(x, alpha= 0.001) {
g_single <- function(x, alpha) {
if(x <= 10^-4) return(0)
if(x >= 0.5) return(1 - g_single(1 - x, alpha))
return(2^alpha * x^(1 + alpha))
}
sapply(x, g_single, alpha = alpha)
}
g(runif(10))
#> [1] 0.7320931 0.9902868 0.8253122 0.5982243 0.2137887 0.6439024
#> [7] 0.8232719 0.3756205 0.2926292 0.4411532
Below is an analytical expression of function g
g <- function(x,a = 0.001) {
2**a*x**(1+a)*(x>=1e-4 & x <= 0.5) + (1-2**a*(1-x)**(1+a))*(x>0.5 & x <= 1-1e-4) + 1*(x>1-1e-4)
}
where a is an optional argument, set to some value by default.
You can pass a vector x to g to get a vectorized output, e.g.,
> g(runif(10))
[1] 0.26534066 0.37201400 0.57292063 0.90836325 0.20149890 0.89855147
[7] 0.94479693 0.66092938 0.62922482 0.06165721
Related
I'm trying to code the following continuous function in R Programming.
I was trying to create a function called fun1 that takes a single argument vecA. I want the function to return the values of f(x) evaluated at the values of vecA.
fun1(vecA) <- function(x){
x^2+2x+3
}
I don't know how I can continue it.
Ideally your function should be able to take vectorized input, in which case you should use ifelse or case_when.
For example:
f <- function(x) {
ifelse(x < 0, x^2 + 2*x + 3,
ifelse(x >= 2, x^2 + 4 * x - 7,
x + 3))
}
Or
f <- function(x) {
dplyr::case_when(x < 0 ~ x^2 + 2*x + 3,
x > 2 ~ x^2 + 4 * x - 7,
TRUE ~ x + 3)
}
both of which produce the same output. We can see what the function looks like by doing:
plot(f, xlim = c(-5, 5))
Created on 2022-09-25 with reprex v2.0.2
Try studying the patterns here:
fun1 <- function(x){
if (x < 0) {
x^2+2*x+3
} else if (x < 2) {
x + 3
} else {
# Your turn
}
}
I'm trying to get the following function to work for windsorizing attributes but I can't get the if elseif working in a function. It gives the following error: "the condition has length > 1 and only the first element will be used". I'm hoping someone can suggest a solution or alternative.
Example:
x <- data.frame(runif(100, 0, 100))
colnames(x) <- "test"
WINSORIZE <- function(x){
WIN_MEAN <- mean(x)
WIN_SD <- sd(x)
WIN_UPPER <- sum(WIN_MEAN + (3 * WIN_SD))
WIN_LOWER <- sum(WIN_MEAN - (3 * WIN_SD))
if(x > WIN_UPPER){
WIN_UPPER
} else if (x < WIN_LOWER) {WIN_LOWER
} else x
}
WINSORIZE(x$test)
Solution
Use R's immanent vectorized ability. Select by [ and change the value by <- assignment.
This solution is very R-ish:
winsorize <- function(x) {
m <- mean(x)
s <- sd(x)
u <- m + 3 * s
l <- m - 3 * s
x[ x > u ] <- u # select elements > u and assign to them u in situ
x[ x < l ] <- l # select elements < l and assign to them l in situ
x # return the resulting vector
}
And also this solution is very R-ish with the already vectorized ifelse() function:
winsorize <- function(x) {
m <- mean(x)
s <- sd(x)
u <- m + 3 * s
l <- m - 3 * s
ifelse( x > u, u, ifelse( x < l, l, x))
}
Solution with sapply()
Another possibility is to use sapply(x, ...) to apply your if-else constructs on each element of x.
winsorize <- function(x){
m <- mean(x)
s <- sd(x)
upper <- m + 3 * s
lower <- m - 3 * s
# apply your if-else construct on each individual element (el) of x
# using `sapply()`
sapply(x, function(el) if(el > upper){
upper
} else if (el < lower) {
lower
} else {
el})
}
Or the same with ifelse():
winsorize <- function(x){
m <- mean(x)
s <- sd(x)
upper <- m + 3 * s
lower <- m - 3 * s
sapply(x, function(el)
ifelse(el > upper, upper, ifelse(el < lower, lower, el))
}
Solution with Vectorize()
Or make a function out of your if-else construct, vectorize this function using Vectorize() before you apply it on x:
winsorize <- function(x){
m <- mean(x)
s <- sd(x)
upper <- m + 3 * s
lower <- m - 3 * s
# define function for one element
winsorize.one.element <- function(el) {
if(el > upper){ upper } else if (el < lower) { lower } else { el}
}
# Vectorize this function
winsorize.elements <- Vectorize(winsorize.one.element)
# Apply the vectorized function to the vector and return the result
winsorize.elements(x)
}
This winsorize.one.element function can be written neater by ifelse,
but although ifelse is vectorized
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
This calculates the log of (x-1)! to return the lgamma(x) value of an integer but my function log_gamma works only till x = 171 for x > 171 it returns Inf. How can I solve this problem?
log_gamma <- function(x){
y <- 1
if (x < 1)(
return("Infinity")
)
if (x == 1)(
return(0)
)
x <- x-1
for (i in 1:x){
y <- y*i
}
return(log(y))
}
Your current solution first computes 171! which is a pretty big number. Instead, use the fact that log(a*b) = log(a) + log(b) to compute this as a sum.
log_gamma <- function(x){
y <- 1
if (x < 1)(
return("Infinity")
)
if (x == 1)(
return(0)
)
x <- x-1
for (i in 1:x){
y <- y + log(i)
}
return(y)
}
log_gamma(171)
[1] 707.5731
log_gamma(172)
[1] 712.7147
log_gamma(1000)
[1] 5906.22
I'm new to R, and I'm trying to code a function which requires it only chooses values in a certain interval, so I have decided to go with k=1 if it lies in [lower, upper] and 0 if it lies elsewhere (where lower and upper have been defined earlier in the function. However, when I try to assign values to the function, it always comes back with this
myfun(10,0.5,0.05)
#Error in k[i] <- function(p) ifelse(p >= lower & p <= upper, 1, 0) :
# incompatible types (from closure to double) in subassignment type fix
I don't really know what this means, I've tried finding an answer, but most pages just say how to fix their particular problem rather than saying what it actually means. Maybe I haven't been looking hard enough, and I apologise if I haven't, but any help would be greatly appreciated. Here is the full function, if it would help:
myfun <- function(a, q, m) {
k <- rep(0,a+1)
bin.prob <- rep(0,a+1)
for (i in 1:(a+1)) {
x <- i-1
qhat <- x/a
z <- qnorm(1-m/2)
upper <- qhat+(z*sqrt(qhat*(1-qhat)*(a^-1)))
lower <- qhat-(z*sqrt(qhat*(1-qhat)*(a^-1)))
k[i] <- function(q) ifelse(q>=lower & q<=upper, 1, 0)
bin.prob[i] <- dbinom(x,a,q)
}
C <- sum(k*bin.prob)
return(C)
}
myfun(10,0.5,0.05)
#Error in k[i] <- function(q) ifelse(q >= lower & q <= upper, 1, 0) :
# incompatible types (from closure to double) in subassignment type fix
NEW PROBLEM
Hey, I'm encountering a new problem when trying to adjust this function when trying to adjust the data set, i.e a becomes a+4 and x becomes x+2
> myfun2 <- function(a,q,m) {
+ fn <- function(a) a+4
+ abar <- fn(a)
+ kadj <- rep(0,abar+1)
+ bin.prob.adj <- rep(0,abar+1)
+ for (j in 1:(abar+1)) {
+ x <- j-1
+ fx <- function(x) x+2
+ xbar <- fx(x)
+ qhatadj <- xbar/abar
+ z <- (1-(m/2))
+ upperadj <- qhatadj+(z*sqrt(qhatadj*(1-qhatadj)*(abar^-1)))
+ loweradj <- qhatadj-(z*sqrt(qhatadj*(1-qhatadj)*(abar^-1)))
+ kadj[j] <- q>=loweradj & q<=upperadj
+ bin.prob.adj[j] <- dbinom(xbar,abar,q)
+ }
+ D <- sum(kadj*bin.prob.adj)
+ return(D)
+ }
> myfun2(10,0.5,0.05)
[1] NA
Warning messages:
1: In sqrt(qhatadj * (1 - qhatadj) * (abar^-1)) : NaNs produced
2: In sqrt(qhatadj * (1 - qhatadj) * (abar^-1)) : NaNs produced
3: In sqrt(qhatadj * (1 - qhatadj) * (abar^-1)) : NaNs produced
4: In sqrt(qhatadj * (1 - qhatadj) * (abar^-1)) : NaNs produced
I've been trying to find an answer as to why this has arised, and have found that the NaNs warning could mean there is a negative square root? However I can't see why that would have arisen. It may be bad coding on my part, or could be something else entirely (I'm new to R). Thanks for any help.
As the error message suggests, the problem starts at the line:
k[i] <- function(q) ifelse(q >= lower & q <= upper, 1, 0)
In the line above you are assigning a function function(q) ifelse(q >= lower & q <= upper, 1, 0) to each element of the vector k, when you really want to be assigning the result of evaluating this function on the scalar q given as an argument to the original function. Note also that the closure function(q) has an environment separate from that of the function in which it is defined. It must be explicitly called with an argument in order for it to evaluate. Hence, when you hit the line:
C <- sum(k * bin.prob)
R tries to multiply the function function(q) itself by bin.prob, throwing an error, when what you want to be doing is multiplying the result of evaluating function(q) for the scalar q defined in the arguments to the original function. In this case, there appears to be no need for you to define function(q) at all. The assignment can be replaced with:
k[i] <- ifelse(q >= lower & q <= upper, 1, 0)
Since R coerces logical vectors to numeric vectors where necessary, treating TRUE as 1 and FALSE as 0, the above assigment can be expressed more succinctly as:
k[i] <- q >= lower & q <= upper