#################################################################
#################################################################
#########  Preamble  ############################################
#################################################################
#################################################################

#setwd("...")


######################################################################################
#     supporting functions									 #
######################################################################################
# center a vector
center<-function(v)  v - mean(v)

# normalize a vector
norm<-function(v)  
{ 
  sumv2<-sum(v^2)
  if(sumv2 == 0) sumv2<-1
  v/sqrt(sumv2)
}

# Gram-Schmidt orthonormalization
orthnormal<-function(X)
{
  X<-as.matrix(X)
  n<-nrow(X)
  p<-ncol(X)
  
  W<-NULL
  if(p > 1) {
    W<-cbind(W, X[,1])
    for(k in 2:p) {
      gw<-rep(0, n)
      for(i in 1:(k-1)) {
        gki<-as.vector((t(W[,i]) %*% X[,k])/(t(W[,i]) %*% W[,i]))
        gw<-gw + gki * W[,i]
      }
      W<-cbind(W, X[,k] - gw)
    }
  } else {
    W<-cbind(W, X[,1])
  }
  
  W<-apply(W, 2, norm)
  W
}

# covariance matrix 
cov.x<-function(X)
{
  Xc<-apply(X, 2, center)
  t(Xc) %*% Xc / nrow(Xc)
}

# square-root of a matrix
mat.sqrt<-function(A)
{
  ei<-eigen(A)
  d<-ei$values
  d<-(d+abs(d))/2
  d2<-sqrt(d)
  ans<-ei$vectors %*% diag(d2) %*% t(ei$vectors)
  return(ans)
}

# square-root-inverse of a matrix
mat.sqrt.inv<-function(A)
{
  ei<-eigen(A)
  d<-ei$values
  d<-(d+abs(d))/2
  d2<-1 / sqrt(d)
  d2[d == 0]<-0
  ans<-ei$vectors %*% diag(d2) %*% t(ei$vectors)
  return(ans)
}


partial.sir = function(X, Y, Xcat, ncat , nslices, Xcat.com=F )
{ 
  n = nrow(X)
  p = ncol(X)
  Y = matrix(Y, nrow=n)
  q = ncol(Y)
  H = nslices
  
  if(Xcat.com==F){
    num = rep(0,ncat)  
    for (j in 1:ncat){for (i in 1:n){if (Xcat[i]==j-1) num[j]=num[j]+1}}
    ns = cumsum(num)
  }else{
    nx = floor(nrow(X)/ncat)
    num = c(rep(nx,ncat-1),nrow(X)-(ncat-1)*nx)
    ns = cumsum(num)
  }
  
  data = matrix(c(X,Y,Xcat),n,p+q+1)
  data = data[order(data[,p+q+1]), ]
  data = data[,-(p+q+1)]
  M = matrix(0,p,p)
  Mhat = array(0,dim=c(p, p,ncat))
  Mhat1 = array(0,dim=c(p, p,ncat))
  
  data1 = array(0,dim=c(n,p+q,ncat))
  for (j in 1:ncat){ if (j==1) data1[1:num[j],,j] = data[1:num[j],]
  else data1[1:num[j],,j] = data[(ns[j-1]+1):(ns[j]),]}
  
  sigma = matrix(0,p,p)
  for (j in 1:ncat){
    sigma = sigma + (num[j]/n)*cov(data1[1:num[j],1:p,j])}
  sigma.x2 = mat.sqrt(sigma)
  sigmamrt = mat.sqrt.inv(sigma)
  
  for (j in 1:ncat)
    
  {
    xb = apply(data1[1:num[j],1:p,j], 2, mean)
    xb = t(matrix(xb, p, num[j]))
    x1 = data1[1:num[j],1:p,j] - xb
    z = as.matrix(x1)%*%sigmamrt        
    
    
    ynew = data1[1:num[j],((p+1):(p+q)),j]
    datanew = matrix(c(z,ynew),num[j],p+q) 
    datanew = datanew[order(datanew[,p+1]), ]
    
    znew = datanew[,1:p]
    nx = num[j]/H
    msir = matrix(0, p, p)
    zh = matrix(0, p, H)
    
    for (sl in 1:H)  
    {
      znewh = znew[((sl-1)*nx+1):(sl*nx), ]
      zh[ , sl] = colMeans(znewh)
    }
    
    Mhat[,,j] = zh%*%t(zh)/H
  }
  
  for (i in 1:ncat)  { M = M + (num[i]/n)*Mhat[,,i]}
  M.ppr = sigma.x2 %*% M %*% sigma.x2
  
  # determine d here using the chi-square test of Chiaromonte et al(2002)
  
  chi.calc = rep(0,H)
  chi.tab = rep(0,H)
  df = rep(0,H)
  pvalue=rep(0,H)
  for(i in 0:(H-1)){
    chi.calc[i+1]=n*sum(eigen(M)$val[(i+1):p])
    df[i+1]=(ncat*H-i-ncat)*(p-i)
    chi.tab[i+1]=qchisq(0.05,df[i+1], ncp=0, lower.tail =  F, log.p = FALSE)
    pvalue[i+1] = pchisq(q = chi.calc[i+1],df = df[i+1], ncp = 0, lower.tail =  F, log.p = FALSE)
  }
  
  testing = cbind(Stat=chi.calc, df=df, p.value=pvalue)
  rownames(testing) = paste(0:(H-1),'D vs >= ', 1:H, 'D',sep='')
  
  d=0
  k=1
  while(chi.calc[k]>chi.tab[k] & d < H-1){ d=d+1;k=k+1}
  
  m = mat.sqrt(M.ppr)
  v = eigen(M)$vectors[,1:d]
  if(d == 1) v = matrix(v, ncol=1)
  beta.ppr<-sigmamrt %*% v
  beta.ppr<-apply(beta.ppr, 2, norm)
  ans = list(m=m, G=sigma, beta.sdr=beta.ppr, d=d, test = testing)
  
  
  return(ans)
}


library(car)
library(xtable)
library(dr)
library(lme4)
library(gplm)
library(HoRM)
library(mgcv)
library(car)
library(visreg)
library(plyr)
library(ggplot2)
library(ElemStatLearn)
library(SemiPar)
library(np)
library(gridExtra)
library(grid)
library(MASS)
library(GGally)
library(sfsmisc)
library(fiftystater)

#################################################################
#################################################################
#########  Clean Data ###########################################
#################################################################
#################################################################

Data = read.csv('PDB_2015_Block_Group.csv')

## remove Puerto Rico
index.woPRC = which(Data[,3] != 'Puerto Rico Commonwealth')

## 83: no insurance, 79: one insurance, 81: more than two  insurance;
Y = Data[index.woPRC, c(83,79,81)] 
X = Data[index.woPRC,c(3,73,77,103,112,115,124,130,132,145,149,151,153,155,167,169)]
X[,c(7,8,14,15)+1] = sapply(c(7,8,14,15)+1,function(i) as.numeric(gsub('[$,]','',as.character(X[,i]))))
rm(Data)

## remove the missing obs 
Dat = cbind(X,Y)
DatX = as.matrix(X[complete.cases(Dat),])
DatY = as.matrix(Y[complete.cases(Dat),])
rm(Dat)
rm(X)
rm(Y)

## transformation
X.ori = DatX[,-1]
X.ori = apply(X.ori, 2, function(x) as.numeric(x))
summary(bc<-powerTransform(X.ori+0.5))

tranX <- bcPower(X.ori+0.5,coef(bc,round=TRUE))
DatX = cbind(DatX[,1],tranX)
newX = apply(DatX[,-1], 2, function(x) as.numeric(x))


#################################################################
#################################################################
#########  calculate the VIF ####################################
#################################################################
#################################################################

colnames(newX) = paste('X',1:15,sep='')
colnames(DatY) = paste('Y',c(2,3,1), sep='')
newdata = data.frame(cbind(newX,DatY))

out1 = vif(lm(Y1~.-Y2-Y3,data=newdata))
out2 = vif(lm(Y2~.-Y1-Y3,data=newdata))
out3 = vif(lm(Y3~.-Y1-Y2,data=newdata))

tab = cbind(out1,out2,out3)
colnames(tab) = paste('Y',1:3,sep='')
xtable(tab, caption = 'VIF values for Y1-Y3.', digits=4)


#################################################################
#################################################################
#########  Testing Dimension  ###################################
#################################################################
#################################################################

## SIR 
# Y1
sir1 <- dr(DatY[,1]~newX, method='sir', nslice = 100,numdir = 10)
sum = summary(sir1)
xtable(sum$test,caption = 'Test for Dimension using SIR For Y1',digits = 4)
table=sum$evectors[,1:5]
rownames(table) = paste('X',1:15,sep='')
xtable(table,caption = 'evectors using SIR For Y1',digits = 4)
# Y2
sir2 <- dr(DatY[,2]~newX, method='sir', nslice = 100,numdir = 10)
sum = summary(sir2)
xtable(sum$test,caption = 'Test for Dimension using SIR For Y2',digits = 4)
table=sum$evectors[,1:6]
rownames(table) = paste('X',1:15,sep='')
xtable(table,caption = 'evectors using SIR For Y2',digits = 4)
# Y3
sir3 <- dr(DatY[,3]~newX, method='sir', nslice = 100,numdir = 10)
sum = summary(sir3)
xtable(sum$test,caption = 'Test for Dimension using SIR For Y3',digits = 4)
table=sum$evectors[,1:3]
rownames(table) = paste('X',1:15,sep='')
xtable(table,caption = 'evectors using SIR For Y3',digits = 4)

## SAVE
# Y1
save1 <- dr(DatY[,1]~newX, method='save', nslice = 100,numdir = 15)
sum = summary(save1)
xtable(sum$test,caption = 'Test for Dimension using SAVE For Y1',digits = 4)

# Y2
save2 <- dr(DatY[,2]~newX, method='save', nslice = 100,numdir = 15)
sum = summary(save2)
xtable(sum$test,caption = 'Test for Dimension using SAVE For Y2',digits = 4)

# Y3
save3 <- dr(DatY[,3]~newX, method='save', nslice = 100,numdir = 15)
sum = summary(save3)
xtable(sum$test,caption = 'Test for Dimension using SAVE For Y3',digits = 4)


## yPHD
# Y1
phdy1 <- dr(DatY[,1]~newX, method='phdy', nslice = 100,numdir = 15)
sum = summary(phdy1)
xtable(sum$test,caption = 'Test for Dimension using yPHD For Y1',digits = 4)

# Y2
phdy2 <- dr(DatY[,2]~newX, method='phdy', nslice = 100,numdir = 15)
sum = summary(phdy2)
xtable(sum$test,caption = 'Test for Dimension using yPHD For Y2',digits = 4)

# Y3
phdy3 <- dr(DatY[,3]~newX, method='phdy', nslice = 100,numdir = 15)
sum = summary(phdy3)
xtable(sum$test,caption = 'Test for Dimension using yPHD For Y3',digits = 4)


## resPHD
# Y1
phdres1 <- dr(DatY[,1]~newX, method='phdres', nslice = 100,numdir = 15)
sum = summary(phdres1)
xtable(sum$test,caption = 'Test for Dimension using rPHD For Y1',digits = 4)

# Y2
phdres2 <- dr(DatY[,2]~newX, method='phdres', nslice = 100,numdir = 15)
sum = summary(phdy2)
xtable(sum$test,caption = 'Test for Dimension using rPHD For Y2',digits = 4)

# Y3
phdres3 <- dr(DatY[,3]~newX, method='phdres', nslice = 100,numdir = 15)
sum = summary(phdres3)
xtable(sum$test,caption = 'Test for Dimension using rPHD For Y3',digits = 4)



#################################################################
#################################################################
#########  PSIR  categorical  ###################################
#################################################################
#################################################################

Division = list(
  Div1 = c('Connecticut', 'Maine', 'Massachusetts', 'New Hampshire', 'Rhode Island', 'Vermont'),
  Div2 = c('New Jersey', 'New York', 'Pennsylvania'),
  Div3 = c('Illinois', 'Indiana', 'Michigan', 'Ohio', 'Wisconsin'),
  Div4 = c('Iowa', 'Kansas', 'Minnesota', 'Missouri', 'Nebraska', 'North Dakota', 'South Dakota'),
  Div5 = c('Delaware', 'District of Columbia', 'Florida', 'Georgia', 'Maryland', 'North Carolina', 'South Carolina', 'Virginia', 'West Virginia'),
  Div6 = c('Alabama', 'Kentucky', 'Mississippi', 'Tennessee'),
  Div7 = c('Arkansas', 'Louisiana', 'Oklahoma', 'Texas'),
  Div8 = c('Arizona', 'Colorado', 'Idaho', 'Montana', 'Nevada', 'New Mexico', 'Utah', 'Wyoming'),
  Div9 = c('Alaska', 'California', 'Hawaii', 'Oregon', 'Washington')
)

name = unlist(attr(table(DatX[,1]),"dimnames"))
Div = rep(0,length(name))
for(j in 1:length(name)){
  Div[j] = which(sapply(1:9, function(i) name[j] %in% Division[[i]])==T)-1
}

X = newX
ncat = 9
mn = 100
nslices = 15
No.obs = table(DatX[,1]) 
Xcat = unlist(sapply(1:51, function(i) rep(Div[i],times = as.numeric(No.obs[i]))))

# Y1
k=1
Y = as.matrix(DatY[,k])
out.psir = partial.sir(X,Y,Xcat,ncat,nslices,F)
test = out.psir$test
xtable(test,caption = 'Test for Dimension using partial SIR For Y1.',digits = 4)
d = out.psir$d
table=out.psir$beta.sdr
rownames(table) = paste('X',1:15,sep='')
xtable(table,caption = 'Coefficient using PSIR For Y1',digits = 4)
lm.X = newX %*% out.psir$beta.sdr

# Y2
k=2
Y = as.matrix(DatY[,k])
out.psir = partial.sir(X,Y,Xcat,ncat,nslices,F)
test = out.psir$test
xtable(test,caption = 'Test for Dimension using partial SIR For Y2.',digits = 4)
d = out.psir$d
table=out.psir$beta.sdr
rownames(table) = paste('X',1:15,sep='')
xtable(table,caption = 'Coefficient using PSIR For Y2',digits = 4)
lm.X = newX %*% out.psir$beta.sdr

# Y3
k=3
Y = as.matrix(DatY[,k])
out.psir = partial.sir(X,Y,Xcat,ncat,nslices,F)
test = out.psir$test
xtable(test,caption = 'Test for Dimension using partial SIR For Y3.',digits = 4)
d = out.psir$d
table=out.psir$beta.sdr
rownames(table) = paste('X',1:15,sep='')
xtable(table,caption = 'Coefficient using PSIR For Y3.',digits = 4)
lm.X = newX %*% out.psir$beta.sdr


#################################################################
#################################################################
#########  Scatter plots and Maps  ##############################
#################################################################
#################################################################

No.obs = table(DatX[,1])
cum = cumsum(No.obs)

#####################################################
##############  PCA y1 ##############################
#####################################################
k = 6 
X = scale(newX)
pca = prcomp(X)
lm.X = X %*% pca$rotation[,1:k] 
colnames(lm.X) = paste('D',1:k,sep = '')
lm.Y = DatY[,1]
data.f = data.frame(cbind(lm.X, lm.Y))

## BIC 
bic = c()
out.am <- gam(lm.Y ~ s(D1, k = 3) + s(D2, k=3) + s(D3, k = 3) + s(D4, k=3) + s(D5, k = 3) + s(D6, k=3),
              data = data.f)
summary(out.am)
bic = c(bic,BIC(out.am))# D4, D6, D2, D3, D5
bic

## Scatter plot
var.names = c(D1 = "Dimension 1", D2 = 'Dimension 2',D3 = "Dimension 3",D4 = "Dimension 4", D5 = 'Dimension 5', D6 = "Dimension 6")

plot.am <- visreg(out.am, type = "contrast", plot = FALSE)
smooths <- ldply(plot.am, function(part) data.frame(Variable = part$meta$x, x = part$fit[[part$meta$x]], 
                                                    smooth = part$fit$visregFit, lower = part$fit$visregLwr, upper = part$fit$visregUpr))

res.am <- ldply(plot.am, function(part) data.frame(Variable = part$meta$x, x = part$res[[part$meta$x]], 
                                                   y = part$res$visregRes))

ggplot(smooths, aes(x, smooth)) + 
  geom_line(aes(y = upper), linetype = "dashed") + 
  facet_wrap(~Variable, scales = "free_x",labeller = as_labeller(var.names)) + 
  geom_point(data = res.am, color='red', size=0.25, aes(x, y)) + 
  geom_line() + geom_line(aes(y = lower), linetype = "dashed") + 
  geom_rug(data = res.am, aes(x, y), sides = "b", color = "blue") + theme(text = element_text(size = 15)) + 
  xlab("") + ylab("Smooth")


## Map
index <-function(cum, i){
  if(i==1) return(1:cum[i])
  else return((cum[i-1]+1):cum[i])
}

pca_y1_state_gam = sapply(1:length(No.obs), function(i) 
  c(mean(out.am$residuals[index(cum,i)]), median(out.am$residuals[index(cum,i)]))) #k =6
data("fifty_states") # this line is optional due to lazy data loading

crimes <- data.frame(state = tolower(rownames(USArrests)), 
                     Mean = (pca_y1_state_gam[1,])[-9],
                     Median = (pca_y1_state_gam[2,])[-9])

# map_id creates the aesthetic mapping to the state name column in your data
p <- ggplot(crimes, aes(map_id = state)) + 
  # map points to the fifty_states shape data
  geom_map(aes(fill = Mean), map = fifty_states, color='black') + 
  expand_limits(x = fifty_states$long, y = fifty_states$lat) +
  coord_map() +
  scale_fill_gradient(low='white', high='grey20', name=expression(Y[1])) +
  scale_x_continuous(breaks = NULL) + 
  scale_y_continuous(breaks = NULL) +
  labs(x = "", y = "") +
  theme(legend.position = "bottom", 
        panel.background = element_blank())

p
# add border boxes to AK/HI
p + fifty_states_inset_boxes() 

#####################################################
##############  PCA y2 ##############################
#####################################################
k = 6 
X = scale(newX)
pca = prcomp(X)
lm.X = X %*% pca$rotation[,1:k] 
colnames(lm.X) = paste('D',1:k,sep = '')
lm.Y = DatY[,2]
data.f = data.frame(cbind(lm.X, lm.Y))

## BIC
bic = c()
out.am <- gam(lm.Y ~ s(D1, k = 3) + s(D2, k=3) + s(D3, k = 3) + s(D4, k=3) + s(D5, k = 3) + s(D6, k=3),
              data = data.f)
summary(out.am)
bic = c(bic,BIC(out.am))# D4, D6, D2, D3, D5
bic

## Scatter plot
var.names = c(D1 = "Dimension 1", D2 = 'Dimension 2',D3 = "Dimension 3",D4 = "Dimension 4", D5 = 'Dimension 5', D6 = "Dimension 6")

plot.am <- visreg(out.am, type = "contrast", plot = FALSE)
smooths <- ldply(plot.am, function(part) data.frame(Variable = part$meta$x, x = part$fit[[part$meta$x]], 
                                                    smooth = part$fit$visregFit, lower = part$fit$visregLwr, upper = part$fit$visregUpr))

res.am <- ldply(plot.am, function(part) data.frame(Variable = part$meta$x, x = part$res[[part$meta$x]], 
                                                   y = part$res$visregRes))

ggplot(smooths, aes(x, smooth)) + 
  geom_line(aes(y = upper), linetype = "dashed") + 
  facet_wrap(~Variable, scales = "free_x",labeller = as_labeller(var.names)) + 
  geom_point(data = res.am, color='red', size=0.25, aes(x, y)) + 
  geom_line() + geom_line(aes(y = lower), linetype = "dashed") + 
  geom_rug(data = res.am, aes(x, y), sides = "b", color = "blue") + theme(text = element_text(size = 15)) + 
  xlab("") + ylab("Smooth")

## Map
index <-function(cum, i){
  if(i==1) return(1:cum[i])
  else return((cum[i-1]+1):cum[i])
}

pca_y2_state_gam = sapply(1:length(No.obs), function(i) 
  c(mean(out.am$residuals[index(cum,i)]), median(out.am$residuals[index(cum,i)]))) #k =6
data("fifty_states") # this line is optional due to lazy data loading

crimes <- data.frame(state = tolower(rownames(USArrests)), 
                     Mean = (pca_y2_state_gam[1,])[-9],
                     Median = (pca_y2_state_gam[2,])[-9])

# map_id creates the aesthetic mapping to the state name column in your data
p <- ggplot(crimes, aes(map_id = state)) + 
  # map points to the fifty_states shape data
  geom_map(aes(fill = Mean), map = fifty_states, color='black') + 
  expand_limits(x = fifty_states$long, y = fifty_states$lat) +
  coord_map() +
  scale_fill_gradient(low='white', high='grey20', name=expression(Y[2])) +
  scale_x_continuous(breaks = NULL) + 
  scale_y_continuous(breaks = NULL) +
  labs(x = "", y = "") +
  theme(legend.position = "bottom", 
        panel.background = element_blank())

p
# add border boxes to AK/HI
p + fifty_states_inset_boxes() 


#####################################################
##############  PCA y3 ##############################
#####################################################
k = 6 
X = scale(newX)
pca = prcomp(X)
lm.X = X %*% pca$rotation[,1:k] 
colnames(lm.X) = paste('D',1:k,sep = '')
lm.Y = DatY[,3]
data.f = data.frame(cbind(lm.X, lm.Y))

## BIC
bic = c()
out.am <- gam(lm.Y ~ s(D1, k = 3) + s(D2, k=3) + s(D3, k = 3) + s(D4, k=3) + s(D5, k = 3) + s(D6, k=3),
              data = data.f)
summary(out.am)
bic = c(bic,BIC(out.am))# D4, D6, D2, D3, D5
bic

## Scatter plot
var.names = c(D1 = "Dimension 1", D2 = 'Dimension 2',D3 = "Dimension 3",D4 = "Dimension 4", D5 = 'Dimension 5', D6 = "Dimension 6")

plot.am <- visreg(out.am, type = "contrast", plot = FALSE)
smooths <- ldply(plot.am, function(part) data.frame(Variable = part$meta$x, x = part$fit[[part$meta$x]], 
                                                    smooth = part$fit$visregFit, lower = part$fit$visregLwr, upper = part$fit$visregUpr))

res.am <- ldply(plot.am, function(part) data.frame(Variable = part$meta$x, x = part$res[[part$meta$x]], 
                                                   y = part$res$visregRes))

ggplot(smooths, aes(x, smooth)) + 
  geom_line(aes(y = upper), linetype = "dashed") + 
  facet_wrap(~Variable, scales = "free_x",labeller = as_labeller(var.names)) + 
  geom_point(data = res.am, color='red', size=0.25, aes(x, y)) + 
  geom_line() + geom_line(aes(y = lower), linetype = "dashed") + 
  geom_rug(data = res.am, aes(x, y), sides = "b", color = "blue") + theme(text = element_text(size = 15)) + 
  xlab("") + ylab("Smooth")


## Map
index <-function(cum, i){
  if(i==1) return(1:cum[i])
  else return((cum[i-1]+1):cum[i])
}

pca_y3_state_gam = sapply(1:length(No.obs), function(i) 
  c(mean(out.am$residuals[index(cum,i)]), median(out.am$residuals[index(cum,i)]))) #k =6
data("fifty_states") # this line is optional due to lazy data loading

crimes <- data.frame(state = tolower(rownames(USArrests)), 
                     Mean = (pca_y3_state_gam[1,])[-9],
                     Median = (pca_y3_state_gam[2,])[-9])

# map_id creates the aesthetic mapping to the state name column in your data
p <- ggplot(crimes, aes(map_id = state)) + 
  # map points to the fifty_states shape data
  geom_map(aes(fill = Mean), map = fifty_states, color='black') + 
  expand_limits(x = fifty_states$long, y = fifty_states$lat) +
  coord_map() +
  scale_fill_gradient(low='white', high='grey20', name=expression(Y[3])) +
  scale_x_continuous(breaks = NULL) + 
  scale_y_continuous(breaks = NULL) +
  labs(x = "", y = "") +
  theme(legend.position = "bottom", 
        panel.background = element_blank())

p
# add border boxes to AK/HI
p + fifty_states_inset_boxes() 

#####################################################
##############   SIR y1 ##############################
#####################################################
k = 5 # y1:6, y2:4, y3:6
sir <- dr(DatY[,1]~newX, method='sir', nslice = 100,numdir = 10)
Coe.Matrx = sir$evectors[,1:k]  
lm.X = newX %*% Coe.Matrx
colnames(lm.X) = paste('D',1:k,sep = '')
lm.Y = DatY[,1]
data.f = data.frame(cbind(lm.X, lm.Y))


## BIC
bic = c()
out.am <- gam(lm.Y ~ s(D1, k = 3) + s(D2, k=3) + s(D3, k = 3) + s(D4, k=3) + s(D5, k=3),
              data = data.f)
summary(out.am)
bic = c(bic,BIC(out.am))# D4, D6, D2, D3, D5
bic

out.am <- gam(lm.Y ~ s(D1, k = 3) + s(D2, k=3) + s(D3, k = 3) + s(D5, k = 3),
              data = data.f)
summary(out.am)
bic = c(bic,BIC(out.am))# D4, D6, D2, D3, D5
bic

## Scatter plot
var.names = c(D1 = "Dimension 1", D2 = 'Dimension 2',D3 = "Dimension 3", D5 = 'Dimension 5')

plot.am <- visreg(out.am, type = "contrast", plot = FALSE)
smooths <- ldply(plot.am, function(part) data.frame(Variable = part$meta$x, x = part$fit[[part$meta$x]], 
                                                    smooth = part$fit$visregFit, lower = part$fit$visregLwr, upper = part$fit$visregUpr))

res.am <- ldply(plot.am, function(part) data.frame(Variable = part$meta$x, x = part$res[[part$meta$x]], 
                                                   y = part$res$visregRes))

ggplot(smooths, aes(x, smooth)) + 
  geom_line(aes(y = upper), linetype = "dashed") + 
  facet_wrap(~Variable, scales = "free_x",labeller = as_labeller(var.names)) + 
  geom_point(data = res.am, color='red', size=0.25, aes(x, y)) + 
  geom_line() + geom_line(aes(y = lower), linetype = "dashed") + 
  geom_rug(data = res.am, aes(x, y), sides = "b", color = "blue") + theme(text = element_text(size = 15)) + 
  xlab("") + ylab("Smooth")

## Map
index <-function(cum, i){
  if(i==1) return(1:cum[i])
  else return((cum[i-1]+1):cum[i])
}

sir_y1_state_gam = sapply(1:length(No.obs), function(i) 
  c(mean(out.am$residuals[index(cum,i)]), median(out.am$residuals[index(cum,i)]))) #k =6
data("fifty_states") # this line is optional due to lazy data loading

crimes <- data.frame(state = tolower(rownames(USArrests)), 
                     Mean = (sir_y1_state_gam[1,])[-9],
                     Median = (sir_y1_state_gam[2,])[-9])

# map_id creates the aesthetic mapping to the state name column in your data
p <- ggplot(crimes, aes(map_id = state)) + 
  # map points to the fifty_states shape data
  geom_map(aes(fill = Mean), map = fifty_states, color='black') + 
  expand_limits(x = fifty_states$long, y = fifty_states$lat) +
  coord_map() +  
  scale_fill_gradient(low='white', high='grey20', name=expression(Y[1])) +
  scale_x_continuous(breaks = NULL) + 
  scale_y_continuous(breaks = NULL) +
  labs(x = "", y = "") +
  theme(legend.position = "bottom", 
        panel.background = element_blank()) 

p
# add border boxes to AK/HI
p + fifty_states_inset_boxes() 

#####################################################
##############   SIR y2 ##############################
#####################################################
k = 6 
sir <- dr(DatY[,2]~newX, method='sir', nslice = 100,numdir = 10)
Coe.Matrx = sir$evectors[,1:k]  
lm.X = newX %*% Coe.Matrx
colnames(lm.X) = paste('D',1:k,sep = '')
lm.Y = DatY[,2]
data.f = data.frame(cbind(lm.X, lm.Y))

## BIC
bic = c()
out.am <- gam(lm.Y ~ s(D1, k = 3)  + s(D2, k = 3) + s(D3, k = 3)  + s(D4, k = 3) + s(D5, k = 3)  + s(D6, k = 3) , 
              data = data.f)
summary(out.am)
bic = c(bic,BIC(out.am))# D2, D6, D4, D3
bic

out.am <- gam(lm.Y ~ s(D1, k = 3)  + s(D2, k = 3) + s(D3, k = 3)  + s(D4, k = 3) + s(D5, k = 3), 
              data = data.f)
summary(out.am)
bic = c(bic,BIC(out.am))# D2, D6, D4, D3
bic

## Scatter plot
var = paste('Dimension ', 1:5, sep='')
var.names = c(D1 = var[1], D2 = var[2], D3 = var[3], D4 = var[4], D5 = var[5])

plot.am <- visreg(out.am, type = "contrast", plot = FALSE)
smooths <- ldply(plot.am, function(part) data.frame(Variable = part$meta$x, x = part$fit[[part$meta$x]], 
                                                    smooth = part$fit$visregFit, lower = part$fit$visregLwr, upper = part$fit$visregUpr))

res.am <- ldply(plot.am, function(part) data.frame(Variable = part$meta$x, x = part$res[[part$meta$x]], 
                                                   y = part$res$visregRes))

ggplot(smooths, aes(x, smooth)) + 
  geom_line(aes(y = upper), linetype = "dashed") + 
  facet_wrap(~Variable, scales = "free_x",labeller = as_labeller(var.names)) + 
  geom_point(data = res.am, color='red', size=0.25, aes(x, y)) + 
  geom_line() + geom_line(aes(y = lower), linetype = "dashed") + 
  geom_rug(data = res.am, aes(x, y), sides = "b", color = "blue") + theme(text = element_text(size = 15)) + 
  xlab("") + ylab("Smooth")


## Map
index <-function(cum, i){
  if(i==1) return(1:cum[i])
  else return((cum[i-1]+1):cum[i])
}

sir_y2_state_gam = sapply(1:length(No.obs), function(i) c(mean(out.am$residuals[index(cum,i)]), median(out.am$residuals[index(cum,i)]))) #k =6
data("fifty_states") # this line is optional due to lazy data loading

crimes <- data.frame(state = tolower(rownames(USArrests)), 
                     Mean = (sir_y2_state_gam[1,])[-9],
                     Median = (sir_y2_state_gam[2,])[-9])

# map_id creates the aesthetic mapping to the state name column in your data
p <- ggplot(crimes, aes(map_id = state)) + 
  # map points to the fifty_states shape data
  geom_map(aes(fill = Mean), map = fifty_states, color='black') + 
  expand_limits(x = fifty_states$long, y = fifty_states$lat) +
  coord_map() +
  scale_fill_gradient(low='white', high='grey20', name=expression(Y[2])) +
  scale_x_continuous(breaks = NULL) + 
  scale_y_continuous(breaks = NULL) +
  labs(x = "", y = "") +
  theme(legend.position = "bottom", 
        panel.background = element_blank())

p
# add border boxes to AK/HI
p + fifty_states_inset_boxes() 

#####################################################
##############   SIR y3 ##############################
#####################################################
k = 3 
sir <- dr(DatY[,3]~newX, method='sir', nslice = 100,numdir = 10)
Coe.Matrx = sir$evectors[,1:k]  
lm.X = newX %*% Coe.Matrx
colnames(lm.X) = paste('D',1:k,sep = '')
lm.Y = DatY[,3]
data.f = data.frame(cbind(lm.X, lm.Y))

## BIC
bic = c()
out.am <- gam(lm.Y ~ s(D1, k = 3) + s(D2, k= 3) + s(D3, k = 3), data = data.f)
summary(out.am)
bic = c(bic,BIC(out.am))# D4, D2, D3
bic


## Scatter plot
var = paste('Dimension ', c(1:3), sep='')
var.names = c(D1 = var[1], D2 = var[2], D3 = var[3])

plot.am <- visreg(out.am, type = "contrast", plot = FALSE)
smooths <- ldply(plot.am, function(part) data.frame(Variable = part$meta$x, x = part$fit[[part$meta$x]], 
                                                    smooth = part$fit$visregFit, lower = part$fit$visregLwr, upper = part$fit$visregUpr))

res.am <- ldply(plot.am, function(part) data.frame(Variable = part$meta$x, x = part$res[[part$meta$x]], 
                                                   y = part$res$visregRes))

ggplot(smooths, aes(x, smooth)) + 
  geom_line(aes(y = upper), linetype = "dashed") + 
  facet_wrap(~Variable, scales = "free_x",labeller = as_labeller(var.names)) + 
  geom_point(data = res.am, color='red', size=0.25, aes(x, y))+ 
  geom_line() + geom_line(aes(y = lower), linetype = "dashed") + 
  geom_rug(data = res.am, aes(x, y), sides = "b", color = "blue") + theme(text = element_text(size = 15)) + 
  xlab("") + ylab("Smooth")


## Map
index <-function(cum, i){
  if(i==1) return(1:cum[i])
  else return((cum[i-1]+1):cum[i])
}

sir_y3_state_gam = sapply(1:length(No.obs), function(i) c(mean(out.am$residuals[index(cum,i)]), median(out.am$residuals[index(cum,i)]))) #k =6
data("fifty_states") # this line is optional due to lazy data loading

crimes <- data.frame(state = tolower(rownames(USArrests)), 
                     Mean = (sir_y3_state_gam[1,])[-9],
                     Median = (sir_y3_state_gam[2,])[-9])

# map_id creates the aesthetic mapping to the state name column in your data
p <- ggplot(crimes, aes(map_id = state)) + 
  # map points to the fifty_states shape data
  geom_map(aes(fill = Mean), map = fifty_states, color='black') + 
  expand_limits(x = fifty_states$long, y = fifty_states$lat) +
  coord_map() +
  scale_fill_gradient(low='white', high='grey20', name=expression(Y[3])) +
  scale_x_continuous(breaks = NULL) + 
  scale_y_continuous(breaks = NULL) +
  labs(x = "", y = "") +
  theme(legend.position = "bottom", 
        panel.background = element_blank())

p
# add border boxes to AK/HI
p + fifty_states_inset_boxes()