Analisi del punto di cambio usando R's nls ()

Sto cercando di implementare un'analisi del "punto di cambio" o una regressione multifase usando nls()in R.

Ecco alcuni dati falsi che ho creato . La formula che voglio usare per adattare i dati è:

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

Ciò che si suppone debba fare è adattare i dati fino a un certo punto con una certa intercettazione e pendenza ( e \ beta_1 ), quindi, dopo un certo valore x ( \ delta ), aumentare la pendenza di \ beta_2 . Questo è tutto ciò che riguarda il massimo. Prima del punto \ delta , sarà uguale a 0 e \ beta_2 verrà azzerato.$\beta_0$$\beta_1$$\delta$$\beta_2$$\delta$$\beta_2$

Quindi, ecco la mia funzione per fare questo:

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

E provo ad adattare il modello in questo modo

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

Ho scelto quei parametri iniziali, perché so che questi sono i parametri iniziali, perché ho creato i dati.

Tuttavia, ottengo questo errore:

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

Ho appena fatto dati sfavorevoli? Prima ho provato ad adattare questo dato ai dati reali e ho riscontrato lo stesso errore e ho solo pensato che i miei parametri iniziali di partenza non fossero abbastanza buoni.

(In un primo momento ho pensato che potrebbe essere un problema derivante dal fatto che maxnon è vettorializzare, ma che non è vero Si. Non fanno un dolore al lavoro con Changepoint, per cui la seguente modifica:

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

Questo post della mailing list di R-help descrive un modo in cui può verificarsi questo errore: il rhs della formula è sovraparametrizzato, in modo tale che la modifica di due parametri in tandem si adatti allo stesso modo ai dati. Non riesco a capire come sia vero il tuo modello, ma forse lo è.

In ogni caso, puoi scrivere la tua funzione oggettiva e minimizzarla. La seguente funzione fornisce l'errore al quadrato per i punti dati (x, y) e un certo valore dei parametri (la strana struttura dell'argomento della funzione è tenere conto di come optimfunziona):

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

Quindi diciamo:

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

E vedi:

$par
[1] 54.53436800 -0.09283594  2.07356459 48.00000006

Nota che per i miei dati falsi ( x <- 40:60; data <- changePoint(x, 50, 0, 2, 48) + rnorm(21, 0, 0.5)) ci sono molti massimi locali a seconda dei valori dei parametri iniziali che dai. Suppongo che se volessi prenderlo sul serio, chiameresti l'ottimizzatore molte volte con parametri iniziali casuali ed esaminerai la distribuzione dei risultati.

Volevo solo aggiungere che puoi farlo con molti altri pacchetti. Se vuoi ottenere una stima dell'incertezza attorno al punto di cambio (qualcosa che nls non può fare), prova il mcppacchetto.

# 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)

Tracciamolo con un intervallo di predizione (linea verde). La densità blu è la distribuzione posteriore per la posizione del punto di cambio:

# Plot it
plot(fit, q_predict = T)

È possibile controllare i singoli parametri in modo più dettagliato utilizzando plot_pars(fit)e summary(fit).