R: nls2 misses the solution - r

I'm trying to fit a bi exponential function:
t = seq(0, 30, by = 0.1)
A = 20 ; B = 10 ; alpha = 0.25 ; beta = 0.01
y = A*exp(-alpha*t) + B*exp(-beta*(t))
df = as.data.frame(cbind(t,y))
ggplot(df, aes(t, y)) + geom_line() + scale_y_continuous(limits=c(0, 50))
This problem can't be solve by a simple transformation like log so I wanted to use the nls2 package:
library(nls2)
fo <- y ~ Ahat*exp(-alphahat*t) + Bhat*exp(-betahat*t)
fit <- nls2(fo,
start = list(Ahat=5, Bhat=5, alphahat=0.5,betahat=0.5),
algorithm = "brute-force",
trace = TRUE,
lower = c(Ahat=0, Bhat=0, alphahat=0, betahat=0),
upper = c(Ahat=50, Bhat=50, alphahat=10,betahat=10))
fit
Here is the result:
Nonlinear regression model
model: y ~ Ahat * exp(-alphahat * t) + Bhat * exp(-betahat * t)
data: NULL
Ahat Bhat alphahat betahat
5.0 5.0 0.5 0.5
residual sum-of-squares: 37910
Number of iterations to convergence: 4
Achieved convergence tolerance: NA
I assume something is wrong in my code because :
data: NULL ?
Why only 4 iterations ?
Hard to think nls2 didn't find a better solution than the starting point.
The result is far from the solution

From the documentation, the start parameter should be a data.frame of two rows that define the grid to search in, or a data.frame with more rows corresponding to parameter combinations to test if you are using brute-force. Also, nls will have trouble with your fit because it is a perfect curve, there is no noise. The brute-force method is slow, so here is an example where the search space is decreased for nls2. The result of the brute-force nls2 is then used as the starting values with nls default algorithm (or you could use nls2), after adding a tiny bit of noise to the data.
## Data
t = seq(0, 30, by = 0.1)
A = 20 ; B = 10 ; alpha = 0.25 ; beta = 0.01
y = A*exp(-alpha*t) + B*exp(-beta*(t))
df = as.data.frame(cbind(t,y))
library(nls2)
fo <- y ~ Ahat*exp(-alphahat*t) + Bhat*exp(-betahat*t)
## Define the grid to search in,
## Note: decreased the grid size
grd <- data.frame(Ahat=c(10,30),
Bhat=c(10, 30),
alphahat=c(0,2),
betahat=c(0,1))
## Do the brute-force
fit <- nls2(fo,
data=df,
start = grd,
algorithm = "brute-force",
control=list(maxiter=100))
coef(fit)
# Ahat Bhat alphahat betahat
# 10.0000000 23.3333333 0.0000000 0.3333333
## Now, run through nls:
## Fails, because there is no noise
final <- nls(fo, data=df, start=as.list(coef(fit)))
## Add a little bit of noise
df$y <- df$y+rnorm(nrow(df),0,0.001)
coef((final <- nls(fo, data=df, start=as.list(coef(fit)))))
# Ahat Bhat alphahat betahat
# 10.00034000 19.99956016 0.01000137 0.25000966
## Plot
plot(df, col="steelblue", pch=16)
points(df$t, predict(final), col="salmon", type="l")

Your data is null because you didn't add in any data into the nls2 statement.
This is how nls2 needs to be set up:
nls2(formula, data = parent.frame(), start, control = nls.control(),
algorithm = c("default", "plinear", "port", "brute-force",
"grid-search", "random-search", "plinear-brute", "plinear-random"),
trace = FALSE, weights, ..., all = FALSE)
Take a look at the official documentation for a full example.

Related

Errors in nls() - singular gradient or NaNs produced

I am trying to fit my photosynthesis data to a nls function, which is a nonrectangular hyperbola function. So far, I have some issues with getting the right start value for nls and, therefore, I am getting a lot of errors such as 'singular gradient ', 'NaNs produced', or 'step factor 0.000488281 reduced below 'minFactor' of 0.000976562'. Would you please give some suggestions for finding the best starting values? Thanks in advance!
The codes and data are below:
#Dataframe
PPFD <- c(0,0,0,50,50,50,100,100,100,200,200,200,400,400,400,700,700,700,1000,1000,1000,1500,1500,1500)
Cultivar <- c(-0.7,-0.8,-0.6,0.6,0.5,0.8,2.0,2.0,2.3,3.6,3.7,3.7,5.7,5.5,5.8,9.7,9.6,10.0,14.7,14.4,14.9,20.4,20.6,20.9)
NLRC <-data.frame(PPFD,Cultivar)
#nls regression
reg_nrh <- nls(Cultivar ~ (1/(2*Theta))*(AQY*PPFD+Am-sqrt((AQY*PPFD+Am)^2-4*AQY*Theta*Am*PPFD))-Rd, data = NLRC, start=list(Am = max(NLRC$Cultivar)-min(NLRC$Cultivar), AQY = 0.05, Rd=-min(NLRC$Cultivar), Theta = 1))
#estimated parameters for plotting
Amnrh <- coef(reg_nrh)[1]
AQYnrh <- coef(reg_nrh)[2]
Rdnrh <- coef(reg_nrh)[3]
Theta <- coef(reg_nrh)[4]
#plot
plot(NLRC$PPFD, NLRC$Cultivar, main = c("Cultivar"), xlab="", ylab="", ylim=c(-2,40),cex.lab=1.2,cex.axis=1.5,cex=2)+mtext(expression("PPFD ("*mu*"mol photons "*m^-2*s^-1*")"),side=1,line=3.3,cex=1.5)+mtext(expression(P[net]*" ("*mu*"mol "*CO[2]*" "*m^-2*s^-1*")"),side=2,line=2.5,cex=1.5)
#simulated value
ppfd = seq(from = 0, to = 1500)
pnnrh <- (1/(2*Theta))*(AQYnrh*ppfd+Amnrh-sqrt((AQYnrh*ppfd+Amnrh)^2-4*AQYnrh*Theta*Amnrh*ppfd))- Rdnrh
lines(ppfd, pnnrh, col="Green")
If we
take the maximum of 0 and the expression within the sqrt to avoid taking negative square roots
fix Theta at 0.8
use lm to get starting values for AQY and Am
then it converges
Theta <- 0.8
fm <- lm(Cultivar ~ PPFD, NLRC)
st <- list(AQY = coef(fm)[[2]], Rd = -min(NLRC$Cultivar), Am = coef(fm)[[1]])
fo <- Cultivar ~
(1/(2*Theta))*(AQY*PPFD+Am-sqrt(pmax(0, (AQY*PPFD+Am)^2-4*AQY*Theta*Am*PPFD)))-Rd
reg <- nls(fo, data = NLRC, start = st)
deviance(reg) # residual sum of squares
## [1] 5.607943
plot(Cultivar ~ PPFD, NLRC)
lines(fitted(reg) ~ PPFD, NLRC, col = "red")
(continued after image)
Note that the first model below has only two parameters yet has lower residual sum of squares (lower is better).
reg2 <- nls(Cultivar ~ a * PPFD^b, NLRC, start = list(a = 1, b = 1))
deviance(reg2)
## [1] 5.098796
These have higher residual sum of squares but do have the advantage that they are very simple.
deviance(fm) # fm defined above
## [1] 6.938648
fm0 <- lm(Cultivar ~ PPFD + 0, NLRC) # same as fm except no intercept
deviance(fm0)
## [1] 7.381632

nls() : “Error singular gradient matrix at initial parameter estimates ”

I've read many similar questions but still couldn't find the answer.
Here is some data that I'm using to calibrate the equation below:
set.seed(100)
i <- sort(rexp(n = 100,rate = 0.01))
Tr <- sort(runif(n = 100,min = 5,max = 100))
k_start <- 3259
u_start <- 0.464
t0_start <- 38
n_start <- -1
i_test <- k_start*Tr^u_start * (5 + t0_start)^n_start
m <- nls(i~(k * Tr^u / (5+t0)^n), start = list(k = k_start, u = u_start,
t0 = t0_start, n = n_start))
When I used nlsLM and the same error came up:
Error in nlsModel(formula, mf, start, wts) : singular gradient matrix at initial parameter estimates
For the start values, I tried to use the values from calibration in Python and still the same error occurs.
There's also another way to use that equation that is like this:
However, the result is the same error.
d_start <- 43
m <- nls(i ~ (k * Tr^u / d),
start = list(k = k_start, u = u_start,d=d_start))
When I use only the numerator it works, but that's not what I need.
Any help will be very much appreciated.
In the first nls, the right hand side depends on k, t0 and n only through
k / (5+t0)^n so it is over parameterized as one parameter could represent
their combined effect. In the second nls the right hand side depends only
on k and d through k / d so again the problem has been over parameterized and
one parameter could represent their combined effect.
Getting rid of the excess parameters and getting the starting values using a linear model it converges.
fit.lm <- lm(log(i) ~ log(Tr))
co <- coef(fit.lm)
fit <- nls(i ~ k * Tr ^ u, start = list(k = exp(co[[1]]), u = co[[2]]))
fit
## Nonlinear regression model
## model: i ~ k * Tr^u
## data: parent.frame()
## k u
## 0.0002139 3.0941602
## residual sum-of-squares: 79402
##
## Number of iterations to convergence: 43
## Achieved convergence tolerance: 5.354e-06
Reciprocal Model
Below we fit a "reciprocal model" which has the same number of parameters but a better fit as measured by the deviance which is the residual sum of squares. A lower value means better fit.
# reciprocal model
fit.recip <- nls(i ~ 1/(a + b * log(Tr)), start = list(a = 1, b = 1))
deviance(fit)
## [1] 79402.17
deviance(fit.recip)
## [1] 25488.1
Graphics
Below we plot both fit (red) and fit.recip (blue) models.
plot(i ~ Tr)
lines(fitted(fit) ~ Tr, col = "red")
lines(fitted(fit.recip) ~ Tr, col = "blue")
legend("topleft", legend = c("fit", "fit.recip"), lty = 1, col = c("red", "blue"))
(continued after plot)
plinear
Note that the plinear algorithm could be used as an alternative algorithm to fit the fit model above to avoid having to supply a starting value for k. It also has the additional benefit that it requires substantially fewer iterations in this case (14 vs. 45). With plinear the formula should omit the linear argument, k, as it is implied by the algorithm and will be reported as .lin .
nls(i ~ Tr ^ u, start = list(u = co[[2]]), algorithm = "plinear")
## Nonlinear regression model
## model: i ~ Tr^u
## data: parent.frame()
## u .lin
## 3.0941725 0.0002139
## residual sum-of-squares: 79402
##
## Number of iterations to convergence: 14
## Achieved convergence tolerance: 3.848e-06

Adjusting ODE model output using a Rogan-Gladen estimator in R

I have made an ODE model in R using the package deSolve. Currently the output of the model gives me the "observed" prevalence of a disease (i.e. the prevalence not accounting for diagnostic imperfection).
However, I want to adjust the model to output the "true" prevalence, using a simple adjustment formula called the Rogan-Gladen estimator (http://influentialpoints.com/Training/estimating_true_prevalence.htm):
True prevalence =
(Apparent prev. + (Specificity-1)) / (Specificity + (Sensitivity-1))
As you will see in the code below, I have attempted to adjust only one of the differential equations (diggP).
Running the model without adjustment gives an expected output (a proportion between 0 and 1). However, attempting to adjust the model using the RG-estimator gives a spurious output (a proportion less than 0).
Any advice on what might be going wrong here would be very much appreciated.
# Load required packages
library(tidyverse)
library(broom)
library(deSolve)
# Set time (age) for function
time = 1:80
# Defining exponential decay of lambda over age
y1 = 0.003 + (0.15 - 0.003) * exp(-0.05 * time) %>% jitter(10)
df <- data.frame(t = time, y = y1)
fit <- nls(y ~ SSasymp(time, yf, y0, log_alpha), data = df)
fit
# Values of lambda over ages 1-80 years
data <- as.matrix(0.003 + (0.15 - 0.003) * exp(-0.05 * time))
lambda<-as.vector(data[,1])
t<-as.vector(seq(1, 80, by=1))
foi<-cbind(t, lambda)
foi[,1]
# Making lambda varying by time useable in the ODE model
input <- approxfun(x = foi[,1], y = foi[,2], method = "constant", rule = 2)
# Model
ab <- function(time, state, parms) {
with(as.list(c(state, parms)), {
# lambda, changing by time
import<-input(time)
# Derivatives
# RG estimator:
#True prevalence = (apparent prev + (sp-1)) / (sp + (se-1))
diggP<- (((import * iggN) - iggR * iggP) + (sp_igg-1)) / (sp_igg + (se_igg-1))
diggN<- (-import*iggN) + iggR*iggP
dtgerpP<- (0.5*import)*tgerpN -tgerpR*tgerpP
dtgerpN<- (0.5*-import)*tgerpN + tgerpR*tgerpP
# Return results
return(list(c(diggP, diggN, dtgerpP, dtgerpN)))
})
}
# Initial values
yini <- c(iggP=0, iggN=1,
tgerpP=0, tgerpN=1)
# Parameters
pars <- c(iggR = 0, tgerpR = (1/8)/12,
se_igg = 0.95, sp_igg = 0.92)
# Solve model
results<- ode(y=yini, times=time, func=ab, parms = pars)
# Plot results
plot(results, xlab="Time (years)", ylab="Proportion")

neldermead arguments in R

I have found no examples of neldermead() on the internet, so I figured I would post the following. That said, I cant figure out how to control the max number of iterations of the algorithm.
https://cran.r-project.org/web/packages/neldermead/neldermead.pdf
Which states the following:
optbase An object of class ’optimbase’, i.e. a list created by optimbase() and containing the following elements:
iterations The number of iterations.
Working example of using Nelder Mead to fit a parabola by minimizing the residuals
library(neldermead); library(nloptr);
## ========= Minimizing the residuals for a 2d quadrature =========== ##
x2d = seq(-4,6,length.out=50); ## x vector definition
ynoise = runif(n=50, min=-2, max = 2) ## noise
y2d = 1.3 + (x2d-2.1)^2 + ynoise ## y data for fitting
## Fitting with nelder-mead
quadmin <- function(x){ sum( (y2d - x[1] - (x2d - x[2])^2)^2 ) }
x000 <- c(1, 2)
sol2d <- neldermead(x0 = x000, fn = quadmin)
sol2d
yfit = sol2d[[1]][1] + (x2d - sol2d[[1]][2])^2 ## Fitted curve.
plot(x2d, y2d); lines(x2d, yfit) ## Plotting
But I'm looking to do something like:
sol2d <- neldermead(x0 = x000, fn = quadmin, iterations = 200)
^^^ which doesn't work. Neither does putting it into a list:
sol2d <- neldermead(x0 = x000, fn = quadmin, optbase = list(iterations = 200))
This is a basic question about how to use these arguments, so I apologize if this isn't the right title. In advance, thank you for your help.
There are at least tow neldermead functions available in R. One is from the package neldermead which correspond to the documentation you link.
I have not been able to make it work. It gives me back neither error or solution.
The code:
library(neldermead)
library(nloptr)
## ========= Minimizing the residuals for a 2d quadrature =========== ##
x2d = seq(-4,6,length.out=50); ## x vector definition
ynoise = runif(n=50, min=-2, max = 2) ## noise
y2d = 1.3 + (x2d-2.1)^2 + ynoise ## y data for fitting
## Fitting with nelder-mead
quadmin <- function(x){
sum(y2d - x[1] - (x2d - x[2])^2)^2 }
x000 <- c(1, 2)
opt <- optimbase(x0 = as.matrix(x000),fx0 = -1000,maxiter = 200,fopt = quadmin,verbose=T)
sol2d <- neldermead::neldermead(opt)
On the other hand, package nloptr also provides a neldermedad function which sintax looks closer to you code and I have been able to run:
library(neldermead)
library(nloptr)
## ========= Minimizing the residuals for a 2d quadrature =========== ##
x2d = seq(-4,6,length.out=50); ## x vector definition
ynoise = runif(n=50, min=-2, max = 2) ## noise
y2d = 1.3 + (x2d-2.1)^2 + ynoise ## y data for fitting
## Fitting with nelder-mead
quadmin <- function(x){
sum(y2d - x[1] - (x2d - x[2])^2)^2 }
x000 <- c(1, 2)
sol2d <- nloptr::neldermead(x0 = x000,fn =quadmin,control =list(maxeval=200))
yfit = sol2d[[1]][1] + (x2d - sol2d[[1]][2])^2 ## Fitted curve.
plot(x2d, y2d); lines(x2d, yfit)
As you can see, the only issue with you code was the control part.
Best!

Predicting data from a power curve manually

I have a series of data I have fit a power curve to, and I use the predict function in R to allow me predict y values based on additional x values.
set.seed(1485)
len <- 24
x <- runif(len)
y <- x^3 + rnorm(len, 0, 0.06)
ds <- data.frame(x = x, y = y)
mydata=data.frame(x,y)
z <- nls(y ~ a * x^b, data = mydata, start = list(a=1, b=1))
#z is same as M!
power <- round(summary(z)$coefficients[1], 3)
power.se <- round(summary(z)$coefficients[2], 3)
plot(y ~ x, main = "Fitted power model", sub = "Blue: fit; green: known")
s <- seq(0, 1, length = 100)
lines(s, s^3, lty = 2, col = "green")
lines(s, predict(z, list(x = s)), lty = 1, col = "blue")
text(0, 0.5, paste("y =x^ (", power, " +/- ", power.se,")", sep = ""), pos = 4)
Instead of using the predict function here, how could I manually calculate estimated y values based on additional x values based on this power function. If this were just a simple linear regression, I would calculate the slope and y intercept and calculate my y values by
y= mx + b
Is there a similar equation I can use from the output of z that will allow me to estimate y values from additional x values?
> z
Nonlinear regression model
model: y ~ a * x^b
data: mydata
a b
1.026 3.201
residual sum-of-squares: 0.07525
Number of iterations to convergence: 5
Achieved convergence tolerance: 5.162e-06
You would do it the same way except you use the power equation you modeled. You can access the parameters the model calculated using z$m$getPars()
Here is a simple example to illustrate:
predict(z, list(x = 1))
Results in: 1.026125
Which equals the results of
z$m$getPars()["a"] * 1 ^ z$m$getPars()["b"]
Which is equivalet to y = a * x^b
Here are some ways.
1) with This evaluates the formula with respect to the coefficients:
x <- 1:2 # input
with(as.list(coef(z)), a * x^b)
## [1] 1.026125 9.437504
2) attach We could also use attach although it is generally frowned upon:
attach(as.list(coef(z)))
a * x^b
## [1] 1.026125 9.437504
3) explicit Explicit definition:
a <- coef(z)[["a"]]; b <- coef(z)[["b"]]
a * x^b
## [1] 1.026125 9.437504
4) eval This one extracts the formula from z so that we don't have to specify it again. formula(z)[[3]] is the right hand side of the formula used to produce z. Use of eval is sometimes frowned upon but this does avoid
the redundant specification of the formula.
eval(formula(z)[[3]], as.list(coef(z)))
## [1] 1.026125 9.437504

Resources