Many libraries are available in R to perform minimisation. However, all the ones I could find (e.g. rcgmin, or optimx) only allow lower and upper bounds on the input parameters:
opt_Params <- Rcgmin(par = Params_init,
fn = cost_func,
gr = params_grad,
lower = min_par,
upper = max_par
)
I'm looking for something different: boundaries not on the input parameters, but on the values of a function that takes them.
Concretely, my cost_func is a cost function that measures the sum of the squared residuals between my (fixed) observed data Y_obs and the prediction from my fitted parameters Y_calc:
cost_func <- function(Params) {
X <- Params[1:(num_items*num_features)]
dim(X) <- c(num_items,num_features)
Theta <- Params[(num_items*num_features+1):length(Params)]
dim(Theta) <- c(num_users,num_features)
Y_calc <- X * t(Theta)
J <- ((Y_calc - Y_obs) * (Y_calc - Y_obs))
cost <- sum(rowSums(J)[])
return(cost)
}
Minimising the cost function, I can ensure that my predicted Y_calc get ever closer to Y_obs.
This however allows for arbitrary values in Y_calc. What I would like to do is to impose the same boundaries as I know to be present in Y_obs (between 0 and 10 - this is a collaborative filtering algorithm).
So I'm not trying to put constraints on my input parameters, but on a function of them (namely, on every element of Y_calc <- X * t(Theta)).
Is there an R minimisation library in which this is possible? Or do I need to change my approach?
I think you can try something like this :
library(DEoptim)
cost_func <- function(Params)
{
X <- Params[1 : (num_items * num_features)]
dim(X) <- c(num_items,num_features)
Theta <- Params[(num_items * num_features + 1) : length(Params)]
dim(Theta) <- c(num_users,num_features)
Y_calc <- X * t(Theta)
if((Y_calc < 0) | (Y_calc > 10))
{
return(10 ^ 30)
}else
{
J <- ((Y_calc - Y_obs) * (Y_calc - Y_obs))
cost <- sum(rowSums(J)[])
return(cost)
}
}
DEoptim(par = Params_init,
fn = cost_func,
lower = min_par,
upper = max_par)
If a parameter set generates a value of Y_calc that is between 0 and 10, the objective function will return a very high value. Hence, the DEoptim algorithm will not consider this set of parameters as a candidate solution.
Related
Given a function f(x,c,d) of x that also depends on some parameters c and d. I would like to find the zeroes for a cartesian product of certain values c_1,...,c_n and d_1,...,d_m of the parameters, i.e. an x_ij such that f(x_ij,c_i,d_j)=0 for i=1,...,n and j=1,...,m. Although not that crucial I am applying a Newton-Raphson algorithm for the root finding:
newton.raphson <- function(f, a, b, tol = 1e-5, n = 1000){
require(numDeriv) # Package for computing f'(x)
x0 <- a # Set start value to supplied lower bound
k <- n # Initialize for iteration results
# Check the upper and lower bounds to see if approximations result in 0
fa <- f(a)
if (fa == 0.0){
return(a)
}
fb <- f(b)
if (fb == 0.0) {
return(b)
}
for (i in 1:n) {
dx <- genD(func = f, x = x0)$D[1] # First-order derivative f'(x0)
x1 <- x0 - (f(x0) / dx) # Calculate next value x1
k[i] <- x1 # Store x1
# Once the difference between x0 and x1 becomes sufficiently small, output the results.
if (abs(x1 - x0) < tol) {
root.approx <- tail(k, n=1)
res <- list('root approximation' = root.approx, 'iterations' = k)
return(res)
}
# If Newton-Raphson has not yet reached convergence set x1 as x0 and continue
x0 <- x1
}
print('Too many iterations in method')
}
The actual function that I am interest is more complicated, but the following example illustrates my problem.
test.function <- function(x=1,c=1,d=1){
return(c*d-x)
}
Then for any given c_i and d_j I can easily calculate the zero by
newton.raphson(function(x) test.function(x,c=c_i,d=d_j),0,1)[1]
which here is obviously just the product c_i*d_j.
Now I tried to define a function that finds for two given vectors (c_1,...,c_n) and (d_1,...,d_m) the zeroes for all combinations. For this, I tried to define
zeroes <- function(ci=1,dj=1){
x<-newton.raphson(function(x) test.function(x,c=ci,d=dj),0,1)[1]
return(as.numeric(x))
}
and then use the outer-function, e.g.
outer(c(1,2),c(1,2,3),FUN=zeroes)
Unfortunately, this did not work. I got an error message
Error during wrapup: dims [product 6] do not match the length of object [1]
There might be also a much better solution to my problem. I am happy for any input.
I am re-writting an algorithm I did in C++ in R for practice called the Finite Difference Method. I am pretty new with R so I don't know all the rules regarding vector/matrix multiplication. For some reason I am getting a non-conformable arguments error when I do this:
ST_u <- matrix(0,M,1)
ST_l <- matrix(0,M,1)
for(i in 1:M){
Z <- matrix(gaussian_box_muller(i),M,1)
ST_u[i] <- (S0 + delta_S)*exp((r - (sigma*sigma)/(2.0))*T + sigma*sqrt(T)%*%Z)
ST_l[i] <- (S0 - delta_S)*exp((r - (sigma*sigma)/(2.0))*T + sigma*sqrt(T)%*%Z)
}
I get this error:
Error in sqrt(T) %*% Z : non-conformable arguments
Here is my whole code:
gaussian_box_muller <- function(n){
theta <- runif(n, 0, 2 * pi)
rsq <- rexp(n, 0.5)
x <- sqrt(rsq) * cos(theta)
return(x)
}
d_j <- function(j, S, K, r, v,T) {
return ((log(S/K) + (r + (-1^(j-1))*0.5*v*v)*T)/(v*(T^0.5)))
}
call_delta <- function(S,K,r,v,T){
return (S * dnorm(d_j(1, S, K, r, v, T))-K*exp(-r*T) * dnorm(d_j(2, S, K, r, v, T)))
}
Finite_Difference <- function(S0,K,r,sigma,T,M,delta_S){
ST_u <- matrix(0,M,1)
ST_l <- matrix(0,M,1)
for(i in 1:M){
Z <- matrix(gaussian_box_muller(i),M,1)
ST_u[i] <- (S0 + delta_S)*exp((r - (sigma*sigma)/(2.0))*T + sigma*sqrt(T)%*%Z)
ST_l[i] <- (S0 - delta_S)*exp((r - (sigma*sigma)/(2.0))*T + sigma*sqrt(T)%*%Z)
}
Delta <- matrix(0,M,1)
totDelta <- 0
for(i in 1:M){
if(ST_u[i] - K > 0 && ST_l[i] - K > 0){
Delta[i] <- ((ST_u[i] - K) - (ST_l[i] - K))/(2*delta_S)
}else{
Delta <- 0
}
totDelta = totDelta + exp(-r*T)*Delta[i]
}
totDelta <- totDelta * 1/M
Var <- 0
for(i in 1:M){
Var = Var + (Delta[i] - totDelta)^2
}
Var = Var*1/M
cat("The Finite Difference Delta is : ", totDelta)
call_Delta_a <- call_delta(S,K,r,sigma,T)
bias <- abs(call_Delta_a - totDelta)
cat("The bias is: ", bias)
cat("The Variance of the Finite Difference method is: ", Var)
MSE <- bias*bias + Var
cat("The marginal squared error is thus: ", MSE)
}
S0 <- 100.0
delta_S <- 0.001
K <- 100.0
r <- 0.05
sigma <- 0.2
T <- 1.0
M <- 10
result1 <- Finite_Difference(S0,K,r,sigma,T,M,delta_S)
I can't seem to figure out the problem, any suggestions would be greatly appreciated.
In R, the %*% operator is reserved for multiplying two conformable matrices. As one special case, you can also use it to multiply a vector by a matrix (or vice versa), if the vector can be treated as a row or column vector that conforms to the matrix; as a second special case, it can be used to multiply two vectors to calculate their inner product.
However, one thing it cannot do is perform scalar multipliciation. Scalar multiplication of vectors or matrices always uses the plain * operator. Specifically, in the expression sqrt(T) %*% Z, the first term sqrt(T) is a scalar, and the second Z is a matrix. If what you intend to do here is multiply the matrix Z by the scalar sqrt(T), then this should just be written sqrt(T) * Z.
When I made this change, your program still didn't work because of another bug -- S is used but never defined -- but I don't understand your algorithm well enough to attempt a fix.
A few other comments on the program not directly related to your original question:
The first loop in Finite_Difference looks suspicious: guassian_box_muller(i) generates a vector of length i as i varies in the loop from 1 up to M, and forcing these vectors into a column matrix of length M to generate Z is probably not doing what you want. It will "reuse" the values in a cycle to populate the matrix. Try these to see what I mean:
matrix(gaussian_box_muller(1),10,1) # all one value
matrix(gaussian_box_muller(3),10,1) # cycle of three values
You also use loops in many places where R's vector operations would be easier to read and (typically) faster to execute. For example, your definition of Var is equivalent to:
Var <- sum((Delta - totDelta)^2)/M
and the definitions of Delta and totDelta could also be written in this simplified fashion.
I'd suggest Googling for "vector and matrix operations in r" or something similar and reading some tutorials. Vector arithmetic in particular is idiomatic R, and you'll want to learn it early and use it often.
You might find it helpful to consider the rnorm function to generate random Gaussians.
Happy R-ing!
I have a simple hazard function, the line causing the error is marked.
h <- function(t,u) {
x <- 1 - Sa(t)
y <- 1 - Sm(u)
invx <- as.numeric(qt(x,df=d1))
invy <- as.numeric(qt(x,df=d1))
[ERROR LINE] copula <- pmvt(lower=as.numeric(cbind(-9999,-9999)),upper=cbind(invx,invy),df=d1,corr=matrix(cbind(1,d2,d2,1),byrow=T,ncol=2) )
density <- dmvt(cbind(invx,invy),sigma=matrix(cbind(1,d2,d2,1),byrow=T,ncol=2),df=d1)
num <- (sa(t)*sm(u))*density/dt(invx,df=d1)/dt(invy,df=d1)
den <- 1 - x - y + copula
hazard <- num/den
return(hazard)
}
This hazard function is then called on by a likelihood function:
# log Likelihood function for each individual car i
lli <- function(data) {
result <- 0;
# for all claims, evaluate hazard function at that point
if (nrow(data)> 2) {
for (k in 1:nrow(data)) {
if (data[k,3] == 1) {
result <- result + log(h(data[k,2],data[k,1]));
}
}
}
# integrate hazard function over areas between claims
for (k in 1:(nrow(data)-1)) {
integral <- quad2d(h,data[k,2],data[k+1,2],data[k,1],data[k+1,1]);
result <- result - integral;
}
return(result)
}
Now this likelihood function is then called on by a third function to use over my entire data set; however it is the above function that is causing the error, not the function below
# log Likelihood function over all vehicles
ll <- function(x) {
# Unpack parameters
d1 <<- x[1];
d2 <<- x[2];
total <- 0;
# Get log Likelihood for each vehicle
for (i in 1:length(alldata)) {
total <- total + lli(alldata[[i]]);
#print(sprintf("Found candidate solution %d value: %f",i,total));
}
#print(sprintf("Found candidate solution value: %f",total));
if (is.nan(total)) { #If it is undefined, make it a large negative number
total <- -2147483647 ;
}
return(-1*total); # Minimise instead of maximise
}
Error message is as follows:
> ll(cbind(50,0.923))
Error in checkmvArgs(lower = lower, upper = upper, mean = delta, corr = corr, :
‘diag(corr)’ and ‘lower’ are of different length
I kept getting this same error when using pmvnorm, and ended up having to use the pbivnorm package to get around this. I can't find an alternative package for the bivariate t distribution though. I don't understand what the problem is. When I call the function h(t,u) by itself it executes without a problem. But when lli(data) calls h(t,u), it doesn't work. What's even more bizarre is that they are the same length.
> length(as.numeric(cbind(-9999,-9999)))
[1] 2
> length(diag(matrix(cbind(1,d2,d2,1),byrow=T,ncol=2)))
[1] 2
I apologize for the messy code. I don't use R much. Anyway this has me completely stumped.
Data file is here: https://files.fm/u/yx9pw2b3
Additional code I forgot to include, basically some constants and marginal CDF functions:
Marginals.R:
p1 <- 0.4994485;
p2 <- 0.2344439;
p3 <- 0.1151654;
p4 <- 0.1509421;
b1 <- 0.7044292
t1 <- 1713.3170267
mu1 <- 7.014415
sig1 <- 1.394735
mu2 <- 6.926146
sig2 <- 1.056647
mu3 <- 6.7995896
sig3 <- 0.7212853
b2 <- 0.6444582
t2 <- 762.9962093
b3 <- 1.494303
t3 <- 410.828780
b1 <- 0.903
t1 <- 864.896
b2 <- 0.9109
t2 <- 314.2946
# Marginal survival distribution and density
Sa <- function(t) {return(exp(-(t / t1) ** b1))}
Sm <- function(u) {return(exp(-(u / t2) ** b2))}
sa <- function(t) {return((t / t1) ** b1 * b1 * exp(-(t / t1) ** b1) / t ) }
sm <- function(u) {return((u / t2) ** b2 * b2 * exp(-(u / t2) ** b2) / u ) }
Summary:
The problem is the difference length between lower and upper when calling pvmt, which upper has a length of 2048, while lower has length of 2.
Reasoning:
1. pmvt checks the coming parameters by calling checkmvArgs in mvtnorm package.
2. In checkmvArgs, lower, upper and mean have been put together by rec <- cbind(lower, upper, mean). Here the new data rec has 2048 row instead of 2.
3. lower is then replace by lower <- rec[, "lower"], which lower now has length 2048 instead of 2.
4. Given corr is still a 2 * 2 matrix, error occurs when checking length(corr) != length(lower)
Solution:
invx <- as.numeric(qt(x,df=d1))
invy <- as.numeric(qt(x,df=d1))
upper mean to be a length 2 vector, hence invx and invy needs to be single numbers.
As not sure what's the upper range you want to define, I cannot solve it further. Possible one is :
invx <- as.numeric(qt(x,df=d1))
invy <- as.numeric(qt(x,df=d1))
copula <- pmvt(lower=as.numeric(cbind(-9999,-9999)),upper=range(c(invx,invy)),df=d1,corr=matrix(c(1,d2,d2,1),byrow=T,ncol=2) )
Which is using the range of invx and invy as the input. Hence the dmvt would not be affect.
Note:
As value a is not provided, the next line below (calling dmvt) the error line failed.
Edit:
To make the issue more specific:
1. quad2d will generate a Gauss-Legendre Quadrature which will be created by default a length of 32 on a given range. And,
2. Your function h is then called with the x and y from this Gauss-Legendre Quadrature. Hence, the t and u defined in h is not a single mumber, instead, it is a vector.
I am doing cluster analysis of several time series in R (the sales of a product in different stores).
I am using the first order temporal correlation coefficient CORT(S1,S2), in package TSclust, where S1 and S2 are two time series.
The literaure (https://cran.r-project.org/web/packages/TSclust/TSclust.pdf) explains that CORT belongs to the interval [-1,1]: when CORT(S1,S2)=1 both series show a similar dynamic behavior, and when CORT(S1,S2)=-1 they have opposite behavior.
I would like to know how to see the results of CORT, in order to observe the values of CORT for each pair of time series.
We can see the next example in TSclust package:
## Create three sample time series
x <- cumsum(rnorm(100))
y <- cumsum(rnorm(100))
z <- sin(seq(0, pi, length.out=100))
## Compute the distance and check for coherent results
diss.CORT(x, y, 2)
diss.CORT(x, z, 2)
diss.CORT(y, z, 2)
So with the above code we can calculate de dissimilarity index using the coefficient CORT(S1,S2), but we cannot consult the values of the CORT coefficient.
So, does anyone how to see the values of CORT coefficient in R?
Thanks in advance.
I am not sure if this is what you want, but any how this is what I did:
View(diss.CORT)
where R shows:
function (x, y, k = 2, deltamethod = "Euclid")
{
.ts.sanity.check(x, y)
.check.equal.length.ts(x, y)
corrt <- corrtemporder1(x, y)
type <- (pmatch(deltamethod, c("Euclid", "Frechet", "DTW")))
typedist <- 0
if (is.na(type)) {
stop(paste("Unknown method", deltamethod))
}
else if (type == 1) {
typedist <- as.numeric(dist(rbind(x, y)))
}
else if (type == 2) {
typedist <- diss.FRECHET(x, y)
}
else if (type == 3) {
typedist <- dtw(x, y, dist.method = "Manhattan", distance.only = T)$distance
}
(2/(1 + exp(k * corrt))) * typedist
}
Now if you go through that and start reading the script it seems that you are looking for line where corrt <- corrtemporder1(x, y). google it and you get to: https://github.com/cran/TSclust/blob/master/R/diss.R
#############################################################################
################# Temporal Correlation Distance #########################
#############################################################################
##CHOUAKRIA-DOUZAL
corrtemporder1 <- function (x, y) {
p <- length(x)
sum((x[2:p] - x[1:(p-1)]) * (y[2:p] - y[1:(p-1)])) / ( sqrt( sum((x[2:p] - x[1:(p-1)])^2) ) * sqrt( sum((y[2:p] - y[1:(p-1)])^2) ))
}
Now, I think this is what you are looking for.
So I have a system of ode's and some data I am using the R packages deSolve and FME to fit the parameters of the ode system to data. I am getting a singular matrix result when I fit the full parameter set to the data. So I went back and looked at the collinearity of the parameters using a collinearity index cut-off of 20 as suggested in all the FME package documentation I then picked a few models with subsets of parameters to fit. Then when I run modFit I get this error:
Error in approx(xMod, yMod, xout = xDat) :
need at least two non-NA values to interpolate
Can anyone enlighten me as to a fix for this. Everything else is working fine. So this is not a coding problem.
Here is a minimal working example (removing r=2 in modFit creates the error which I can fix in the minimal working example but not in my actual problem so I doubt a minimal working example helps here):
`## =======================================================================
## Now suppose we do not know K and r and they are to be fitted...
## The "observations" are the analytical solution
## =======================================================================
# You need these packages
library('deSolve')
library('FME')
## logistic growth model
TT <- seq(1, 100, 2.5)
N0 <- 0.1
r <- 0.5
K <- 100
## analytical solution
Ana <- cbind(time = TT, N = K/(1 + (K/N0 - 1) * exp(-r*TT)))
time <- 0:100
parms <- c(r = r, K = K)
x <- c(N = N0)
logist <- function(t, x, parms) {
with(as.list(parms), {
dx <- r * x[1] * (1 - x[1]/K)
list(dx)
})
}
## Run the model with initial guess: K = 10, r = 2
parms["K"] <- 10
parms["r"] <- 2
init <- ode(x, time, logist, parms)
## FITTING algorithm uses modFit
## First define the objective function (model cost) to be minimised
## more general: using modFit
Cost <- function(P) {
parms["K"] <- P[1]
parms["r"] <- P[2]
out <- ode(x, time, logist, parms)
return(modCost(out, Ana))
}
(Fit<-modFit(p = c(K = 10,r=2), f = Cost))
summary(Fit)`
I think the problem is in your Cost function. If you don't provide both K and r, then the cost function will override the start value of r to NA. You can test this:
Cost <- function(P) {
parms["K"] <- P[1]
parms["r"] <- P[2]
print(parms)
#out <- ode(x, time, logist, parms)
#return(modCost(out, Ana))
}
Cost(c(K=10, r = 2))
Cost(c(K=10))
This function works:
Cost <- function(P) {
parms[names(P)] <- P
out <- ode(x, time, logist, parms)
return(modCost(out, Ana))
}
The vignette FMEDyna is very helpful: https://cran.r-project.org/web/packages/FME/vignettes/FMEdyna.pdf See page 14 on how to specify the Objective (Cost) function.