I was trying to prove there that a certain function cannot go negative. As I did not manage to make the proof, and also to convince myself that it is true, I coded the function as follows:
test = function(s,t){
# s is a vector of positives reals of length d
# t is a vector of complexes of length d-1
d = length(s)
t = c(t, (1-sum(t*s[1:(d-1)]))/s[d])
modulii = abs((t+1)/(t-1))
return(max(modulii)-1)
}
# I want to minimize this test function over all
# s positive reals of length d
# t complex of length d-1.
# How can i do that ?
# simple starting points:
d = 3
s = runif(d)
t = complex(real = runif(d-1),imaginary = runif(d-1))
test(s,t) # should be positive.
How can I code an optimization routine that minimize this function with respect to :
s[1],...s[d] all non-negative reals, with s[d] strictly positive.
t[1],...,t[d-1] all complex valued.
?
I struggle with optim and complex numbers. I want to be sure that the minimum cannot be negative ;)
Define a function proj which takes a vector of length 3*d-2 and produces a list with s and t from it squaring the first d elements to form s and taking the next d-1 and following d-1 elements as the real and imaginary parts of t. Then define f to run proj and pass the result to test and run.
d <- 3
proj <- function(x) {
d <- (length(x) + 2) / 3
list(s = head(x, d)^2, t = complex(x[seq(d+1, length = d-1)], tail(x, d-1)))
}
f <- function(x) with(proj(x), test(s, t))
result <- optim(rep(0.5, 3*d-2), f)
result
## $par
## [1] 1.0863555573 5.9011341467 -0.0009866435 -0.1252050359 1.0720624611
## [6] -0.3826544395 -6.2322265938
##
## $value
## [1] 8.911303e-09
##
## $counts
## function gradient
## 188 NA
##
## $convergence
## [1] 0
##
## $message
## NULL
proj(result$par)
## $s
## [1] 1.180168e+00 3.482338e+01 9.734655e-07
##
## $t
## [1] -0.3826544+0i -6.2322266+0i
Related
I am using a simple polynomial to fit a curve.
poly <- function(a, b, c, x) a * x^2 + b * x + c
I'd like to find the value of x that results in the maximum value of the curve. Currently I create a grid with a range of x from 20000 to 50000, run the function for each row, then use max() on the result. It works, but I have a lot of groups and it creates a big dataframe every time I do it. It is very clunky and I feel like there must be a better way.
Some typical coefficients are:
a <- -0.000000179
b <- 0.011153167
c <- 9.896420781
If you rearrange your function so the variable you want to maximize is first and you set the default values like so:
poly <- function(x, a, b, c) a * x^2 + b * x + c
formals(poly)$a <- -0.000000179
formals(poly)$b <- 0.011153167
formals(poly)$c <- 9.896420781
Then you can use the optimize function to maximize over your interval:
optimize(poly, c(20000, 50000), maximum = T)
$`maximum`
[1] 31154.1
$objective
[1] 183.6298
Where $maximum is the x value at which the maximum occurs and $objective is the height.
If a is negative, maximum of parabola a * x^2 + b * x + c is reached at -b/(2*a) :
a<0
#[1] TRUE
-b/(2*a)
#[1] 31154.1
You could use optim. I think the other solutions answered in this thread are more appealing, but I'll write this up for completeness:
a <- -0.000000179
b <- 0.011153167
c <- 9.896420781
o <- optim(
par=list(x=0),
fn=function(x){ -poly(a,b,c,x=x) },
method="Brent",
lower=-50e3, upper=50e3
)
Output:
> o
$par
[1] 31154.1
$value
[1] -183.6298
$counts
function gradient
NA NA
$convergence
[1] 0
$message
NULL
I'd like to minimize several differences. For one difference, this seems straight forward:
target1 <- 1.887
data <- seq(0,1, by=.001)
#Step 1
somefunction <- function(dat, target1, X){
#some random function...
t <- sum(dat)
y <- t * X
#minimize this difference
diff <- target1-y
return(diff)
}
V1 <- optimize(f = somefunction,
interval = c(0,1),
dat=data,
target1=target,
maximum = T)
V1$maximum
6.610696e-05
#--> This value for `X` should minimize the difference...
V1$maximum * sum(data)
#0.03308653
#--> as close to zero we get
Now, I'd like to minimize several differences in one step relying on optim but this does not work properly:
#Step 2
set.seed(1)
data2 <- data.frame(dat1=seq(0,1, by=.01),
dat2=runif(101),
dat3=runif(101))
somefunction_general <- function(dat, target1, target2, target3, X){
#some random function...
y <- sum(dat[,1]) * X[1]
y1 <- sum(dat[,2]) * X[2]
y2 <- sum(dat[,3]) * X[3]
#minimize these differences...
diff1 <- target1-y
diff2 <- target2-y1
diff3 <- target3-y2
#almost certain that this is wrong...
vtr <- sum(abs(diff1), abs(diff2), abs(diff3))
return(vtr)
}
V2 <- optim(par=c(1,1,1),
fn = somefunction_general,
dat=data2,
target1=1.8,
target2=2,
target3=4,
control = list(fnscale = -1))
sum(data2[,1])
[1] 50.5
sum(data2[,2])
[1] 44.27654
sum(data2[,3])
[1] 51.73668
V2$par[1]*sum(data2[,1])
#[1] 1.469199e+45
V2$par[2]*sum(data2[,2])
#[1] 1.128977e+45
V2$par[3]*sum(data2[,3])
[1] 2.923681e+45
Looks like there's some disagreement between the first function and the second? In the first function, you're returning target1-sum(dat)*X and then trying to find the maximum over X values in [0, 1].
But since you're returning the raw difference and not the absolute value, you're actually just maximizing -sum(dat)*X, or, equivalently, minimizing sum(dat)*X. Since the dat is constant, naturally the optimize function is going to return the smallest value on the interval each time (0 in the example).
For the first function, I think what you want to do is return the absolute value of the difference and then find the minimum and not the maximum. The fix for the second function, somefunction_general, is even simpler, since you're already returning sum(abs(diff1), abs(diff2), abs(diff3)): just make sure the minimum is returned by getting rid of control = list(fnscale = -1)
V2 <- optim(par=c(1,1,1),
fn = somefunction_general,
dat=data2,
target1=1.8,
target2=2,
target3=4)
V2$par
[1] 0.03564358 0.03837754 0.07748929
You should write a function such that whether there is one parameter or more, optim should work on it:
somefunction_general <- function(X, dat, target){
dat <- as.matrix(dat)
y <- colSums(dat) * X
sum((target-y)^2) # Often use the MSE
}
let us test this
data2 <- data.frame(dat1=seq(0,1, by=.01),
dat2=runif(101),
dat3=runif(101))
data <- seq(0,1, by=.001)
(a <-optim(0,somefunction_general,dat = data,target = 1.887,method = "BFGS"))
$par
[1] 0.00377023
$value
[1] 3.64651e-28
$counts
function gradient
25 3
$convergence
[1] 0
$message
NULL
We can not that the function value is zero. thus the parameter a$par is what we want. check this out
a$par*sum(data)
[1] 1.887
We can also have 3 parameters 1 target eg:
(b<-optim(c(0,0,0),somefunction_general,dat = data2,target = 1.887))
$par
[1] 0.03736837 0.04262253 0.03647203
$value
[1] 4.579334e-08
$counts
function gradient
100 NA
$convergence
[1] 0
$message
NULL
b$par*colSums(data2)
dat1 dat2 dat3
1.887103 1.887178 1.886942
Each almost got to the target of 1.887. note that this is similar to running the first one 3 times.
lastly:
(d<-optim(c(0,0,0),somefunction_general,dat = data2,target = c(1.8, 2, 4)))
$par
[1] 0.03564672 0.04516916 0.07730660
$value
[1] 2.004725e-07
$counts
function gradient
88 NA
$convergence
[1] 0
$message
NULL
the target was achieved:
d$par*colSums(data2)
dat1 dat2 dat3
1.800160 1.999934 3.999587
This one function can work on n dimensions. please use the method BFGS unless it does not converge.
What if there is one parameter with three targets? well this is quite difficult. Unless there is such a parameter, then it wont converge.
suppose we say the parameter is 0.01, what is the target?
colSums(data2)*0.01
dat1 dat2 dat3
0.5050000 0.4427654 0.5173668
Okay, suppose we were given this target, can we get the 0.01 back?
(e<-optim(10,somefunction_general,dat = data2,target = c(0.505, 0.4427654, 0.5173668),method = "BFGS"))
$par
[1] 0.01
$value
[1] 7.485697e-16
$counts
function gradient
12 3
$convergence
[1] 0
$message
NULL
Huh, we were able to converge. this is because there was a parameter that could take us there. note that i did change the starting point to 10.
here is the list of scores
Scores<-list(T = c(10,8,7,9), M = c(9,10,8,7), L = c(6,8,10), B = c(10,9,10,7,8))
I tried using lapply() function unsuccessfully, I am new to R and just trying to solve some exercise problem. What's the best way to approach this problem
If you are just starting out, this is more difficult because you will likely want to pass what is known as an anonymous function to lapply() as opposed to something readily available like mean. Here is how to do that:
Scores <- list(T = c(10,8,7,9), M = c(9,10,8,7), L = c(6,8,10), B = c(10,9,10,7,8))
lapply(Scores, function(x) diff(range(x)))
# $T
# [1] 3
#
# $M
# [1] 3
#
# $L
# [1] 4
#
# $B
# [1] 3
I tried to create a repeat loop function based on logical case as follow:
n=5 # number of element in lambda
t=10 # limit state
lambda=c(runif(n,2,4)) #vector to be tested
tes=function(x)
{
if(x>=t) {a=0;b=0;c=0}
else
{
repeat
{
a=runif(1,0.5,0.8)
b=runif(1, 5, 8)
c=x+a+b
print(a)
print(b)
if (c>=t) {break}
}
}
return(list(a,b,c))
}
I need to save all of the repeat loop iterations output into an object in the workspace to be used afterwards. however my function only save the latest value of the iterations.
here's the example of iteration for lambda[1]:
The iteration:
[1] 0.6714837
[1] 5.840948
[1] 0.7914275
[1] 7.264076
The saved result in the list:
[[1]]
[[1]][[1]]
[1] 0.7914275
[[1]][[2]]
[1] 7.264076
[[1]][[3]]
[1] 11.03819
how to save each of the result per iterations in the output list?
I’ve looked through other thread, but I haven’t found a suitable solution for my case yet. Thank you.
You can accumulate the results onto a data.frame.
I would also recommend you not assign identifiers like c and t, since those are built-in functions which can be masked by locals, especially if you're passing around functions as arguments, such as do.call(c,...).
I also suggest that it's probably appropriate to pass the limit state variable as another argument to the function.
tes <- function(x,lim) {
res <- data.frame(a=double(),b=double(),c=double());
if (x >= lim) {
res[1L,] <- c(0,0,0);
} else {
i <- 1L;
repeat {
ta <- runif(1L,0.5,0.8);
tb <- runif(1L,5,8);
tc <- x+ta+tb;
res[i,] <- c(ta,tb,tc);
print(ta);
print(tb);
if (tc >= lim) break;
i <- i+1L;
};
};
return(res);
};
Demo:
set.seed(5L);
n <- 5L; ## number of elements in lambda
lambda <- runif(n,2,4); ## vector to be tested
lambda;
## [1] 2.400429 3.370437 3.833752 2.568799 2.209300
res <- lapply(lambda,tes,10);
## [1] 0.7103172
## [1] 6.58388
## [1] 0.7423806
## [1] 7.8695
## [1] 0.5331359
## [1] 5.819855
## [1] 0.647154
## [1] 5.955212
## [1] 0.6677518
## [1] 5.787779
## [1] 0.5605626
## [1] 6.162577
## [1] 0.7663609
## [1] 6.664768
## [1] 0.7526538
## [1] 7.670621
## [1] 0.7162103
## [1] 5.634021
## [1] 0.5677152
## [1] 5.419951
## [1] 0.6439742
## [1] 6.312236
## [1] 0.7897892
## [1] 5.425742
## [1] 0.7864937
## [1] 6.334192
## [1] 0.5178087
## [1] 5.825448
## [1] 0.5093445
## [1] 5.043447
## [1] 0.6461507
## [1] 6.785455
## [1] 0.6793559
## [1] 6.193042
## [1] 0.6190491
## [1] 7.448228
res;
## [[1]]
## a b c
## 1 0.7103172 6.58388 9.694626
## 2 0.7423806 7.86950 11.012310
##
## [[2]]
## a b c
## 1 0.5331359 5.819855 9.723428
## 2 0.6471540 5.955212 9.972803
## 3 0.6677518 5.787779 9.825968
## 4 0.5605626 6.162577 10.093577
##
## [[3]]
## a b c
## 1 0.7663609 6.664768 11.26488
##
## [[4]]
## a b c
## 1 0.7526538 7.670621 10.99207
##
## [[5]]
## a b c
## 1 0.7162103 5.634021 8.559531
## 2 0.5677152 5.419951 8.196967
## 3 0.6439742 6.312236 9.165510
## 4 0.7897892 5.425742 8.424831
## 5 0.7864937 6.334192 9.329986
## 6 0.5178087 5.825448 8.552557
## 7 0.5093445 5.043447 7.762092
## 8 0.6461507 6.785455 9.640906
## 9 0.6793559 6.193042 9.081698
## 10 0.6190491 7.448228 10.276578
You can save the intermediate results in a list, then return it (loop_results). See below. I have also formatted a bit your code so that, intermediate results are printed in a more intelligible/compact way, and the returned list is named.
tes <- function(x) {
if(x>=t) {
a=0;b=0;c=0
} else {
loop_results <- list()
i=0
repeat
{
i <- i+1
a=runif(1,0.5,0.8)
b=runif(1, 5, 8)
c=x+a+b
cat("iteration ", i, "a: ", a, "b: ", b, "\n")
loop_results[[i]] <- list(a=a, b=b, c=c)
if (c>=t) {break}
}
}
return(list(a=a, b=b, c=c, loop_results=loop_results))
}
I took the liberty to add an argument in the function and a "maximum iteration" argument coupled with a warning. i think the optimal result form is the data frame for vectors a, b, and c.
Then, to apply it on a vector, I propose to use an lapply function.
n <- 5 # number of element in lambda
limitstate <- 10 # limit state
lambda <- c(runif(n,2,4)) #vector to be tested
tes <- function(x, t, maxiter = 1000) {
if( x >= t) {
return(data.frame(a=0, b=0, c=0))
} else {
iter <- 1
a <- c()
b <- c()
c <- c()
repeat {
a[iter] <- runif(1, 0.5, 0.8)
b[iter] <- runif(1, 5, 8)
c[iter] <- x + a[iter] + b[iter]
if (c[iter] >= t) break
iter <- iter+1
if (iter >= maxiter) {
warning("Maximum iteration reached")
break
}
}
}
return(data.frame(a=a,b=b,c=c))
}
tes(2, 10)
lapply(lambda, tes, t=limitstate)
A similar problem is faced in this question, that I hope you find useful. So, you should insert a cumulative function inside of your's, as in the following example. It simulate a game where, in case of victory you earn money, otherwise you will lose it. This procedure stores your savings fluctuations during all the process.
x <- y <- 10
while (x > 0) {
if (rbinom(1, 1, 0.5) == 1) {
x <- x + 10
} else {
x <- x - 1
}
y <- c(y, x)
}
Otherwise, if your problem goes on a superior dimensional level, you could try a vectorized approach, which is much faster. But for your problem the approach exposed should be fine.
I have a setup that looks like below
for(V in (seq(1, 250, by = 5))){
for(n in (seq(1, 250, by = 5))){
# 1) Working Algorithm creating a probability
ie. vector in range [0:1]
# 2) Take the natural log of this probability
a <- log(lag(Probability), base = exp(1))
# 3) calculate price differences
b <- abs(diff(Price) -1)
# 4) Then compute correlation between a and b
cor(a, b)
# 5) Here I'd like to save this in the corresponding index of matrix
}
}
So that I get a [V, n] sized matrix as output, that collects from each loop.
I have a few problems with this.
The first problem is that my correlation is not computable, as the Probability is often 0, creating a ln(0) = -Inf input in the ln(Probability) vector. Is there a way to compute the std.dev or cor of a Ln vector with -Inf inputs?
My second question is how I save this correlation output into a matrix generated for each loop?
Thanks for your help. I hope this is clear enough.
For your second question (My second question is how I save this correlation output into a matrix generated for each loop?), you could initialise a matrix before the loop and store each computed correlation in the corresponding index like:
sz <- seq(1, 250, by = 5)
out_mat <- matrix(0, nrow=length(sz), ncol=length(sz))
# then continue with your for-loop
for (V in 1:length(sz)) {
for(n in length(sz)) {
# here instead of accessing V and n in computing probability
# use sz[V] and sz[n]
...
...
# after computing the correlation, here use V and n (not sz[V] or sz[n])
out_mat[V, n] <- c # c holds the value of cor(a,b)
}
}
What you can do with -Inf is replace that by NA, for example:
x = runif(10)
x[3] = 1/0
> is.infinite(x)
[1] FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE
x[is.infinite(x)] <- NA
> x
[1] 0.09936348 0.66624531 NA 0.90689357 0.71578917 0.14655174
[7] 0.59561047 0.41944552 0.67203026 0.03263173
And use the na.rm argument for sd:
> sd(x, na.rm = TRUE)
[1] 0.3126829