#########################################################################################
########## Ultrasonic Calibration Data - a log-hyperbolic semiparametric model ##########
#########################################################################################
library(NISTnls)
Chwirut <- Chwirut1[order(Chwirut1$x,Chwirut1$y),]
attach(Chwirut)
loc.f <- function(vP){
beta <- vP[1:3]
-beta[1]*x - log(beta[2] + beta[3]*x)
}
start <- c(b1=0.15, b2=0.005, b3=0.012)
fit <- ssym.nl(log(y),loc.f,start=start,ncs=x,family='Hyperbolic',xi=1,
local.influence=TRUE)
summary(fit)
####################### Plot of the fitted model ##############################
par(mfrow=c(4,2))
xl <- "Distance to the metal"
rx <- range(x)
plot(x,y,xlim=rx,ylim=range(y),type="p",cex=0.3,lwd=3,ylab="",xlab="")
par(new=TRUE)
plot(x,exp(fit$mu.fitted),xlim=rx,ylim=range(y),type="l",ylab="",xlab=xl,main="Median")
h <- fit$coefs.phi
ss <- splinek(as.numeric(levels(factor(x))),x)
gam <- solve(ss$R)sa <- ncs.graph(as.numeric(levels(factor(x))),h,gam,1000)
r <- (log(y) - fit$mu.fitted)^2/fit$xix
plot(x,r,xlim=rx,ylim=range(r),type="p",cex=0.3,lwd=3,ylab="",xlab="")
par(new=TRUE)
plot(sa[,1],exp(sa[,2]),xlim=rx,ylim=range(r),type="l",ylab="",xlab=xl,main="Skewness")
########################### Residual analysis ##################################
m1 <- "Residuals for the median submodel"
res.dev.mu <- sqrt(fit$deviance.mu)*ifelse(fit$z.hat>=0,1,-1)
yl <- c(min(res.dev.mu,-3.5),max(res.dev.mu,3.5))
plot(x,res.dev.mu,cex=0.3,lwd=3,ylim=yl,main=m1,xlab=xl,ylab="")
abline(h=-3,lty=3)
abline(h=+3,lty=3)
m2 <- "Residuals for the skewness submodel"
res.dev.phi <- sqrt(fit$deviance.phi)*ifelse(fit$z.hat>=0,1,-1)
yl <- c(min(res.dev.phi,-3.5),max(res.dev.phi,3.5))
plot(x,res.dev.phi,cex=0.3,lwd=3,ylim=yl,main=m2,xlab=xl,ylab="")
abline(h=-3,lty=3)
abline(h=+3,lty=3)
########################### Sensitivity analysis ##################################
m1 <- "Local Influence under case-weight perturbation scheme"
m2 <- "Total Local Influence under case-weight perturbation scheme"
plot(fit$cw[,1], type="h", main=m1, xlab="Index", ylab="")
plot(fit$cw[,2], type="h", main=m2, xlab="Index", ylab="")
m1 <- "Local Influence under response perturbation scheme"
m2 <- "Total Local Influence under response perturbation scheme"
plot(fit$pr[,1], type="h", main=m1, xlab="Index", ylab="")
plot(fit$pr[,2], type="h", main=m2, xlab="Index", ylab="")
#########################################################################################
############ European Rabbits Data - a Student-t semiparametric model #############
#########################################################################################
data(Erabbits)
Erabbits2 <- Erabbits[order(Erabbits$age,Erabbits$wlens),]
attach(Erabbits2)
loc.f <- function(vP){
beta <- vP[1:3]
exp(beta[1] - beta[2]/(beta[3] + age))
}
start <- c(b1=5.6, b2=128, b3=36.45)
fit <- ssym.nl(wlens,loc.f,start=start,ncs=age,family='Student',xi=5,
local.influence=TRUE)
summary(fit)
####################### Plot of the fitted model ##############################
par(mfrow=c(4,2))
xl <- "Age of the animal (in days)"
rx <- range(age)
ry <- range(wlens)
plot(age,wlens,xlim=rx,ylim=ry,type="p",cex=0.3,lwd=3,ylab="",xlab="")
par(new=TRUE)
plot(age,fit$mu.fitted,xlim=rx,ylim=ry,type="l",ylab="",xlab=xl,main="Mean")
h <- fit$coefs.phi
ss <- splinek(as.numeric(levels(factor(age))),age)
gam <- solve(ss$R)sa <- ncs.graph(as.numeric(levels(factor(age))),h,gam,1000)
r <- (wlens - fit$mu.fitted)^2/fit$xix
ry <- range(r)
plot(age,r,xlim=rx,ylim=ry,type="p",cex=0.3,lwd=3,ylab="",xlab="")
par(new=TRUE)
plot(sa[,1],exp(sa[,2]),xlim=rx,ylim=ry,type="l",ylab="",xlab=xl,main="Dispersion")
########################### Residual analysis ##################################
m1 <- "Residuals for the mean submodel"
res.dev.mu <- sqrt(fit$deviance.mu)*ifelse(fit$z.hat>=0,1,-1)
ry <- c(min(res.dev.mu,-3.5),max(res.dev.mu,3.5))
plot(age,res.dev.mu,cex=0.3,lwd=3,ylim=ry,main=m1,xlab=xl,ylab="")
abline(h=-3,lty=3)
abline(h=+3,lty=3)
m2 <- "Residuals for the dispersion submodel"
res.dev.phi <- sqrt(fit$deviance.phi)*ifelse(fit$z.hat>=0,1,-1)
ry <- c(min(res.dev.phi,-3.5),max(res.dev.phi,3.5))
plot(age,res.dev.phi,cex=0.3,lwd=3,ylim=ry,main=m2,xlab=xl,ylab="")
abline(h=-3,lty=3)
abline(h=+3,lty=3)
########################### Sensitivity analysis ##################################
m1 <- "Local Influence under case-weight perturbation scheme"
m2 <- "Total Local Influence under case-weight perturbation scheme"
plot(fit$cw[,1], type="h", main=m1, xlab="Index", ylab="")
plot(fit$cw[,2], type="h", main=m2, xlab="Index", ylab="")
m1 <- "Local Influence under response perturbation scheme"
m2 <- "Total Local Influence under response perturbation scheme"
plot(fit$pr[,1], type="h", main=m1, xlab="Index", ylab="")
plot(fit$pr[,2], type="h", main=m2, xlab="Index", ylab="")
Run the code above in your browser using DataLab