I am using simulated annealing, as implemented in R's package GenSa (function GenSA), to search for values of input variables that result in "good values" (compared to some baseline) of a highly dimensional function. I noticed that setting maximum number of calls of the objective function has no effect on the running time. Am I doing something wrong or is this a bug?
Here is a modification of the example given in GenSA help file.
library(GenSA)
Rastrigin <- local({
index <- 0
function(x){
index <<- index + 1
if(index%%1000 == 0){
cat(index, " ")
}
sum(x^2 - 10*cos(2*pi*x)) + 10*length(x)
}
})
set.seed(1234)
dimension <- 1000
lower <- rep(-5.12, dimension)
upper <- rep(5.12, dimension)
out <- GenSA(lower = lower, upper = upper, fn = Rastrigin, control = list(max.call = 10^4))
Even though the max.call is specified to be 10,000, GenSA calls the objective function more than 46,000 times (note that the objective is called within a local environment in order to track the number of calls). The same problem rises when trying to specify the maximum running time via max.time.
This is an answer by the package maintainer :
max.call and max.time are soft limits that do not include local
searches that are performed before reaching these limits. The
algorithm does not stop the local search strategy loop before its end
and this may exceed the limitation that you have set but will stop
after that last search. We have designed the algorithm that way to
make sure that the algorithm isn't stopped in the middle of searching
valley. Such an option to stop anywhere will be implemented in the
next release of the package.
Related
Is there a way to specify weights in relrisk.ppp function in spatstat (version 1.63-3)?
The relrisk.ppp function calls the density.ppp function, which does allow users to specify their own weights.
For example, let us build upon the provided spatstat.data::urkiola data where, instead of individual trees, the locations are tree stands and we have a second numeric mark for the frequency of trees at each point-location:
urkiola_new <- spatstat.data::urkiola
urkiola_new$marks <- data.frame("type" = urkiola_new$marks, "freq" = rpois(urkiola_new$n, 3))
f1 <- spatstat::relrisk(urkiola_new, weights = urkiola_new$marks$freq)
When using the urkiola_new in a call of relrisk, urkiola_new is caught by stopifnot(is.multitype(X)) in relrisk.ppp. I next tried specifying the weights separately as a vector while using the original urkiola data,
f2 <- spatstat::relrisk(urkiola, weights = urkiola_new$marks$freq)
but was caught by a warning from the pixellate.ppp function within the internal density.ppp function:
Error in pixellate.ppp(x, ..., padzero = TRUE) : length(weights) == npoints(x) || length(weights) == 1 is not TRUE
The same error occurs when I convert the weights into a list
urkiola_weights <- split(urkiola_new$marks$freq, urkiola_new$marks$type)
f3 <- spatstat::relrisk(urkiola, weights = urkiola_weights)
I suspect there is a way to specify the weights cleverly, but it yet escapes me. Any suggestions or guidance would be helpful, thank you!
The function relrisk.ppp is not currently designed to handle weights. The help entry for relrisk.ppp does not mention weights.
The example above does not work because relrisk.ppp applies density.ppp separately to the sub-patterns of points of each type, and the extra argument weights is the wrong length for these sub-patterns.
I will take this question as a feature request, to add this capability to relrisk.ppp. It should be done soon.
Update: this is now implemented in the development version, spatstat 1.64-0.018 available at the spatstat github repository
Issue 1
I have an objective function, gFun(modelOutput,l,u), which returns 0 if the simulated output is in interval [l,u], otherwise it returns a positive(!) number.
OFfun <- function(params) {
out <- simulate(params)
OF <- gFun(out,0,5)
return(OF)
}
The objective function is called from the optim function with some tolerance settings.
fitval=optim(par=parms,fn=OFfun,method="SANN",control = list(abstol = 1e-2))
summary(fitval)
My issue is that the optimization doesn't stop if the OFfun == 0.
I have tried with the condition below:
if (OF == 0){
opt <- options(show.error.messages=FALSE)
on.exit(options(opt))
stop()
}
it works but it doesn't return the OF back to optim and therefore I don't get the fitval info with estimated parameters.
Issue 2
Another issue is that the solver sometimes crashes and aborts the entire optimisation. I would like to harvest many solution sets for different initial guesses - so I need to handle failed simulations. probably related to issue 1.
Any advice would be very appreciated.
I am trying to use proxy::dist function with a custom distance matrix but what I have now is very slow.
This is a reproducible example of how I call my custom function:
set.seed(1)
test <- matrix(runif(4200), 60, 70)
train <- matrix(runif(4200), 60, 70)
dMatrix <- proxy::dist(x = test, y = train, method = customDTW,
by_rows = T,
auto_convert_data_frames = T)
which is supposed to calculate the distance between each time series in test matrix with all time series in the train matrix (each row being a time series).
My custom function is:
customDTW <- function(ts1, ts2){
d <- dtw(ts1, ts2,
dist.method = "Euclidean",
window.type = "sakoechiba",
window.size = 20
)
return(d$distance)
}
The problem is that, comparing to when I use method="DTW", or even to the case where I calculate the distance matrix by myself, this is extremely slower, and as the length of the time series or the number of them grows, it get slower exponentially. Of course this is rooted in the nested loop, but I am surprised by the scale of the effect. There must be another reason that I am not seeing it.
My question is that how else I could implement my customDTW to make it faster, using proxy::dist?
This is my little experiment on the execution time:
Execution time for 60X7 (using proxy::dist + customDTW)
user system elapsed
2.852 0.012 2.867
Execution time for 60X70 (using proxy::dist + customDTW)
user system elapsed
5.384 0.000 5.382
Execution time for 60X700 (using proxy::dist + customDTW)
user system elapsed
509.088 18.652 529.115
Execution time for 60X700 (without using proxy::dist)
user system elapsed
26.696 0.004 26.753
DTW is slow by nature
Have you considered trying to use dtwclust (parallelized implementation of dtw)
https://github.com/asardaes/dtwclust
https://cran.r-project.org/web/packages/dtwclust/vignettes/dtwclust.pdf
R is an interpreted language, and under the hood it is implemented in C. The proxy package is, as far as I understand, using R's interpretation capabilities from within C to call R code several times, but that still can't avoid the interpretation's overhead, so almost any "pure" R implementation will be slower.
Specifying loop=TRUE when registering a function with proxy means that the aforementioned will happen (proxy will interpret the R code several times to fill the distance matrix). If you really want to speed things up, you'd need to implement the filling itself in C/C++, and register the function with proxy with loop=FALSE; this is what dtwclust does (among other things).
You might want to look at the parallelDist package if you want to test your own custom C/C++ functions, even if you don't want to use parallelization.
This is what I found that seems to improve the speed, but it is still not as fast as I expect it to be. (Any other idea is still very welcome.)
The trick is to register the custom distance function with proxy (i.e., Registry of proximities here) so that you can use it like a built-in distance measure. So, first:
proxy::pr_DB$set_entry(FUN = customDTW, names=c("customDTW"),
loop = TRUE, type = "metric", distance = TRUE)
and now you can use it as if it was already in the proxy package.
dMatrix <- proxy::dist(x = test, y = train, method = "customDTW",
by_rows = T,
auto_convert_data_frames = T)
Note: If you want to use this method, then the customDTW method has to deal with one pair of time series, instead of all of them. So the customDTW would look like this:
customDTW2 <- function(ts1, ts2){
d <- dtw(ts1, ts2,
dist.method = "Euclidean",
window.type = "sakoechiba",
window.size = 20
)
return(d$distance)
}
For more, see ?pr_DB.
I am using the function plkhci from library Bhat to construct Profile-likelihood based confidence intervals and I got this warning:
Warning message: In dqstep(list(label = x$label, est = btrf(xt, x$low,
x$upp), low = x$low, : oops: unable to find stepsize, use default
when i run
r <- dfp(x,f=nlogf)
Can I ignore this warning as I still can get the output?
Following is the complete coding:
library(Bhat)
beta0<--8
beta1<-0.03
gamma<-0.0105
alpha<-0.05
n<-100
u<-runif(n)
u
x<-rnorm(n)
x
c<-rexp(100,1/1515)
c
t1<-(1/gamma)*log(1-((gamma/(exp(beta0+beta1*x)))*(log(1-u))))
t1
t<-pmin(t1,c)
t
delta<-1*(t1>c)
delta
length(delta)
cp<-length(delta[delta==1])/n
cp
delta[delta==1]<-ifelse(rbinom(length(delta[delta==1]),1,0.5),1,2)
delta
deltae<-ifelse(delta==0, 1,0)
deltar<-ifelse(delta==1, 1,0)
deltai<-ifelse(delta==2, 1,0)
dat=data.frame(t,delta, deltae,deltar,deltai,x)
dat$interval[delta==2] <- as.character(cut(dat$t[delta==2], breaks=seq(0, 600, 100)))
labs <- cut(dat$t[delta==2], breaks=seq(0, 600, 100))
dat$lower[delta==2]<-as.numeric( sub("\\((.+),.*", "\\1", labs) )
dat$upper[delta==2]<-as.numeric( sub("[^,]*,([^]]*)\\]", "\\1", labs) )
data0<-dat[which(dat$delta==0),]#uncensored data
data1<-dat[which(dat$delta==1),]#right censored data
data2<-dat[which(dat$delta==2),]#interval censored data
nlogf<-function(para)
{
b0<-para[1]
b1<-para[2]
g<-para[3]
e<-sum((b0+b1*data0$x)+g*data0$t+(1/g)*exp(b0+b1*data0$x)*(1-exp(g*data0$t)))
r<-sum((1/g)*exp(b0+b1*data1$x)*(1-exp(g*data1$t)))
i<-sum(log(exp((1/g)*exp(b0+b1*data2$x)*(1-exp(g*data2$lower)))-exp((1/g)*exp(b0+b1*data2$x)*(1-exp(g*data2$upper)))))
l<-e+r+i
return(-l)
}
x <- list(label=c("beta0","beta1","gamma"),est=c(-8,0.03,0.0105),low=c(-10,0,0),upp=c(10,1,1))
r <- dfp(x,f=nlogf)
x$est <- r$est
plkhci(x,nlogf,"beta0")
plkhci(x,nlogf,"beta1")
plkhci(x,nlogf,"gamma")
I am giving you a super long answer, but it will help you see that you can chase down your own error messages (most of the time, sometimes this means of looking at functions will not work). It is good to see what is happening inside a method when it throws an warning because sometimes it is fine and sometimes you need to fix your data.
This function is REALLY involved! You can look at it by typing dfp into the R command line (NO TRAILING PARENTHESES) and it will print out the whole function.
17 lines from the end, you will see an assignment:
del <- dqstep(x, f, sens = 0.01)
You can see that this calls the function dqstep, which is reflected in your warning.
You can see this function by typing dqstep into the command line of R again. In reading through this function, also long but not so tedious, there is this section of boolean logic:
if (r < 0 | is.na(r) | b == 0) {
warning("oops: unable to find stepsize, use default")
cat("problem with ", x$label[i], "\n")
break
}
This is the culprit, it returns the message you are getting. The line right above it spells out how r is calculated. You are feeding this function your default x from the prior function plus a sensitivity equations (which I assume dfp generates, it is huge and ugly, so I did not untangle all of it). When the previous nested function returns either an r value lower than Zero, and r value of NA or a b value of ZERO, that message is displayed.
The second error tells you that it was likely b==0 because b is in the denominator and it returned and infinity value, so NO STEP SIZE IS RETURNED FROM THIS NESTED FUNCTION to the variable del in dfp.
The step is fed into THIS equation:
h <- logit.hessian(x, f, del, dapprox = FALSE, nfcn)
which you can look into by typing logit.hessian into the R commandline.
When you do, you see that del is a step size in a logit scale, with a default value of del=rep(0.002, length(x$est))...which the function set for you because running the function dqstep returned no value.
So, you now get to decide if using that step size in the calculation of your confidence interval seems right or if there is a problem with your data which needs resolving to make this work better for you.
When I ran it, line by line, I got this message:
Error in if (denom <= 0) { : missing value where TRUE/FALSE needed
at this line of code:
r <- dfp(x,f=nlogf(x))
Which makes me think I was correct.
That is how I chase down issues I have with messages from packages when I get a message like yours.
I'm relatively new in R and I would appreciated if you could take a look at the following code. I'm trying to estimate the shape parameter of the Frechet distribution (or inverse weibull) using mmedist (I tried also the fitdist that calls for mmedist) but it seems that I get the following error :
Error in mmedist(data, distname, start = start, fix.arg = fix.arg, ...) :
the empirical moment function must be defined.
The code that I use is the below:
require(actuar)
library(fitdistrplus)
library(MASS)
#values
n=100
scale = 1
shape=3
# simulate a sample
data_fre = rinvweibull(n, shape, scale)
memp=minvweibull(c(1,2), shape=3, rate=1, scale=1)
# estimating the parameters
para_lm = mmedist(data_fre,"invweibull",start=c(shape=3,scale=1),order=c(1,2),memp = "memp")
Please note that I tried many times en-changing the code in order to see if my mistake was in syntax but I always get the same error.
I'm aware of the paradigm in the documentation. I've tried that as well but with no luck. Please note that in order for the method to work the order of the moment must be smaller than the shape parameter (i.e. shape).
The example is the following:
require(actuar)
#simulate a sample
x4 <- rpareto(1000, 6, 2)
#empirical raw moment
memp <- function(x, order)
ifelse(order == 1, mean(x), sum(x^order)/length(x))
#fit
mmedist(x4, "pareto", order=c(1, 2), memp="memp",
start=c(shape=10, scale=10), lower=1, upper=Inf)
Thank you in advance for any help.
You will need to make non-trivial changes to the source of mmedist -- I recommend that you copy out the code, and make your own function foo_mmedist.
The first change you need to make is on line 94 of mmedist:
if (!exists("memp", mode = "function"))
That line checks whether "memp" is a function that exists, as opposed to whether the argument that you have actually passed exists as a function.
if (!exists(as.character(expression(memp)), mode = "function"))
The second, as I have already noted, relates to the fact that the optim routine actually calls funobj which calls DIFF2, which calls (see line 112) the user-supplied memp function, minvweibull in your case with two arguments -- obs, which resolves to data and order, but since minvweibull does not take data as the first argument, this fails.
This is expected, as the help page tells you:
memp A function implementing empirical moments, raw or centered but
has to be consistent with distr argument. This function must have
two arguments : as a first one the numeric vector of the data and as a
second the order of the moment returned by the function.
How can you fix this? Pass the function moment from the moments package. Here is complete code (assuming that you have made the change above, and created a new function called foo_mmedist):
# values
n = 100
scale = 1
shape = 3
# simulate a sample
data_fre = rinvweibull(n, shape, scale)
# estimating the parameters
para_lm = foo_mmedist(data_fre, "invweibull",
start= c(shape=5,scale=2), order=c(1, 2), memp = moment)
You can check that optimization has occurred as expected:
> para_lm$estimate
shape scale
2.490816 1.004128
Note however, that this actually reduces to a crude way of doing overdetermined method of moments, and am not sure that this is theoretically appropriate.