# R code for "Using SITAR to relate pubertal growth to bone health in later life:
# the MRC National Survey of Health and Development"
# 29 April 2016

	library(sitar)

################################
# merged data
################################

  summary(nalx)
#           gp             id                 age        sex             ht            wt             bmi
# NSHD  :30004   Length:104124      Min.   : 2.00   1:52212   Min.   : 66   Min.   :  6.8   Min.   : 6.87
# ALSPAC:74120   Class :character   1st Qu.: 7.44   2:51912   1st Qu.:124   1st Qu.: 24.2   1st Qu.:15.89
#                Mode  :character   Median :10.69             Median :143   Median : 35.8   Median :17.68
#                                   Mean   :11.04             Mean   :141   Mean   : 39.2   Mean   :18.53
#                                   3rd Qu.:13.75             3rd Qu.:160   3rd Qu.: 52.0   3rd Qu.:20.47
#                                   Max.   :27.42             Max.   :208   Max.   :164.0   Max.   :62.31

################################
# sitar models for NSHD
################################

	m3l <- sitar(log(age), ht, id, nalx[nalx$sex == 1 & nalx$gp == 'NSHD',], 5)
	f3l <- sitar(log(age), ht, id, nalx[nalx$sex == 2 & nalx$gp == 'NSHD',], 5)
	wm3l <- sitar(log(age), wt, id, nalx[nalx$sex == 1 & nalx$gp == 'NSHD',], 5)
	wf3l <- sitar(log(age), wt, id, nalx[nalx$sex == 2 & nalx$gp == 'NSHD',], 5)

#############################################################
# sitar models for NSHD joint with ALSPAC
#############################################################

	gp <- nalx$gp[nalx$sex == 1]
	namx7f <- sitar(log(age), ht, id, nalx[nalx$sex == 1,], 6, weights = varIdent(form=~1|gp))
	nawmx7f <- sitar(log(age), wt, id, nalx[nalx$sex == 1,], 5, weights = varIdent(form=~1|gp))
	gp <- nalx$gp[nalx$sex == 2]
	nafx7f <- sitar(log(age), ht, id, nalx[nalx$sex == 2,], 6, weights = varIdent(form=~1|gp))
	nawfx7f <- sitar(log(age), wt, id, nalx[nalx$sex == 2,], 5, weights = varIdent(form=~1|gp))

#############################################################
# list of models
#############################################################

	models <- c('m3l','namx7f','f3l','nafx7f','wm3l','nawmx7f','wf3l','nawfx7f')

#######################################################################################
# cross-sectional sex, puberty, ht/wt/bmi at 26, sitar parameters, bone outcomes
#######################################################################################

# als = 0, NSHD modelled alone; als = 1, NSHD modelled with ALSPAC

	for (als in 0:1) {

# combine sitar parameters for height and weight by sex
	abcrisk <- rbind(cbind(
		ranef(get(models[1+als])),
		ranef(get(models[5+als])), sex=1),
		cbind(
		ranef(get(models[3+als])),
		ranef(get(models[7+als])), sex=2))
	dimnames(abcrisk)[[2]] <- c('ah','bh','ch','aw','bw','cw','sex')
	
# lose ALSPAC
	if (als == 1) abcrisk <- abcrisk[substr(rownames(abcrisk),1,1) == 'N',]

#	merge variables
	abcrisk <- merge(pgpab[, c(1, 3, 4, 6:12)], abcrisk[, 1:6], by.x='id', by.y=0, all.x=TRUE)
	abcrisk <- cbind(abcrisk, bones[, c(4:5, 10:11)])

#	NSHD age 0-26 vs NSHD age 0-26 with ALSPAC
	if (als == 0) {
		abcrisk1 <- abcrisk
	}
	else {
		abcrisk2 <- abcrisk
	}
	}

#############################################################
# plot figures
#############################################################

	pdf('Figure 1-2.pdf', w=7, h=7)
	par(mfrow=c(2,2), mar=c(5,4,1,1) + 0.1)

	xlab <- 'age (years)'
	ylab <- c('height (cm)', 'weight (kg)')
	yhwa <- y ~ age

#  Figure 1 - plots of sole and joint fitted NSHD curves

	counter <- 0
  for (hw in 1:2)	{
	for (ix in 1:2) {
	  counter <- counter + 1
	  obj1 <- get(models[counter * 2 - 1])
	  plot(obj1, 'd', lty=2, las=1, xlab=xlab, ylab=ylab[hw], mar=par()$mar)
	  obj2 <- get(models[counter * 2])
	  lines(obj2, 'd', subset=gp=='NSHD')
	  legend('bottomright', legend=c('joint', 'sole'), lty=1:2)
	  legend('topleft', paste0(letters[counter], ')'), bty='n')
	}
  }

#	Figure 2 - plots of raw data for NSHD and ALSPAC with fitted curves

	counter <- 0
	for (hw in 1:2)	{
	  for (ix in 1:2) {
	    counter <- counter + 1
	    obj <- get(models[counter * 2])
	    yhwa[[2]] <- c(quote(ht), quote(wt))[[hw]]
	    plot(yhwa, data=nalx[nalx$sex==ix,], type='n', las=1, xlab=xlab, ylab=ylab[hw])
	    points(yhwa, data=nalx[nalx$sex == ix & nalx$gp == 'ALSPAC',], pch=46, col='gray')
	    lines(obj, 'd', subset=gp=='ALSPAC')
	    points(yhwa, data=nalx[nalx$sex == ix & nalx$gp == 'NSHD',], pch=20, col='black', cex=0.5)
	    lines(obj, 'd', subset=gp=='NSHD')
	    legend('topleft', paste0(letters[counter], ')'), bty='n')
	  }
	}

	dev.off()

#############################################################
# print results
#############################################################

  sink('NSHD regressions.txt')

  op <- options(width=75, digits=4, show.signif.stars=FALSE)

  cat('\n****************', 'Both sexes', 'NSHD + ALSPAC', 'Regressions ****************\n')
  sitarvars <- c('ah','bh','ch','aw','bw','cw')
  yvars <- c('trabBMD', 'diaCSA')
  xvars <- c('sex', 'ht64', 'wt64')
  vars <- c(yvars, sitarvars, xvars)

# print and fit lm formula
  pslm <- function(formula) {
	obj <- eval(parse(text=paste0('lm(formula = ',
		as.expression(formula), ')')), parent.frame())
	print(summary(obj))
	print(summary(obj)$coef[-1, 3])
	print(attrisk(obj))
  }

# derive growth attributable risk
  attrisk <- function(obj, vars=c('ah','bh','ch','aw','bw','cw'), p=0.9545) {
	cf <- coef(obj)
	cf <- cf[names(cf) %in% vars]
	lp <- as.matrix(obj$model[, names(cf)]) %*% cf
	plo <- (1 - p) / 2
	ar <- diff(quantile(lp, c(plo, 1 - plo), na.rm=TRUE))
	names(ar) <- paste0(p * 100, '%')
	sds <- sd(lp) * 2 * -qnorm(plo)
	names(sds) <- 'SDs'
	c(ar, sds)
  }

# fit cross-sectional models
  with(na.omit(abcrisk2[, vars]), {
	pslm(log(trabBMD) ~ sex+ah+bw++ch+aw+bw+cw)
	pslm(log(trabBMD) ~ sex+ah+bw+ch+aw+bw+cw + log(ht64) + log(wt64))
	pslm(log(trabBMD) ~ sex+ah+bw+ch)
	pslm(log(trabBMD) ~ sex+ah+bw)
	pslm(log(trabBMD) ~ sex+bh)
	pslm(log(trabBMD) ~ sex+bh + log(ht64) + log(wt64))
	pslm(log(diaCSA) ~ sex+ah+bh+ch+aw+bw+cw)
	pslm(log(diaCSA) ~ sex+ah+bh+ch+aw+bw+cw + log(ht64) + log(wt64))
	pslm(log(diaCSA) ~ sex+aw+bw+cw)
	pslm(log(diaCSA) ~ sex+aw+bw+cw + log(ht64) + log(wt64))
	pslm(log(diaCSA) ~ sex+ah+aw)
	pslm(log(diaCSA) ~ sex+aw)
	pslm(log(diaCSA) ~ sex)
	pslm(log(diaCSA) ~ sex + log(ht64) + log(wt64))
  })

  options(op)

  sink()