Estou tentando ajustar uma função de decaimento exponencial aos valores y que se tornam negativos em valores x altos, mas não consigo configurar minha nlsfunção corretamente.

Alvo

Estou interessado na inclinação da função decay ( acordo com algumas fontes ). Como obtenho essa inclinação não é importante, mas o modelo deve ajustar meus dados da melhor maneira possível (por exemplo, linearizar o problema é aceitável , se o ajuste for bom; consulte "linearização"). No entanto, trabalhos anteriores sobre esse tópico usaram a seguinte função de decaimento exponencial ( artigo de acesso fechado de Stedmon et al., Equação 3 ): $\lambda$

$f(y) = a \times exp(-S \times x) + K$

onde Sestá a inclinação em que estou interessado, Ko fator de correção para permitir valores negativos e ao valor inicial para x(ou seja, interceptação).

Preciso fazer isso em R, pois estou escrevendo uma função que converte medidas brutas da matéria orgânica dissolvida cromofórica (CDOM) em valores nos quais os pesquisadores estão interessados.

Dados de exemplo

Devido à natureza dos dados, tive que usar o PasteBin. Os dados de exemplo estão disponíveis aqui .

Escreva dt <-e copie o código do PasteBin no seu console R. Ou seja,

dt <- structure(list(x = ...

Os dados são assim:

library(ggplot2)
ggplot(dt, aes(x = x, y = y)) + geom_point()

Valores y negativos ocorrem quando . $x > 540 nm$

Tentando encontrar solução usando `nls`

A tentativa inicial de usar nlsproduz uma singularidade, o que não deve ser uma surpresa, pois acabei de observar os valores iniciais dos parâmetros:

nls(y ~ a * exp(-S * x) + K, data = dt, start = list(a = 0.5, S = 0.1, K = -0.1))

# Error in nlsModel(formula, mf, start, wts) : 
#  singular gradient matrix at initial parameter estimates

Após esta resposta , posso tentar definir parâmetros de início melhores para ajudar a nlsfunção:

K0 <- min(dt$y)/2
mod0 <- lm(log(y - K0) ~ x, data = dt) # produces NaNs due to the negative values
start <- list(a = exp(coef(mod0)[1]), S = coef(mod0)[2], K = K0)
nls(y ~ a * exp(-S * x) + K, data = dt, start = start)

# Error in nls(y ~ a * exp(-S * x) + K, data = dt, start = start) : 
#  number of iterations exceeded maximum of 50

A função parece não conseguir encontrar uma solução com o número padrão de iterações. Vamos aumentar o número de iterações:

nls(y ~ a * exp(-S * x) + K, data = dt, start = start, nls.control(maxiter = 1000))

# Error in nls(y ~ a * exp(-S * x) + K, data = dt, start = start, nls.control(maxiter = 1000)) : 
#  step factor 0.000488281 reduced below 'minFactor' of 0.000976562

Mais erros. Chuck it! Vamos forçar a função a nos dar uma solução:

mod <- nls(y ~ a * exp(-S * x) + K, data = dt, start = start, nls.control(maxiter = 1000, warnOnly = TRUE))
mod.dat <- data.frame(x = dt$x, y = predict(mod, list(wavelength = dt$x)))

ggplot(dt, aes(x = x, y = y)) + geom_point() + 
  geom_line(data = mod.dat, aes(x = x, y = y), color = "red")

Bem, essa definitivamente não era uma boa solução ...

Linearizando o problema

Muitas pessoas linearizaram suas funções de decaimento exponencial com sucesso (fontes: 1 , 2 , 3 ). Nesse caso, precisamos garantir que nenhum valor de y seja negativo ou 0. Vamos tornar o valor mínimo de y o mais próximo possível de 0 dentro dos limites de ponto flutuante dos computadores :

K <- abs(min(dt$y)) 
dt$y <- dt$y + K*(1+10^-15)

fit <- lm(log(y) ~ x, data=dt)  
ggplot(dt, aes(x = x, y = y)) + geom_point() + 
geom_line(aes(x=x, y=exp(fit$fitted.values)), color = "red")

Muito melhor, mas o modelo não rastreia os valores y perfeitamente em valores x baixos.

Observe que a nlsfunção ainda não conseguiu ajustar o decaimento exponencial:

K0 <- min(dt$y)/2
mod0 <- lm(log(y - K0) ~ x, data = dt) # produces NaNs due to the negative values
start <- list(a = exp(coef(mod0)[1]), S = coef(mod0)[2], K = K0)
nls(y ~ a * exp(-S * x) + K, data = dt, start = start)

# Error in nlsModel(formula, mf, start, wts) : 
#  singular gradient matrix at initial parameter estimates

Os valores negativos são importantes?

Os valores negativos são obviamente um erro de medição, pois os coeficientes de absorção não podem ser negativos. E se eu fizer os valores y generosamente positivos? É no declive que me interessa. Se a adição não afeta o declive, eu devo decidir:

dt$y <- dt$y + 0.1

fit <- lm(log(y) ~ x, data=dt)  
ggplot(dt, aes(x = x, y = y)) + geom_point() + geom_line(aes(x=x, y=exp(fit$fitted.values)), color = "red")

Bem, isso não foi tão bem ... Valores altos de x devem obviamente ser o mais próximo possível de zero.

A questão

Obviamente, estou fazendo algo errado aqui. Qual é a maneira mais precisa de estimar a inclinação para uma função de decaimento exponencial ajustada em dados que possuem valores y negativos usando R?

r model exponential

— Mikko
fonte

11

nlsconvergiu para mim usando os valores iniciais . Alternativamente, você pode usar a função de auto-partida: . Isso converge para mim também.

a = 1, S = 0.01, K = - 0.0001

$a=1, S =0.01, K=-0.0001$ nls(y~SSasymp(x, Asym, r0, lrc), data = dt)

— COOLSerdash

10

Use uma função de auto-inicialização:

ggplot(dt, aes(x = x, y = y)) + 
  geom_point() +
  stat_smooth(method = "nls", formula = y ~ SSasymp(x, Asym, R0, lrc), se = FALSE)

fit <- nls(y ~ SSasymp(x, Asym, R0, lrc), data = dt)
summary(fit)
#Formula: y ~ SSasymp(x, Asym, R0, lrc)
#
#Parameters:
#       Estimate Std. Error  t value Pr(>|t|)    
#Asym -0.0001302  0.0004693   -0.277    0.782    
#R0   77.9103278  2.1432998   36.351   <2e-16 ***
#lrc  -4.0862443  0.0051816 -788.604   <2e-16 ***
#---
#Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
#
#Residual standard error: 0.007307 on 698 degrees of freedom
#
#Number of iterations to convergence: 0 
#Achieved convergence tolerance: 9.189e-08

exp(coef(fit)[["lrc"]]) #lambda
#[1] 0.01680222

No entanto, eu consideraria seriamente se o seu conhecimento de domínio não justifica definir a assíntota como zero. Eu acredito que sim e o modelo acima não discorda (veja o erro padrão / valor p do coeficiente).

ggplot(dt, aes(x = x, y = y)) + 
  geom_point() +
  stat_smooth(method = "nls", formula = y ~ a * exp(-S * x), 
              method.args = list(start = list(a = 78, S = 0.02)), se = FALSE, #starting values obtained from fit above
              color = "dark red")

— Roland
fonte

Perfeito. Eu não sabia sobre SSasympfunção. Obrigado! Acredito que os pesquisadores querem se referir ao artigo que citei na pergunta e usar o Ktermo, mas vou sugerir que modifiquem sua equação. Eu acho que eles querem manter o K, porque valores negativos significam que o instrumento não se comportou como o esperado, mas eles estão interessados na inclinação. A remoção da assíntota negativa pode afetar a inclinação em alguns casos.

— Mikko

@ Mikko Se você medir a absorção e a assíntota ficar significativamente zero, eu diria que você tem problemas com a calibração ou a estabilidade do instrumento.

— Roland

O problema geralmente ocorre quando a água é muito clara (água oceânica). Alguns valores ficam abaixo de zero. Acho que temos um instrumento que sofre de problemas de temperatura. Quando superaquece, os valores se tornam instáveis, mas esses detalhes provavelmente não devem ser tratados com validação cruzada.

— Mikko

3

Esta pergunta tem relações com várias outras perguntas

Tenho três observações adicionais sobre alguns pontos desta questão.

1: Por que o modelo linearizado não se ajusta bem aos grandes valores de $y$

Muito melhor, mas o modelo não rastreia os valores y perfeitamente em valores x baixos.

O ajuste linearizado não está minimizando os mesmos resíduos. Na escala logarítmica, os resíduos para valores menores serão maiores. A imagem abaixo mostra a comparação plotando o eixo y em uma escala de log na imagem correta:

Quando necessário, você pode adicionar pesos à função de perda de mínimos quadrados.

2: Usando ajuste linearizado como valores iniciais

Depois de obter estimativas com seu ajuste linearizado, você poderá usá-las como ponto de partida para o ajuste não linear. *

# vectors x and y from data
x <- dat$x
y <- dat$y

# linearized fit with zero correction
K <- abs(min(y)) 
dty <- y + K*(1+10^-15)
fit <- lm(log(dty) ~x)  


# old fit that had a singluar gradient matrix error
#         nls(y ~ a * exp(-S * x) + K, 
#                 start = list(a = 0.5, 
#                              S = 0.1, 
#                              K = -0.1))
#

# new fit
fitnls <- nls(y ~ a * exp(-S * x) + K, 
                  start = list(a = exp(fit$coefficients[1]), 
                               S = -fit$coefficients[2], 
                               K = -0.1))
#

3: Usando um método mais geral para obter o ponto de partida

Se você tiver pontos suficientes, também poderá obter a inclinação sem se preocupar com o valor assintótico e os valores negativos (não é necessário o cálculo de um logaritmo).

Você pode fazer isso integrando os pontos de dados. Em seguida, com e é possível utilizar um modelo linear para se obter o valor de , descrevendo como uma combinação linear dos vetores , e um intercepto:

y = a e^{s x} + k

$y = a e^{sx} + k$

Y = \frac{a}{s} e^{s x} + k x + C o n s t

$Y = \frac{a}{s} e^{sx} + kx + Const$

s

$s$

y

$y$

Y

$Y$

x

$x$

\begin{array}{rccccl} y & = & a e^{s x} + k & = & s (\frac{a}{s} e^{s x} + k x + C o n s t) & - s k x - s C o n s t \\ = & s Y & - s k x - s C o n s t \end{array}

$\begin{array}{rccccl}y &=& a e^{sx} + k &=& s(\frac{a}{s} e^{s x} + k x + Const) &- s k x - s Const \\ &&&=& sY &- sk x - s Const \end{array}$

A vantagem desse método (consulte Tittelbach e Helmrich 1993 "Um método de integração para a análise de sinais transitórios multiexponenciais" ) é que você pode estendê-lo a mais do que um único componente decadente exponencialmente (adicionando mais integrais).

#
# using Tittelbach Helmrich
#

# integrating with trapezium rule assuming x variable is already ordered
ys <- c(0,cumsum(0.5*diff(x)*(y[-1]+y[-length(y)])))

# getting slope parameter
modth <- lm(y ~ ys + x)
slope <- modth$coefficients[2]

# getting other parameters 
modlm <- lm(y ~ 1 + I(exp(slope*x)))
K <- modlm$coefficients[1]
a <- modlm$coefficients[2]

# fitting with TH start

fitnls2 <- nls(y ~ a * exp(-S * x) + K, 
              start = list(a = a, 
                           S = -slope, 
                           K = K))

Nota de rodapé: * Esse uso da inclinação no problema linearizado é exatamente o que a SSasympfunção de inicialização automática faz. Primeiro, estima a assíntota

> stats:::NLSstRtAsymptote.sortedXyData
function (xy) 
{
    in.range <- range(xy$y)
    last.dif <- abs(in.range - xy$y[nrow(xy)])
    if (match(min(last.dif), last.dif) == 2L) 
        in.range[2L] + diff(in.range)/8
    else in.range[1L] - diff(in.range)/8
}

e depois a inclinação (subtraindo o valor da assíntota e obtendo os valores do log)

> stats:::NLSstAsymptotic.sortedXyData
function (xy) 
{
    xy$rt <- NLSstRtAsymptote(xy)
    setNames(coef(nls(y ~ cbind(1, 1 - exp(-exp(lrc) * x)), data = xy, 
        start = list(lrc = log(-coef(lm(log(abs(y - rt)) ~ x, 
            data = xy))[[2L]])), algorithm = "plinear"))[c(2, 
        3, 1)], c("b0", "b1", "lrc"))
}

Observe a linha start = list(lrc = log(-coef(lm(log(abs(y - rt)) ~ x, data = xy))[[2L]]))

Nota: No caso especial de você pode usar $K=0$

plot(x,y)
mod <- glm(y~x, family = gaussian(link = log), start = c(2,-0.01))
lines(x,exp(predict(mod)),col=2)

que modela o parâmetro observado como $y$

y = e x p (X β) + ϵ = e x p (β_{0}) \cdot e x p (β_{1} \cdot x) + ϵ

$y = exp(X\beta) + \epsilon = exp(\beta_0) \cdot exp(\beta_1 \cdot x) + \epsilon$

— Sextus Empiricus
fonte

Ajustando decaimento exponencial com valores y negativos