#########################################################################################
############## Texture of Snacks Data - a log-normal semiparametric model ###############
#########################################################################################
data(Snacks)
Snacks2 <- Snacks[order(Snacks$snack,Snacks$week,Snacks$texture),]
attach(Snacks2)
snack <- factor(snack)
week2 <- week^2
week3 <- week^3
fit <- ssym.l(log(texture),formula.mu=~snack + week2 + week3,formula.phi=~snack,
ncs=week,family='Normal',local.influence=TRUE)
summary(fit)
####################### Plot of the fitted model ##############################
par(mfrow=c(4,2))
rx <- range(week)
ry <- range(texture)
plot(week,texture,xlim=rx,ylim=ry,type="p",cex=0.3,lwd=3,ylab="",xlab="")
for(i in 1:5){
par(new=TRUE)
plot(week[snack==i],exp(fit$mu.fitted[snack==i]),xlim=rx,ylim=ry,
type="l",ylab="",xlab="",lty=i,main="Median")
}
legend(min(week),max(texture),lty=1:5,bty="n",legend=paste("snack",1:5))
h <- fit$coefs.phi[5:length(fit$coefs.phi)]
ss <- splinek(as.numeric(levels(factor(week))),week)
gam <- solve(ss$R)sa <- ncs.graph(as.numeric(levels(factor(week))),h,gam,1000)
r <- (log(texture) - fit$mu.fitted)^2/fit$xix
ry <- range(r)
plot(week,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="",lty=1)
for(i in 1:4){
par(new=TRUE)
plot(sa[,1],exp(sa[,2]+fit$coefs.phi[i]),xlim=rx,ylim=ry,type="l",ylab="",xlab="",
lty=i,main="Skewness")
}
legend(min(week),max(r),lty=1:5,bty="n",legend=paste("snack",1:5))
########################### Residual analysis ##################################
xl <- "Week"
m1 <- "Residuals for the median 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(week,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 skewness 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(week,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="")
#########################################################################################
################## Biaxial Fatigue Data - a Birnbaum-Saunders model ##################
#########################################################################################
data(Biaxial)
Biaxial2 <- Biaxial[order(Biaxial$Work,Biaxial$Life),]
attach(Biaxial2)
fit <- ssym.l(log(Life), formula.mu=~log(Work), family='Sinh-normal', xi=1.54,
local.influence=TRUE)
summary(fit)
####################### Plot of the fitted model ##############################
par(mfrow=c(3,2))
xl <- "Work per cycle"
rx <-range(Work)
ry <- range(Life)
plot(Work,Life,xlim=rx,ylim=ry,type="p",cex=0.3,lwd=3,ylab="",xlab="")
par(new=TRUE)
plot(Work,exp(fit$mu.fitted),xlim=rx,ylim=ry,type="l",ylab="Life",xlab=xl,main="Median")
########################### Residual analysis ##################################
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(Work,res.dev.mu,cex=0.3,lwd=3,ylim=ry,main="Residuals",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="")
########################################################################################
######### Gross Domestic Product per capita Data - a Birnbaum-Saunders model ###########
#########################################################################################
data(gdp)
attach(gdp)
gdp2010 <- sort(gdp2010)
fit <- ssym.l(log(gdp2010), family='Sinh-normal', xi=2.2)
summary(fit)
xl <- "GDP per capita 2010"
par(mfrow=c(1,2))
hist(gdp2010,xlim=range(gdp2010),ylim=c(0,0.00015),prob=TRUE,breaks=55,col="light gray",
border="dark gray",xlab="",main="",ylab="")
par(new=TRUE)
plot(gdp2010,exp(fit$lpdf)/gdp2010,xlim=range(gdp2010),ylim=c(0,0.00015),type="l",
xlab=xl,ylab="",main="Histogram")
plot(gdp2010,fit$cdfz,xlim=range(gdp2010),ylim=c(0,1),type="l",xlab="",ylab="")
par(new=TRUE)
plot(ecdf(gdp2010),xlim=range(gdp2010),ylim=c(0,1),verticals=TRUE,do.points=FALSE,
col="dark gray",xlab=xl,main="ecdf")
Run the code above in your browser using DataLab