Cambiar el análisis de puntos usando R's nls ()

Estoy tratando de implementar un análisis de "punto de cambio" o una regresión multifásica usando nls()en R.

Aquí hay algunos datos falsos que he hecho . La fórmula que quiero usar para ajustar los datos es:

$y = \beta_0 + \beta_1x + \beta_2\max(0,x-\delta)$

Lo que se supone que debe hacer es ajustar los datos hasta cierto punto con una cierta intersección y pendiente ( y ), luego, después de cierto valor de x ( ), aumente la pendiente en . De eso se trata toda la cuestión de max. Antes del punto , será igual a 0 y se pondrá a cero.β 1 δ β 2 δ β $\beta_0$$\beta_1$$\delta$$\beta_2$$\delta$$\beta_2$

Entonces, aquí está mi función para hacer esto:

changePoint <- function(x, b0, slope1, slope2, delta){ 
   b0 + (x*slope1) + (max(0, x-delta) * slope2)
}

Y trato de ajustar el modelo de esta manera

nls(y ~ changePoint(x, b0, slope1, slope2, delta), 
    data = data, 
    start = c(b0 = 50, slope1 = 0, slope2 = 2, delta = 48))

Elegí esos parámetros iniciales, porque sé que esos son los parámetros iniciales, porque hice los datos.

Sin embargo, me sale este error:

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

¿Acabo de hacer datos desafortunados? Primero intenté ajustar esto en datos reales, y estaba obteniendo el mismo error, y me di cuenta de que mis parámetros iniciales no eran lo suficientemente buenos.

(Al principio pensé que podría ser un problema que resulta del hecho de que maxno esté vectorizado, pero eso no es verdad Es. No lo convierten en un dolor de trabajar con ChangePoint, por lo cual la siguiente modificación:

changePoint <- function(x, b0, slope1, slope2, delta) { 
   b0 + (x*slope1) + (sapply(x-delta, function (t) max(0, t)) * slope2)
}

Esta publicación de la lista de correo de R-help describe una forma en que puede producirse este error: la rhs de la fórmula está sobreparamizada, de modo que cambiar dos parámetros en conjunto proporciona el mismo ajuste a los datos. No puedo ver cómo eso es cierto para su modelo, pero tal vez lo sea.

En cualquier caso, puede escribir su propia función objetivo y minimizarla. La siguiente función proporciona el error al cuadrado para los puntos de datos (x, y) y un cierto valor de los parámetros (la estructura de argumento extraño de la función es dar cuenta de cómo optimfunciona):

sqerror <- function (par, x, y) {
  sum((y - changePoint(x, par[1], par[2], par[3], par[4]))^2)
}

Entonces decimos:

optim(par = c(50, 0, 2, 48), fn = sqerror, x = x, y = data)

Y ver:

$par
[1] 54.53436800 -0.09283594  2.07356459 48.00000006

Tenga en cuenta que para mis datos falsos ( x <- 40:60; data <- changePoint(x, 50, 0, 2, 48) + rnorm(21, 0, 0.5)) hay muchos máximos locales dependiendo de los valores de parámetros iniciales que proporcione. Supongo que si quisieras tomar esto en serio, llamarías al optimizador muchas veces con parámetros iniciales aleatorios y examinarías la distribución de resultados.

Solo quería agregar que puede hacer esto con muchos otros paquetes. Si desea obtener una estimación de la incertidumbre en torno al punto de cambio (algo que nls no puede hacer), pruebe el mcppaquete.

# Simulate the data
df = data.frame(x = 1:100)
df$y = c(rnorm(20, 50, 5), rnorm(80, 50 + 1.5*(df$x[21:100] - 20), 5))

# Fit the model
model = list(
  y ~ 1,  # Intercept
  ~ 0 + x  # Joined slope
)
library(mcp)
fit = mcp(model, df)

Tracemos con un intervalo de predicción (línea verde). La densidad azul es la distribución posterior para la ubicación del punto de cambio:

# Plot it
plot(fit, q_predict = T)

Puede inspeccionar parámetros individuales con más detalle utilizando plot_pars(fit)y summary(fit).