I am interested in using nls to aid in fitting the Langmuir Equation Y =(Qmax*k*X)/(1+(k*X)) similar to what was done in this post Fitting Non-linear Langmuir Isotherm in R. The parameter of the equation I am interested in is Qmax which corresponds to the horizontal asymptote (green line) of the plotted sorption data below. Is there a more robust approach other than nls or a way to improve my use of nls that I could employ to get a Qmax value as close as possible to the visual asymptote (green line) around Qmax=3200?
Lang <- nls(formula = Y ~ (Qmax*k*X)/(1+(k*X)), data = data, start = list(Qmax = 3600, k = 0.015), algorith = "port")
Using the following data:
X Y
1 3.08 84.735
2 5.13 182.832
3 6.67 251.579
4 9.75 460.077
5 16.30 779.350
6 25.10 996.540
7 40.80 1314.739
8 68.90 1929.422
9 111.00 2407.668
10 171.00 3105.850
11 245.00 3129.240
12 300.00 3235.000
I'm getting a Qmax = 4253.63 (red line) - approximately 1000 units away. Using upper and lower limits only results in a Qmax of what I set the upper limit to and changing initial values doesn't appear to change the outcome. Is this a challenge that can be solved with a different approach to non-linear regression than I've taken in base R or is this a statistical/mathematical problem first and foremost?
Plot of Non-linear Langmuir Isotherm
summary(Lang)
Formula: Y ~ (Qmax * k * X)/(1 + (k * X))
Parameters:
Estimate Std. Error t value Pr(>|t|)
Qmax 4.254e+03 1.554e+02 27.37 9.80e-11 ***
k 1.209e-02 1.148e-03 10.53 9.87e-07 ***
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
Residual standard error: 99.14 on 10 degrees of freedom
Algorithm "port", convergence message: relative convergence (4)
My attempt at the linearization of the model was less successful:
z <- 1/data
plot(Y~X,z)
abline(lm(Y~X,z))
M <- lm(Y~X,z)
Qmax <- 1/coef(M)[1]
#4319.22
k <- coef(M)[1]/coef(M)[2]
#0.00695
Disclaimer: This is my first post so please bear with me, and I'm relatively new to R. With that being said any technical advice that might help me improve my technique above would be greatly appreciated.
Not sure why you expect Qmax to be that low
I rewrote your dependency in a simplest form, removing multiplication and replacing it with addition (a => 1/k) by dividing both nominator and denominator by k. Result looks perfect to my eye.
library(ggplot2)
library(data.table)
dt <- fread("R/Langmuir.dat", sep = " ")
Lang <- nls(formula = Y ~ (Qmax*X)/(a+X), data = dt, start = list(Qmax = 3600, a = 100.0), algorithm = "port")
q <- summary(Lang)
Qmax <- q$coefficients[1,1]
a <- q$coefficients[2,1]
f <- function(x, Qmax, a) {
(Qmax*x)/(a+x)
}
p <- ggplot(data = dt, aes(x = X, y = Y))
p <- p + geom_point()
p <- p + xlab("T") + ylab("Q") + ggtitle("Langmuir Fit")
p <- p + stat_function(fun = function(x) f(x, Qmax=Qmax, a=a))
print(p)
print(Qmax)
print(a)
Output
4253.631
82.68501
Graph
UPDATE
Basically, too many points at low X, hard to get curve bending for lower Qmax. Designed way to make curve bend is to add weights. For example, if I add weights column after reading data table:
dt[, W := (as.numeric(N)/12.0)^3]
and run nls with weights
Lang <- nls(formula = Y ~ (Qmax*X)/(a+X), data = dt, start = list(Qmax = 3600, a = 100.0), weights = dt$W, algorithm = "port")
I'll get Qmax and a
[1] 4121.114
[1] 74.89386
with the following graph
Related
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
I wrote a binomial regression model to predict the prevalence of igneous stone, v, at an archaeological site based on proximity to a river, river_dist, but when I use the predict() function I'm getting odd cyclical results instead of the curve I was expecting. For reference, my data:
v n river_dist
1 102 256 1040
2 1 11 720
3 19 24 475
4 12 15 611
Which I fit to this model:
library(bbmle)
m_r <- mle2(ig$v ~ dbinom(size=ig$n, prob = 1/(1+exp(-(a + br * river_dist)))),
start = list(a = 0, br = 0), data = ig)
This produces a coefficient which, when back-transformed, suggests about 0.4% decrease in the likelihood of igneous stone per meter from the river (br = 0.996):
exp(coef(m_r))
That's all good. But when I try to predict new values, I get this odd cycling of values:
newdat <- data.frame(river_dist=seq(min(ig$river_dist), max(ig$river_dist),len=100))
newdat$v <- predict(m_r, newdata=newdat, type="response")
plot(v~river_dist, data=ig, col="red4")
lines(v ~ river_dist, newdat, col="green4", lwd=2)
Example of predicted values:
river_dist v
1 475.0000 216.855114
2 480.7071 9.285536
3 486.4141 20.187424
4 492.1212 12.571487
5 497.8283 213.762248
6 503.5354 9.150584
7 509.2424 19.888471
8 514.9495 12.381805
9 520.6566 210.476312
10 526.3636 9.007289
11 532.0707 19.571218
12 537.7778 12.180629
Why are the values cycling up and down like that, creating crazy spikes when graphed?
In order for newdata to work, you have to specify the variables as 'raw' values rather than with $:
library(bbmle)
m_r <- mle2(v ~ dbinom(size=n, prob = 1/(1+exp(-(a + br * river_dist)))),
start = list(a = 0, br = 0), data = ig)
At this point, as #user20650 suggests, you'll also have to specify a value (or values) for n in newdata.
This model appears to be identical to binomial regression: is there a reason not to use
glm(cbind(v,n-v) ~ river_dist, data=ig, family=binomial)
? (bbmle:mle2 is more general, but glm is much more robust.) (Also: fitting two parameters to four data points is theoretically fine, but you should not try to push the results too far ... in particular, a lot of the default results from GLM/MLE are asymptotic ...)
Actually, in double-checking the correspondence of the MLE fit with GLM I realized that the default method ("BFGS", for historical reasons) doesn't actually give the right answer (!); switching to method="Nelder-Mead" improves things. Adding control=list(parscale=c(a=1,br=0.001)) to the argument list, or scaling the river dist (e.g. going from "1 m" to "100 m" or "1 km" as the unit), would also fix the problem.
m_r <- mle2(v ~ dbinom(size=n,
prob = 1/(1+exp(-(a + br * river_dist)))),
start = list(a = 0, br = 0), data = ig,
method="Nelder-Mead")
pframe <- data.frame(river_dist=seq(500,1000,length=51),n=1)
pframe$prop <- predict(m_r, newdata=pframe, type="response")
CIs <- lapply(seq(nrow(ig)),
function(i) prop.test(ig[i,"v"],ig[i,"n"])$conf.int)
ig2 <- data.frame(ig,setNames(as.data.frame(do.call(rbind,CIs)),
c("lwr","upr")))
library(ggplot2); theme_set(theme_bw())
ggplot(ig2,aes(river_dist,v/n))+
geom_point(aes(size=n)) +
geom_linerange(aes(ymin=lwr,ymax=upr)) +
geom_smooth(method="glm",
method.args=list(family=binomial),
aes(weight=n))+
geom_line(data=pframe,aes(y=prop),colour="red")
Finally, note that your third-farthest site is an outlier (although the small sample size means it doesn't hurt much).
I have some time series data that looks like this:
x <- c(0.5833, 0.95041, 1.722, 3.1928, 3.941, 5.1202, 6.2125, 5.8828,
4.3406, 5.1353, 3.8468, 4.233, 5.8468, 6.1872, 6.1245, 7.6262,
8.6887, 7.7549, 6.9805, 4.3217, 3.0347, 2.4026, 1.9317, 1.7305,
1.665, 1.5655, 1.3758, 1.5472, 1.7839, 1.951, 1.864, 1.6638,
1.5624, 1.4922, 0.9406, 0.84512, 0.48423, 0.3919, 0.30773, 0.29264,
0.19015, 0.13312, 0.25226, 0.29403, 0.23901, 0.000213074755156413,
5.96565965097398e-05, 0.086874, 0.000926808687858284, 0.000904641782399267,
0.000513042259030044, 0.40736, 4.53928073402494e-05, 0.000765719624469057,
0.000717419263673946)
I would like to fit a curve to this data, using mixtures of one to five Gaussians. In Matlab, I could do the following:
fits{1} = fit(1:length(x),x,fittype('gauss1'));
fits{2} = fit(1:length(x),x,fittype('gauss2'));
fits{3} = fit(1:length(x),x,fittype('gauss3'));
... and so on.
In R, I am having difficulty identifying a similar method.
dat <- data.frame(time = 1:length(x), x = x)
fits[[1]] <- Mclust(dat, G = 1)
fits[[2]] <- Mclust(dat, G = 2)
fits[[3]] <- Mclust(dat, G = 3)
... but this does not really seem to be doing quite the same thing. For example, I am not sure how to calculate the R^2 between the fit curve and the original data using the Mclust solution.
Is there a simpler alternative in base R to fitting a curve using a mixture of Gaussians?
Function
With the code given below, and with a bit of luck in finding good initial parameters, you should be able to curve-fit Gaussian's to your data.
In the function fit_gauss, aim is to y ~ fit_gauss(x) and the number of Gaussians to use is determined by the length of the initial values for parameters: a, b, d all of which should be equal length
I have demonstrated curve-fitting of OP's data up to three Gaussian's.
Specifying Initial Values
This it pretty much most work I have done with nls (thanks to OP for that). So, I am not quite sure what is the best method select the initial values. Naturally, they depend on height's of peaks (a), mean and standard deviation of x around them (b and d).
One option would be for given number of Gaussian's, try with a number of starting values, and find the one that has best fit based on residual standard error fit$sigma.
I fiddled a bit to find initial parameters, but I dare say the parameters and
the plot with three Gaussian model looks solid.
Fitting one, two and thee Gaussian's to Example data
ind <- 1 : length(x)
# plot original data
plot(ind, x, pch = 21, bg = "blue")
# Gaussian fit
fit_gauss <- function(y, x, a, b, d) {
p_model <- function(x, a, b, d) {
rowSums(sapply(1:length(a),
function(i) a[i] * exp(-((x - b[i])/d[i])^2)))
}
fit <- nls(y ~ p_model(x, a, b, d),
start = list(a=a, b = b, d = d),
trace = FALSE,
control = list(warnOnly = TRUE, minFactor = 1/2048))
fit
}
Single Gaussian
g1 <- fit_gauss(y = x, x = ind, a=1, b = mean(ind), d = sd(ind))
lines(ind, predict(g1), lwd = 2, col = "green")
Two Gaussian's
g2 <- fit_gauss(y = x, x = ind, a = c(coef(g1)[1], 1),
b = c(coef(g1)[2], 30),
d = c(coef(g1)[1], 2))
lines(ind, predict(g2), lwd = 2, col = "red")
Three Gaussian's
g3 <- fit_gauss(y = x, x = ind, a=c(5, 4, 4),
b = c(12, 17, 11), d = c(13, 2, 2))
lines(ind, predict(g3), lwd = 2, col = "black")
Summery of fit with three Gaussian
summary(g3)
# Formula: x ~ p_model(ind, a, b, d)
#
# Parameters:
# Estimate Std. Error t value Pr(>|t|)
# a1 5.9307 0.5588 10.613 5.93e-14 ***
# a2 3.5689 0.7098 5.028 8.00e-06 ***
# a3 -2.2066 0.8901 -2.479 0.016894 *
# b1 12.9545 0.5289 24.495 < 2e-16 ***
# b2 17.4709 0.2708 64.516 < 2e-16 ***
# b3 11.3839 0.3116 36.538 < 2e-16 ***
# d1 11.4351 0.8568 13.347 < 2e-16 ***
# d2 1.8893 0.4897 3.858 0.000355 ***
# d3 1.0848 0.6309 1.719 0.092285 .
# ---
# Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
#
# Residual standard error: 0.7476 on 46 degrees of freedom
#
# Number of iterations to convergence: 34
# Achieved convergence tolerance: 8.116e-06
I want to estimate a binomial model with the R package MCMCglmm. The model shall incorporate an intercept and a slope - both as fixed and random parts. How do I have to specify an accepted prior? (Note, here is a similar question, but in a much more complicated setting.)
Assume the data have the following form:
y x cluster
1 0 -0.56047565 1
2 1 -0.23017749 1
3 0 1.55870831 1
4 1 0.07050839 1
5 0 0.12928774 1
6 1 1.71506499 1
In fact, the data have been generated by
set.seed(123)
nj <- 15 # number of individuals per cluster
J <- 30 # number of clusters
n <- nj * J
x <- rnorm(n)
y <- rbinom(n, 1, prob = 0.6)
cluster <- factor(rep(1:nj, each = J))
dat <- data.frame(y = y, x = x, cluster = cluster)
The information in the question about the model, suggest to specify fixed = y ~ 1 + x and random = ~ us(1 + x):cluster. With us() you allow the random effects to be correlated (cf. section 3.4 and table 2 in Hadfield's 2010 jstatsoft-article)
First of all, as you only have one dependent variable (y), the G part in the prior (cf. equation 4 and section 3.6 in Hadfield's 2010 jstatsoft-article) for the random effects variance(s) only needs to have one list element called G1. This list element isn't the actual prior distribution - this was specified by Hadfield to be an inverse-Wishart distribution. But with G1 you specify the parameters of this inverse-Whishart distribution which are the scale matrix ( in Wikipedia notation and V in MCMCglmm notation) and the degrees of freedom ( in Wikipedia notation and nu in MCMCglmm notation). As you have two random effects (the intercept and the slope) V has to be a 2 x 2 matrix. A frequent choice is the two dimensional identity matrix diag(2). Hadfield often uses nu = 0.002 for the degrees of freedom (cf. his course notes)
Now, you also have to specify the R part in the prior for the residual variance. Here again an inverse-Whishart distribution was specified by Hadfield, leaving the user to specify its parameters. As we only have one residual variance, V has to be a scalar (lets say V = 0.5). An optional element for R is fix. With this element you specify, whether the residual variance shall be fixed to a certain value (than you have to write fix = TRUE or fix = 1) or not (then fix = FALSE or fix = 0). Notice, that you don't fix the residual variance to be 0.5 by fix = 0.5! So when you find in Hadfield's course notes fix = 1, read it as fix = TRUE and look to which value of V it is was fixed.
All togehter we set up the prior as follows:
prior0 <- list(G = list(G1 = list(V = diag(2), nu = 0.002)),
R = list(V = 0.5, nu = 0.002, fix = FALSE))
With this prior we can run MCMCglmm:
library("MCMCglmm") # for MCMCglmm()
set.seed(123)
mod0 <- MCMCglmm(fixed = y ~ 1 + x,
random = ~ us(1 + x):cluster,
data = dat,
family = "categorical",
prior = prior0)
The draws from the Gibbs-sampler for the fixed effects are found in mod0$Sol, the draws for the variance parameters in mod0$VCV.
Normally a binomial model requires the residual variance to be fixed, so we set the residual variance to be fixed at 0.5
set.seed(123)
prior1 <- list(G = list(G1 = list(V = diag(2), nu = 0.002)),
R = list(V = 0.5, nu = 0.002, fix = TRUE))
mod1 <- MCMCglmm(fixed = y ~ 1 + x,
random = ~ us(1 + x):cluster,
data = dat,
family = "categorical",
prior = prior1)
The difference can be seen by comparing mod0$VCV[, 5] to mod1$VCV[, 5]. In the later case, all entries are 0.5 as specified.
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.