There're two kinds of evaluation in my program, and first one is
def approx(bs, delta, n, params):
"""Approximate option price using the first n terms of the Ito-Taylor series"""
t, s, v, r, K, v0, kappa, theta, sig, rho = params
deltas_expression = sum(
delta[i] * t ** (i + 1) / factorial(i + 1) for i in range(n + 1)
)
deltas_numerical = numerical_approx(
deltas_expression(
t=t, s=s, v=v, r=r, K=K, v0=v0, kappa=kappa, theta=theta, sig=sig, rho=rho
)
)
bs_numerical = bs(S=s, K=K, T=t, r=r, sigma=np.sqrt(v0))
return bs_numerical + deltas_numerical
Second one is using fast_callable:
def approx2(bs, delta, n, params):
t, s, v, r, K, v0, kappa, theta, sig, rho = params
deltas_expression = sum(
delta[i] * t ** (i + 1) / factorial(i + 1) for i in range(n + 1)
)
fast_delta = fast_callable(
deltas_expression,
vars=("t", "s", "v", "r", "K", "v0", "kappa", "theta", "sig", "rho"),
domain=RR,
)
delta_numerical = fast_delta(*params)
bs_numerical = bs(S=s, K=K, T=t, r=r, sigma=np.sqrt(v0))
return bs_numerical + delta_numerical
With the same task, the first version uses 2 seconds, while the second one uses 28.9 seconds.
I tried to use different domain but it doesn't work.
Related
I am solving a system of differential equations with the RK4 method but the outcome performs bad towards the end iteration. The problem seems to be with the eq11 of my function l(lna,x,y,m,xi,yi) since the term (np.float64(1)-np.power(x,2)-np.power(y,2))->0 and np.exp(3*(lna-lnai))->\infty towards the end state.
The code I wrote is,
import numpy as np
import matplotlib.pyplot as plt
q = 1
def l(lna,x,y,m,xi,yi):
eq11 = (np.float64(1)-np.power(x,2)-np.power(y,2))*np.exp(3*(lna-lnai))
denom= (yi**2)*eq11
num = (y**2)*(1-xi**2-yi**2)
eq1 = np.divide(num,denom)
eq2 = (eq1)**(1/n)
return n * (m**(-1)) * eq2
def f1 (x,y,l):
return -3*x + l*np.sqrt(3/2)* y**2+ 3/2 *x*(2*(x**2)+q*(1-x**2-y**2))
def f2 (x,y,l):
return -l*np.sqrt(3/2) *y*x + 3/2 *y*(2*x**2+q*(1-x**2-y**2))
def R_K_4(xi,yi,m):
N = int(round((lnaf-lnai)/dlna))
lna = np.linspace(lnai, lnaf, N+1)
x = np.empty(N+1)
y = np.empty(N+1)
x[0],y[0] = xi,yi
for i in range(0,N):
kx1 = dlna * f1( x[i], y[i], l( lna[i], x[i], y[i], m, xi, yi) )
ky1 = dlna * f2( x[i], y[i], l( lna[i], x[i], y[i], m, xi, yi) )
kx2 = dlna * f1( x[i]+kx1/2, y[i]+ky1/2, l( lna[i]+dlna/2, x[i]+kx1/2, y[i]+ky1/2, m, xi, yi) )
ky2 = dlna * f2( x[i]+kx1/2, y[i]+ky1/2, l( lna[i]+dlna/2, x[i]+kx1/2, y[i]+ky1/2, m, xi, yi) )
kx3 = dlna * f1( x[i]+kx2/2, y[i]+ky2/2, l( lna[i]+dlna/2, x[i]+kx2/2, y[i]+ky2/2, m, xi, yi) )
ky3 = dlna * f2( x[i]+kx2/2, y[i]+ky2/2, l( lna[i]+dlna/2, x[i]+kx2/2, y[i]+ky2/2, m, xi, yi) )
kx4 = dlna * f1( x[i]+kx3, y[i]+ky3, l( lna[i]+dlna, x[i]+kx3, y[i]+ky3, m, xi, yi) )
ky4 = dlna * f2( x[i]+kx3, y[i]+ky3, l( lna[i]+dlna, x[i]+kx3, y[i]+ky3, m, xi, yi) )
x[i+1] = x[i] +1/6*(kx1 + 2*kx2 + 2*kx3 + kx4)
y[i+1] = y[i] +1/6*(ky1 + 2*ky2 + 2*ky3 + ky4)
return x,y,lna
#Parameters and step size:
n = 0.1
dlna = 1e-3
# Initial and final times:
lnai, lnaf = -2, 17
# Calling the funtion RK4:
x1, y1, lna = R_K_4(np.sqrt(n/(n+4))*10**(-5), 10**(-5), 0.1)
w1 = np.divide((x1**2-y1**2),(x1**2+y1**2))
plt.plot(lna, w1, label='w1')
plt.xlabel('x')
plt.ylabel('y')
plt.grid()
plt.legend()
plt.show()
If I run it, I will get the following result and there is a bump towards y =-1 :
I have to find 6 errors in the following code and I think I found three already, which are in p and q sample and the brakes in Y.
I changed them to:
p = sample(1:6, 1)
q = sample(1:6, 1)
Y = y[(n + 1)(2*n)]
and got the following error message afterwards:
Error in err[(t - 1):(p - q)] :
only 0's may be mixed with negative subscripts
Can you help me fix this and find the other errors?
Also I have to delete one unnecessary variable from rm (at the last line)
myMatrikel = 7081255
{
n = 500
set.seed(myMatrikel)
p = sample(1:6, n = 1)
q = sample(1:6, n = 1)
alpha = round(runif(q, min = 0, max = 1/q), digits = 3)
beta = round(runif(p, min = 0, max = 1/p), digits = 3)
initY = rnorm(max(p, q))
initErr = rnorm(max(p, q))
y = err = 1:(2*n)*0
y[1:max(p, q)] = initY
err[1:max(p, q)] = initErr
for (t in (max(p, q) + 1):length(y))
{
err[t] = rnorm(1)
y[t] = beta %*% y[(t - 1):(t - p)] + alpha %*% err[(t - 1):(p - q)] + Err[t]
}
Y = y[(n + 1)(2*n])
}
rm(list = c("err", "initErr", "initY", "y", "t", "myMatrikel"))
Here's an idea, how to narrow it down:
for (t in (max(p, q) + 1):length(y)) {
if (t %% 50) cat(t, "\n")
else cat(t)
err[t] = rnorm(1)
y[t] = beta %*% y[(t - 1):(t - p)] + alpha %*% err[(t - 1):(p - q)] + Err[t]
}
This way you can see at which iteration the error occurs and look at the specific values of that iteration. Then might easier able to see, what is causing the error.
I was using the NLoptr package for solving an optimization problem of a 9 variables cost function using the program as:
function(x){return( list( "objective" = 0.0404*x[1]^2 + 4.4823*x[1] + 0.4762+0.024*x[2]^2 + 3.9767*x[2] + 0.3737+0.0246*x[3]^2 + 3.6992*x[3] + 0.9425+0.0214*x[4]^2 + 3.5896*x[4] + 0.7615+0.0266*x[5]^2 + 3.8197*x[5] + 0.2799+0.0262*x[6]^2 + 3.7884*x[6] + 0.307+0.0362*x[7]^2 + 4.4927*x[7] + 0.1549+0.0344*x[8]^2 + 4.4066*x[8] - 0.2472+0.0241*x[9]^2 + 4.227*x[9],"gradient" = c(2*0.0404*x[1]+4.4823, 2*0.024*x[2]+3.9767, 2*0.0246*x[3], 2*0.0214*x[4]+3.5896, 2*0.0266*x[5]+3.8197,2*0.0262*x[6]+3.7884,2*0.0362*x[7]+4.4927, 2*0.0344*x[8]+4.4066, 2*0.0241*x[9]+4.227)))}
function( x ) {
constr <- c(x[1] + x[2]+ x[3] + x[4]+x[5]+x[6]+x[7]+x[8]+x[9]-Balance)
grad <- c(1,1,1,1,1,1,1,1,1)
return( list( "constraints"=constr, "jacobian"=grad ) )
}
lb<-c(50,50,50,50,50,50,50,50,50)
ub<-c(0,0,0,0,0,0,0,0)
x_0<-c(25,25,25,25,25,25,25,25,25)
local_opts <- list( "algorithm" = "NLOPT_LD_MMA","xtol_rel" = 1.0e-9 )
opts <- list( "algorithm" = "NLOPT_LD_AUGLAG","xtol_rel" = 1.0e-9,"maxeval" = 10000, "local_opts" = local_opts )
res <- nloptr(x0=x_0, eval_f=eval_f,lb=lb,ub=ub,eval_g_eq=eval_g_eq,opts=opts)
The code works fine but the problem is that I need to solve this optimization for a period of 168h and each time step the lower bounds and upper bounds have to be different. Has anyone implemented this before?
BR
I highly suggest you to use OSQP for that. You can download it from CRAN. You can find an example for updating the problem vectors in the manual. I have rewritten it here:
library(Matrix)
# Define problem data in the form
# minimize (1/2) x' P x + q' x
# subject to l <= A x <= u
#
P <- Matrix(c(11., 0., 0., 0.), 2, 2, sparse = TRUE)
q <- c(3., 4.)
A <- Matrix(c(-1., 0., -1., 2., 3., 0., -1., -3., 5., 4.), 5, 2, sparse = TRUE)
u <- c(0., 0., -15., 100., 80)
l <- rep_len(-Inf, 5)
settings <- osqpSettings(verbose = FALSE)
model <- osqp(P, q, A, l, u, settings)
# Solve
res <- model$Solve()
# Get solution
x_opt <- res$x
# Define new vector
q_new <- c(10., 20.)
# Update model and solve again
model$Update(q = q_new)
res <- model$Solve()
# Get new solution
x_opt_new <- res$x
Disclamer: I am one of the OSQP authors.
This question already has an answer here:
Reducing nested for loop to single loop in R
(1 answer)
Closed 5 years ago.
I have developed a simulation, which can be quite slow (up to 6 hours), depending on values of input parameters.
Profiling my code reveals that sample() is the bottleneck, but from my knowledge, there is no better function (sample() is already optimized for maximal speed since it is written in C).
Parallelization will not work either since algorithm iterations are dependent on one another.
Any suggestions on alternatives to improve runtime?
Any advice is warmly welcomed.
Below is my simulation code:
Haplotype Accumulation Curve Simulator
HAC.sim <- function(K = 1, N, Hstar, probs, m = 0, perms = 10000, p = 0.95){
pop <- array(dim = c(c(perms, ceiling((1 - m) * N / K)), K))
haps <- as.character(1:Hstar)
specs <- 1:ceiling((1 - m) * N / K)
for (j in 1:perms){
for (i in 1:K){
pop[j, specs, i] <- sample(haps, size = length(specs), replace = TRUE, prob = probs)
}
}
HAC.mat <- array(dim = c(c(perms, length(specs), K)))
for (k in specs){
for (j in 1:perms){
for (i in 1:K){
ind.index <- sample(specs, size = k, replace = FALSE)
hap.plot <- pop[sample(1:nrow(pop), size = 1, replace = TRUE), ind.index, sample(i, size = 1, replace = TRUE)]
HAC.mat[j, k, i] <- length(unique(hap.plot))
}
}
}
means <- apply(HAC.mat, MARGIN = 2, mean)
lower <- apply(HAC.mat, MARGIN = 2, function(x) quantile(x, 0.025))
upper <- apply(HAC.mat, MARGIN = 2, function(x) quantile(x, 0.975))
d <- assign("d", data.frame(specs, means), envir = .GlobalEnv)
P <- max(means)
Q <- Hstar - max(means)
R <- assign("R", max(means) / Hstar, envir = .GlobalEnv)
S <- (Hstar - max(means)) / Hstar
Nstar <- assign("Nstar", (N * Hstar) / max(means), envir = .GlobalEnv)
X <- ((N * Hstar) / max(means)) - N
cat("\n Measures of Sampling Closeness \n \n Mean number of haplotypes sampled: " , P, "\n Mean number of haplotypes not sampled: " , Q, "\n Proportion of haplotypes sampled: " , R, "\n Proportion of haplotypes not sampled: " , S, "\n \n Calculated mean value of N*: ", Nstar, "\n Mean number of individuals not sampled: ", X, "\n \n")
if (R < p){
cat("Desired level of H* has not yet been reached \n")
} else{
cat("Desired level of H* has been reached")
}
par(mfrow = c(1, 2))
plot(specs, means, type = "n", xlab = "Specimens sampled", ylab = "Unique haplotypes", ylim = c(1, Hstar))
polygon(x = c(specs, rev(specs)), y = c(lower, rev(upper)), col = "gray")
lines(specs, means, lwd = 2)
HAC.bar <- barplot(length(specs) * probs, xlab = "Unique haplotypes", ylab = "Specimens sampled", names.arg = 1:Hstar)
}
A quick reproducible example
N <- 50
Hstar <- 5
probs <- rep(1/Hstar, Hstar)
HAC.sim(N = N, Hstar = Hstar, probs = probs)
Sure, Rcpp is an option but would require you to rewrite parts of your code in C++. One non-invasive option is to use the compiler package that can offer some speed improvements with minimal effort:
#old R version of lapply
slow_func <- function(X, FUN, ...) {
FUN <- match.fun(FUN)
if (!is.list(X))
X <- as.list(X)
rval <- vector("list", length(X))
for(i in seq(along = X))
rval[i] <- list(FUN(X[[i]], ...))
names(rval) <- names(X) # keep `names' !
return(rval)
}
# Compiled versions
require(compiler)
slow_func_compiled <- cmpfun(slow_func)
You can read more about it here. However, if the only issue is sample it looks like Rcpp has an alternative implemention. It looks like it is not faster in all cases though.
I have created a user defined function as follows:
HAC.sim(K = 1, N, Hstar, m = 0, probs, perms, p = 0.95)
and within the body of this function, I would like to put the following 'while' loop (because I want to eventually create a package for easy use).
while(R < p){
HAC.sim(K = 1, N = Nstar, Hstar, m = 0, probs, perms, p = 0.95)
}
R is a variable that is defined in the main function body.
The problem is that the 'while' loop is not breaking when the condition is met (i.e., the moment when R < p).
My routine works (i.e., it breaks successfully) when the 'while' loop is placed outside of the function, but fails when I place it within the main function body.
I have also tried implementing a repeat loop with break, but the same problem occurs.
Any ideas on how I can fix the issue?
Here is the full function (quite long)
HAC.sim <- function(K = 1, N, Hstar, probs, m = 0, perms = 10000, p = 0.95){
### Set up a container to hold the identity of each individual from each permutation
pop <- array(dim = c(c(perms, ceiling((1 - m) * N / K)), K))
### Create an ID for each haplotype
haps <- as.character(1:Hstar)
### Generate permutations, we assume each permutation has Npop individuals, and we sample those individuals' haplotypes from the probabilities
specs <- 1:ceiling((1 - m) * N / K)
for(j in 1:perms){
for(i in 1:K){
pop[j, specs, i] <- sample(haps, size = ceiling((1 - m) * N / K), replace = TRUE, prob = probs)
}
}
### Make a matrix to hold the 1:N individuals from each permutation
HAC.mat <- array(dim = c(c(perms, ceiling((1 - m) * N / K)), K))
for(k in specs){
for(j in 1:perms){
for(i in 1:K){
ind.index <- sample(specs, size = k, replace = FALSE) ## which individuals will we sample
hap.plot <- pop[sample(1:nrow(pop), size = 1, replace = TRUE), ind.index, sample(i, size = 1, replace = TRUE)] ## pull those individuals from a permutation
HAC.mat[j, k, i] <- length(unique(hap.plot)) ## how many haplotypes did we get for a given sampling intensity (j) from each permutation (i)
}
}
}
### Calculate the mean and CI for number of haplotypes at each sampling intensity (k)
means <- apply(HAC.mat, MARGIN = 2, mean)
lower <- apply(HAC.mat, MARGIN = 2, function(x) quantile(x, 0.025))
upper <- apply(HAC.mat, MARGIN = 2, function(x) quantile(x, 0.975))
assign("d", data.frame(specs, means), envir = .GlobalEnv)
### Compute Measures of Sampling Closeness
P <- max(means)
Q <- Hstar - max(means)
R <- assign("R", max(means) / Hstar, envir = .GlobalEnv)
S <- (Hstar - max(means)) / Hstar
Nstar <- assign("Nstar", (N * Hstar) / max(means), envir = .GlobalEnv)
X <- ((N * Hstar) / max(means)) - N
cat("\n Input parameters \n \n Number of (sub)populations: ", K, "\n Number of individuals: ", N, "\n Number of haplotypes: ", Hstar, "\n Haplotype distribution: ", probs, "\n Migration rate: ", m, "\n Number of permutations: ", perms, "\n Proportion of haplotypes to recover: ", p, "\n \n \n Measures of Sampling Closeness \n \n Mean number of haplotypes sampled: " , P, "\n Mean number of haplotypes not sampled: " , Q, "\n Proportion of haplotypes sampled: " , R, "\n Proportion of haplotypes not sampled: " , S, "\n \n Calculated mean value of N*: ", Nstar, "\n Mean number of individuals not sampled: ", X, "\n \n")
if(R < p){
cat("Desired level of H* has not yet been reached")
} else{
cat("Desired level of H* has been reached")
}
### Plot the curve and frequency barplot
par(mfrow = c(1, 2))
plot(specs, means, type = "n", xlab = "Specimens sampled", ylab = "Unique haplotypes", ylim = c(1, Hstar))
polygon(x = c(specs, rev(specs)), y = c(lower, rev(upper)), col = "gray")
lines(specs, means, lwd = 2)
HAC.bar <- barplot(ceiling((1 - m) * N / K)*probs, xlab = "Unique haplotypes", ylab = "Specimens sampled", names.arg = 1:Hstar)
while(R < p){
HAC.sim(K = K, N = ceiling(Nstar), Hstar = Hstar, probs = probs, m = m, perms = perms, p = p)
}
}
### Run simulation
HAC.sim(K = K, N = N, Hstar = Hstar, probs = probs, m = m, perms = perms, p = p)