I try to solve a set of non-linear systems of equation using the nleqslv function in R. Unfortunately I run into troubles guessing the right initial values to make the function run sucessfully. I have a vector with values between 0 and 1, which are called c(t). They should satisfy the following equation
c(t)=A*(exp(-mt)+exp(-m(1024-t)))+B^2
Using three subsequent values of t I aim to determine the coefficients A,B,m using the following code
library(nleqslv)
C10 <- c(1.000000e+00,9.754920e-01,9.547681e-01,9.359057e-01,9.182586e-01,9.014674e-01)
system_size <- 1024
for(i in 2:5)
{
C <- c(C10[i-1],C10[i],C10[i+1],i-2)
#function
target <- function(Coeffs){
y <- numeric(3)
y[1] <- Coeffs[1]*(exp(-Coeffs[2]*(C[4]-1))+exp(-Coeffs[2]*(system_size-(C[4]-1))))+Coeffs[3]^2-C[1]
y[2] <- Coeffs[1]*(exp(-Coeffs[2]*(C[4]))+exp(-Coeffs[2]*(system_size-(C[4]))))+Coeffs[3]^2-C[2]
y[3] <- Coeffs[1]*(exp(-Coeffs[2]*(C[4]+1))+exp(-Coeffs[2]*(system_size-(C[4]+1))))+Coeffs[3]^2-C[3]
y
}
init <- c(0.001,0.01,0)
sol <- nleqslv(init, target,control=list(btol=.01), method="Broyden")
}
The used initial values reflect what I get when plotting the associated values c(t). Nonetheless the generated output sol gives
chr "Jacobian is ill-conditioned (1/condition=9.0e-18) (see allowSingular option)"
Any idea what is going wrong and how to solve this?
OP edit: Modified Code to have minimal working example: added first few values for C10, adjusted loop and added value for system_size
With your addition of some data for C10 the example runs perfectly ok if one takes into account that the loop should take account of length(C10).
Like this (with some changes; for why see below):
library(nleqslv)
C10 <- c(1.000000e+00,9.754920e-01,9.547681e-01,9.359057e-01,9.182586e-01,9.014674e-01)
system_size <- 1024
target <- function(Coeffs){
y <- numeric(3)
y[1] <- Coeffs[1]*(exp(-Coeffs[2]*(C[4]-1))+exp(-Coeffs[2]*(system_size-(C[4]-1))))+Coeffs[3]^2-C[1]
y[2] <- Coeffs[1]*(exp(-Coeffs[2]*(C[4]))+exp(-Coeffs[2]*(system_size-(C[4]))))+Coeffs[3]^2-C[2]
y[3] <- Coeffs[1]*(exp(-Coeffs[2]*(C[4]+1))+exp(-Coeffs[2]*(system_size-(C[4]+1))))+Coeffs[3]^2-C[3]
y
}
init <- 50*c(0.001,0.01,0)
for(i in 2:min(length(C10)-1,(system_size/2)))
{
C <- c(C10[i-1],C10[i],C10[i+1],i-2)
#function
target <- function(Coeffs){
y <- numeric(3)
y[1] <- Coeffs[1]*(exp(-Coeffs[2]*(C[4]-1))+exp(-Coeffs[2]*(system_size-(C[4]-1))))+Coeffs[3]^2-C[1]
y[2] <- Coeffs[1]*(exp(-Coeffs[2]*(C[4]))+exp(-Coeffs[2]*(system_size-(C[4]))))+Coeffs[3]^2-C[2]
y[3] <- Coeffs[1]*(exp(-Coeffs[2]*(C[4]+1))+exp(-Coeffs[2]*(system_size-(C[4]+1))))+Coeffs[3]^2-C[3]
y
}
cat("i=",i,"init=",init, "target(init)=",target(init),"\n")
sol <- nleqslv(init, target,control=list(btol=.01), method="Broyden")
print(sol)
}
With your initial starting values the model doesn't solve and gives the error message you mention. I have changed the value of init by increasing the value. And then a solution is found up-to i=5. Larger values with the given C10 won't run since within the loop C10[i+1] is referenced (and it doesn't exist).
I have inserted a cat statement before the call of nleqslv and a print(sol) after the function call so that one can at least see what's going on and if a solution is actually found.
You do not need to specify method="Broyden" since it is the default.
You should test sol$termcd in the for loop end exit if an error occurs.
With scripts like this always print stuff inside the loop!
Mislav was correct: starting values can be totally wrong.
Even if starting values are ok the algorithms used can fail. That's why the package provides function testnslv and searchZeros.
I did some experiments (not shown here) with testnslv and the conclusion is that method="Newton" is a failure. The dogleg global strategies always seem to work. The linesearch strategies don't always work.
Related
I am having two related problems with the Deriv() function from the Deriv package (from CRAN).
Problem (1): I believe that the code in the rule for differentiating dbinom() w.r.t "prob" is incorrect. Evidence for this (and my proposed correction) is shown in the following code. I would have preferred to attach text files containing the code, but as far as I can see there is no way to do this.
#
# Script demo01.R.
#
library(Deriv)
# Plot dbinom as a function of probabiity.
plot(function(p){dbinom(3,8,p)},from=0,to=1,xlab="parameter \"prob\"",
ylab="binomial probability",main="dbinom")
abline(v=3/8,col="red")
readline("Go? ")
# Plot the derivative of dbinom, with respect to prob, calculated by
# Deriv(), as a function of probability.
Ddb <- Deriv(dbinom,"prob")
plot(function(p){Ddb(3,8,p)},from=0,to=1,xlab="parameter \"prob\"",
ylab="",main="derivative of dbinom")
readline("Go? ")
# Replace what I believe to be incorrect code for the rule for
# differentiating dbinom() with what I believe to be correct code.
# This rule should, strictly speaking, be placed in a new environment
# rather than over-writing the existing rule, but this seems to
# break down when second derivatives are taken.
drule[["dbinom"]] <- alist(x=NULL,size=NULL,prob={
.e1 <- 1 - prob
.e2 <- size - 1
if (x == 0)
-(x * .e1^(x - 1))
else if (x == size)
prob^.e2 * size
else size*(dbinom(x-1,.e2,prob) - dbinom(x,.e2,prob)) *
(if (log) dbinom(x, size, prob) else 1)
})
# Plot the derivative of dbinom, with respect to prob, calculated by
# the corrected version of Deriv(), as a function of probability.
Ddb <- Deriv(dbinom,"prob")
plot(function(p){Ddb(3,8,p)},from=0,to=1,xlab="parameter \"prob\"",
ylab="",main="derivative of dbinom, corrected")
abline(v=3/8,col="red")
abline(h=0,col="blue")
You will observe that the derivative of dbinom()
should be positive for prob < 3/8 and negative for prob > 3/8. My corrected version has this property, whereas the derivative produced by the uncorrected version is negative everywhere.
Can anyone confirm that I am right about about there being a bug in the Deriv package? (I.e. that I am not making some sort of stupid mistake?)
Problem (2). I "crosschecked" the calculations performed by Deriv() by applying this function to a "roll-your-own" version of dbinom() for which no special rule is needed. I also applied the (corrected version) of Deriv() to dbinom(). The code that I used is as follows:
#
# Script demo02.
#
library(Deriv)
# Replace what I believe to be incorrect code for the rule for
# differentiating dbinom() with what I believe to be correct code.
# This rule should, strictly speaking, be placed in a new environment
# rather than over-writing the existing rule, but this seems to
# break down when second derivatives are taken.
drule[["dbinom"]] <- alist(x=NULL,size=NULL,prob={
.e1 <- 1 - prob
.e2 <- size - 1
if (x == 0)
-(x * .e1^(x - 1))
else if (x == size)
prob^.e2 * size
else size*(dbinom(x-1,.e2,prob) - dbinom(x,.e2,prob)) *
(if (log) dbinom(x, size, prob) else 1)
},log=NULL)
fooB1 <- function(x,prob,size) {
dbinom(x,size,prob)
}
fooB2 <- function(x,prob,size) {
choose(size,x)*prob^x*(1-prob)^(size-x)
}
dfooB1 <- Deriv(fooB1,"prob")
dfooB2 <- Deriv(fooB2,"prob")
d2fooB1 <- Deriv(fooB1,"prob",nderiv=2)
d2fooB2 <- Deriv(fooB2,"prob",nderiv=2)
vB1 <- fooB1(x=3,prob=0.6,size=8)
vB2 <- fooB2(x=3,prob=0.6,size=8)
dB1 <- dfooB1(x=3,prob=0.6,size=8)
dB2 <- dfooB2(x=3,prob=0.6,size=8)
d2B1 <- d2fooB1(x=3,prob=0.6,size=8)
d2B2 <- d2fooB2(x=3,prob=0.6,size=8)
If you run this code you will see that the function values (vB1 and vB2) agree, both having the value 0.123863. Likewise the first derivative values dB1 and dB2 agree: -0.9289728.
However the second derivatives disagree. The value of d2B1 is 1.769472, whereas the value of d2B2 is 2.064384. I have no idea which (if either) of these answers is correct.
Something (the chain rule?) is not working as it should.
Is there any action that I can take to resolve this discrepancy?
I frequently have problems that lend themselves to while loops, but come out ugly, and I'm here to ask if there is an elegant solution or if all possible solutions are ugly. Is there?
Here's a simplified example: suppose we are trying to find the minimum value of a function f <- function(x){x^2}, as well as the location at which it is found. Suppose we elect to find the minimum by making an initial guess x and evaluating f(x). Then we evaluate f(x-0.1), and f(x+0.1). If either of these values is lower than f(x), our new guess is the argmin. We repeat until such shifts no longer decrease the value.
The best solution I have come up with is to run part of the first iteration of the algorithm outside of the loop. But this requires me to duplicate code from the loop, namely the section of code enclosed with !!!!!!!.
# function to minimize
f <- function(x){x^2}
# initial guess
x.current <- 1
f.current <- f(x.current)
# !!!!!!!!!!!!
# part of first iteration
x.guess <- c(x.current - 0.1, x.current + 0.1)
f.guess <- sapply(x.guess, f)
best.ind <- which.min(f.guess)
x.new <- x.guess[best.ind]
f.new <- f.guess[best.ind]
# !!!!!!!!!!!!
# part of first iteration and later iterations
while (f.new < f.current){
x.current <- x.new
f.current <- f.new
x.guess <- c(x.current - 0.1, x.current + 0.1)
f.guess <- sapply(x.guess, f)
best.ind <- which.min(f.guess)
x.new <- x.guess[best.ind]
f.new <- f.guess[best.ind]
}
print("best guess = ")
print(x.current)
Is there a "nicer" way of doing this?
There are a variety of ways to deal with this situation. Whether one is 'ugly' or 'pretty' is a matter of opinion, and therefore off topic for StackOverflow. Nonetheless, we can make some generalisations about some different options:
Option 1: wrap repetitive lines in their own function
A common rule of thumb is that one should avoid repeating code segments. Whenever you see a sequence of lines repeated at various places in your program, one should strongly consider placing those lines into their own function and calling this function repeatedly.
This aids in the readability of the overall code by making it more succinct, and requiring a maintainer to only read through and understand that section once.
Perhaps more importantly, it also aids in maintainability of the code because any changes to that snippet will automatically propagate through the whole program. Having to hunt down and alter every instance of a repeated code snippet is not only frustrating when it comes to editing code, but it is also a potentially error-prone procedure.
Here's one way you might apply this principle here, using an additional trick of placing the function call inside the loop condition expression, so that we only need to call it once here (although the code inside a while loop is not guaranteeed to execute, the code in its condition must always be executed at least once:
# initial guess
x <- 1
fx <- f(x)
find.new = function(x){
x.new <- c(x - 0.1, x + 0.1)
f.new <- sapply(x.new, f)
best.ind <- which.min(f.new)
x.new <- x.new[best.ind]
f.new <- f.new[best.ind]
return(list(x=x.new, fx=f.new))
}
while ((new <- find.new(x))$fx < fx){
x <- new$x
fx <- new$fx
}
2 use a repeat loop instead
If, as in this case, there is some code inside the loop that we would always want to execute at least onse, then consider using a repeat loop instead of while. We can then test for the exit condition to either update values or to break from the loop. If the repeated code snippet in your original does not need to execute anywhere else in your program, this can be more concise than wrapping it in its own function
repeat {
x.new <- c(x - 0.1, x + 0.1)
f.new <- sapply(x.new, f)
best.ind <- which.min(f.new)
x.new <- x.new[best.ind]
f.new <- f.new[best.ind]
if (f.new < fx) {
x <- x.new
fx <- f.new
} else {
break
}
}
As pointed out by dww there are several options. There is a third one which initializes the variables which are referenced in the first iteration of the loop and in the test condition of the loop appropriately:
# function to minimize
f <- function(x){x^2}
# initialize values
x.new <- 1
f.new <- f(x.new)
f.current <- f.new + 0.1 # just to fulfill test condition
# part of first iteration and later iterations
while (f.new < f.current){
x.current <- x.new
f.current <- f.new
x.guess <- c(x.current - 0.1, x.current + 0.1)
f.guess <- sapply(x.guess, f)
best.ind <- which.min(f.guess)
x.new <- x.guess[best.ind]
f.new <- f.guess[best.ind]
}
print("best guess = ")
print(x.current)
I tried to solve the these non-linear equations by using nleqslv. However it does not work well. I do know the reason why it does not because I didn't separate the two unknowns to different sides of the equation.
My questions are: 1, Are there any other packages that could solve this kind of
equations?
2, Is there any effective way in R that could help me rearrange
the equation so that it meets the requirement of the package
nleqslv?
Thank you guys.
Here are the codes and p[1] and p[2] are the two unknowns I want to solve.
dslnex<-function(p){
p<-numeric(2)
0.015=sum(exp(Calib2$Median_Score*p[1]+p[2])*weight_pd_bad)
cum_dr<-0
for (i in 1:length(label)){
cum_dr[i]<-exp(Calib2$Median_Score*p[1]+p[2][1:i]*weight_pd_bad[1:i]/0.015
}
mid<-0
for (i in 1:length(label)){
mid[i]<-sum(cum_dr[1:i])/2
}
0.4=(sum(mid*weight_pd_bad)-0.5)/(0.5*(1-0.015))
}
pstart<-c(-0.000679354,-4.203065891)
z<- nleqslv(pstart, dslnex, jacobian=TRUE,control=list(btol=.01))
Following up on my comment I have rewritten your function as follows correcting errors and inefficiencies.
Errors and other changes are given as inline comments.
# no need to use dslnex as name for your function
# dslnex <- function(p){
# any valid name will do
f <- function(p) {
# do not do this
# you are overwriting p as passed by nleqslv
# p<-numeric(2)
# declare retun vector
y <- numeric(2)
y[1] <- 0.015 - (sum(exp(Calib2$Median_Score*p[1]+p[2])*weight_pd_bad))
# do not do this
# cum_dr is initialized as a scalar and will be made into a vector
# which will be grown as a new element is inserted (can be very inefficient)
# cum_dr<-0
# so declare cum_dr to be a vector with length(label) elements
cum_dr <- numeric(length(label))
for (i in 1:length(label)){
cum_dr[i]<-exp(Calib2$Median_Score*p[1]+p[2][1:i]*weight_pd_bad[1:i]/0.015
}
# same problem as above
# mid<-0
mid <- numeric(length(label))
for (i in 1:length(label)){
mid[i]<-sum(cum_dr[1:i])/2
}
y[2] <- 0.4 - (sum(mid*weight_pd_bad)-0.5)/(0.5*(1-0.015))
# return vector y
y
}
pstart <-c(-0.000679354,-4.203065891)
z <- nleqslv(pstart, dslnex, jacobian=TRUE,control=list(btol=.01))
nleqslv is intended for solving systems of equations of the form f(x) = 0 which must be square.
So a function must return a vector with the same size as the x-vector.
You should now be able to proceed provided your system of equations has a solution. And provided there are no further errors in your equations. I have my doubles about the [1:i] in the expression for cum_dr and the expression for mid[i]. The loop calculating mid possibly can be written as a single statement: mid <- cumsum(cum_dr)/2. Up to you.
I am attempting to calculate some weights in order to perform an indirect treatment comparison using R. I have altered some code slightly, in order to reflect that I am only centring the mean. However, this code will not run.
I believe this is due to the a1 matrix having two columns instead of one, but I really can't work out how to change this. I have tried adding a column of zeros and ones to the matrix, but I'm not sure if this will give me a correct result.
Of course, this may not be the issue at all, but I fail to see what else could be causing this. I have included the code and any advice would be appreciated.
# Objective function
objfn <- function(a1, X){
sum(exp(X %*% a1))
}
# Gradient function
gradfn <- function(a1, X){
colSums(sweep(X, 1, exp(X %*% a1), "*"))
}
X.EM.0 = data$A-age.mean
# Estimate weights
print(opt1 <- optim(par = c(0,0), fn = objfn, gr = gradfn, X = X.EM.0, method = "BFGS"))
a1 <- opt1$par
Such a simple solution, I'm slightly embarrassed to have posted this.
par=c(0,0) should be altered to match the columns of data. Here it should have been changed to one.
I am trying to calculate the area under the curve for every 10ms of a short piece of EEG wave. To first practice this I made a small dataset to run the auc (from package {flux}) function on.
x <- seq(1:10)
y <- c(0:4,5:1)
df <- data.frame(x,y)
attach(df)
plot(x,y)
for (i in 1:10){
x1 <- c(i,(i+1))
y1 <- c(subset(y, x == i),subset(y, x == (i+1)))
auc(x1,y1,thresh = 0)
rm(y1,x1,i)
}
The loop should try to subset two data points from each variable and then run a auc over those data points. However, when running the loop, I get this error:
Error in seq.default(x[1], x[2], length.out = dens) : 'to' must be a finite number
When I run the subset and auc code outside of the loop, it works no problem. Can anyone tell me what's going wrong in the loop?
Thanks for updating the question. It's not because of the control statement (for loop), the error gets thrown precisely when i=10 -- because the length of your x-coords and y-coords vectors are different. Specifically c(10,11) vs c(1). But you have no point at x=11 !
just stop the loop early, at the appropriate time