OTU_dists<- function(
                     file_in,
                     input_dir = "./",
                     output_PCoA_dir = "./",
                     print_dist = 1,
                     output_DIST_dir = "./",
                     dist_method = "OTU",
                     headers = 1,
                     debug = FALSE
                     )

{

# load packages
#  suppressPackageStartupMessages(library(matlab))
  suppressPackageStartupMessages(library(ecodist))

##### SUBS
  func_usage <- function() {
    writeLines("
     You supplied no arguments

     DESCRIPTION: (OTU_similarities.r):
     This script will perform a PCoA analysis on the inputdata
     using the selected distance metric.
     Only two methods are possible in this version - OTU and w_OTU
     OTU = Zhou et al, w_OTU = abundance weighted OTU
     for other methods see MGRAST_plot_pco.r (and plot_pco_with_stats.pl)
     and plot_qiime_pco_with_stats.pl

     Output always produces a
     *.PCoA file that has the normalized eigenvalues (top n lines)
     and eigenvectors (bottom n x m matris, n lines) where n is the
     number of variables (e.g.subsystems), and m the number of
     samples. You can also choose to produce *.DIST files that contain
     the distance matrix used to generate the PCoA.

     USAGE: MGRAST_plot_pca(
                            file_in = no default arg                               # (string)  input data file
                            input_dir = \"./\"                                       # (string)  directory(path) of input
                            output_PCoA_dir = \"./\"                                 # (string)  directory(path) for output PCoA file
                            print_dist = TRUE                                        # (boolean) print the DIST file (distance matrix)
                            output_DIST_dir = \"./\"                                 # (string)  directory(path) for output DIST file
                            dist_method = \"OTU\"                            # (string)  distance/dissimilarity metric,
                                          (choose from one of the following options)
                                          \"OTU\" | \"w_OTU\"
                            headers = 0                                            # (booealan) print headers in output PCoA file
                            )\n"
               )
    stop("OTU_similarities stopped\n\n")
  }

  # Function that calculates the dist matrix
  produce_dist <- function(M, dist_method, dist){

   n<-nrow(M)
   for (i in 1:(n-1)) {
     for (j in (i+1):n) {
       k <- n*(i-1) - i*(i-1)/2 + j-i
       Both <- M[i,] & M[j,]
       Either <- M[i,] | M [j,]
       if ( dist_method == "w_OTU" ){ dist [k] = 100 * sum ( Both*M[i,] , Both*M[j,] ) / sum ( M[i,] , M[j,] ) }
       else { dist [k] = 100 * sum (Both) / sum(Either) }
     }
   }
   return(dist)
 }

 # Function to write output
  write_file <- function(data, file_name) {
    write.table(data, file=file_name, col.names=NA, row.names=TRUE, append = FALSE, sep="\t", quote = FALSE)
  }

  ##### END SUBS

  # stop and give the usage if the proper number of arguments is not given
  if ( nargs() == 0 ){
    func_usage()
  }

  # load data
  my_input_path_file <- gsub(" ", "", paste(input_dir,file_in))
  #Input <<- read.table(my_input_path_file, header = 1, sep = "\t", row.names = 1, quote = "", stringsAsFactors = FALSE, check.names=FALSE)
  Input <<- read.table(my_input_path_file, row.names=1, check.names=FALSE, header=TRUE, sep="\t", comment.char="", quote="", stringsAsFactors = FALSE )
  #           read.table(input_data_path,   row.names=1, check.names=FALSE, header=TRUE, sep="\t", comment.char="", quote="")
  #my_data <<- flipud(rot90(data.matrix(read.table(input_data_path, row.names=1, check.names=FALSE, header=TRUE, sep="\t", comment.char="", quote=""))))

  num_data_rows = dim(Input)[1] # substitute 0 for NA's if they exist in the data
  num_data_cols = dim(Input)[2]
  for (row_num in (1:num_data_rows)){
    for (col_num in (1:num_data_cols)){
      if (is.na(Input[row_num, col_num])){
        Input[row_num, col_num] <<- 0
      }
    }
  }

  row.names (Input) <- NULL
  M <- t (Input)

  # calculate distance matrix and produce *.DIST output files
  dist <- stats::dist (M)
  dist <- produce_dist(M, dist_method, dist)

  # generate string used to name the output *.DIST file
  DIST_file_out <- ""
  if ( dist_method== "w_OTU" ) { DIST_file_out <- gsub(" ", "", paste(output_DIST_dir, file_in, ".", dist_method, ".DIST")) }
  else { DIST_file_out <- gsub(" ", "", paste(output_DIST_dir, file_in, ".", dist_method, ".DIST")) }
  if ( print_dist == 1 ) { write_file(file_name = DIST_file_out, data = data.matrix(dist)) }

  # perform pco and write output(s)
  my_pco <- pco(dist)

  # scale eigen values from 0 to 1, and label them
  eigen_values <<- my_pco$values
  scaled_eigen_values <<- (eigen_values/sum(eigen_values))
  for (i in (1:dim(as.matrix(scaled_eigen_values))[1])) {names(scaled_eigen_values)[i]<<-gsub(" ", "", paste("PCO", i))}
  scaled_eigen_values <<- data.matrix(scaled_eigen_values)

  # label the eigen vectors
  eigen_vectors <<- data.matrix(my_pco$vectors)
  dimnames(eigen_vectors)[[1]] <<- dimnames(Input)[[2]] #dimnames(Input)[[1]]

  # write eigen values and then eigen vectors to file_out
  PCoA_file_out = gsub(" ", "", paste(output_PCoA_dir, file_in, ".", dist_method, ".PCoA"))

  if ( headers == 1 ){
    write(file = PCoA_file_out, paste("# file_in    :", file_in,
            "\n# dist_method:", dist_method,
            "\n#________________________________",
            "\n# EIGEN VALUES (scaled 0 to 1) >",
            "\n#________________________________"),
          append=FALSE)
    write.table(scaled_eigen_values, file=PCoA_file_out, col.names=FALSE, row.names=TRUE, append = TRUE, sep="\t")
  }else{
    write.table(scaled_eigen_values, file=PCoA_file_out, col.names=FALSE, row.names=TRUE, append = FALSE, sep="\t")
  }

  if ( headers == 1 ){
    write(file = PCoA_file_out, paste("#________________________________",
            "\n# EIGEN VECTORS >",
            "\n#________________________________"),
          append=TRUE)
  }

  write.table(eigen_vectors, file=PCoA_file_out, col.names=FALSE, row.names=TRUE, append = TRUE, sep="\t")

}


#last edited at 20200313
#this is a stable version

#a function similar to pegas::geoTrans() but more robust
#a function to transform (or convert) geographic cooridinate string to number

require(magrittr)
require(stringr)
require(tibble)

geoTrans2=function(x){
  #>>>control the input of x begin>>>
  if(!is.character(x) | length(x) == 0){stop("x must be a non-empty character vector")}
  if(anyNA(x)){stop("x can't contain NA")}
  x %<>% enc2utf8() %>% toupper() %>% str_squish()
  #<<<control the input of x end<<<
  #>>>main manipulation begin>>>
  x %<>% str_remove_all(pattern="[\n\r\t]")
  x %<>% gsub(pattern="([NSEW])", replacement="\\1 ", x=.)
  x %<>% chartr(old="°′″", new="DMS", x=.) %>% chartr(old="\'\"", new="MS", x=.)
  x %<>% str_squish()
  #
  tulip = c("^(N |S |E |W |)([[:digit:]]+)D([[:digit:]]+)M([[:digit:]]{3})S$",
            "^(N |S |E |W |)([[:digit:]]+)D([[:digit:]]+)M([[:digit:]]{3})M$",
            "^(N |S |E |W |)([[:digit:]]+)D([[:digit:]]+)M([[:digit:].]+)M$",
            "^(N |S |E |W |)([[:digit:]]+)D([[:digit:].]+)M$",
            "^(N |S |E |W |)([[:digit:].]+)D$")
  x %<>% sub(pattern=tulip[1], replacement="\\1\\2D\\3.\\4M0S", x=.)
  x %<>% sub(pattern=tulip[2], replacement="\\1\\2D\\3.\\4M0S", x=.)
  x %<>% sub(pattern=tulip[3], replacement="\\1\\2D\\3M\\4S", x=.)
  x %<>% sub(pattern=tulip[4], replacement="\\1\\2D\\3M0S", x=.)
  x %<>% sub(pattern=tulip[5], replacement="\\1\\2D0M0S", x=.)
  remove(tulip)
  #
  tulip = "^(N |S |E |W |)([[:digit:].]+)D([[:digit:].]+)M([[:digit:].]+)S$"
  tulip = strcapture(proto=data.frame(direction="", degree=0, minute=0, second=0, stringsAsFactors=FALSE),
                     pattern=tulip, x=x)#stringr::str_match() won't work for non-ACSII character
  tulip$direction %<>% str_trim(side="right")
  for(i in 1:nrow(tulip)) if(!is.na(tulip[[1]][i])){
    ans = tulip[i,]
    ans %<>% {(.$degree<(-180))|(.$degree>180)|(.$minute<0)|(.$minute>60)|(.$second<0)|(.$second>60);}
    if(ans){tulip[i,]=NA;}
    remove(ans)
  }
  x = tibble(direction=tulip$direction, degree=tulip$degree + tulip$minute / 60 + tulip$second / 3600)
  remove(tulip, i)
  #<<<main manipulation end<<<
  return(x)
}

if(FALSE){
  #here are the test codes
  x=c("N 43°27'30\"",
      "N43°27'30\"",
      "43°27'30\"",
      "43°27.5'",
      "n 43d27'30\"")
  geoTrans2(x)
}


Output:
The Total profit is:  54500
You must carry: Gold (x 11 )
You must carry: Panacea (x 9 )


#!/usr/bin/env Rscript

# Helper functions to annotate adducts
adductCalculator<-function(mz=NA,charge=NA,mode="pos",adduct=NA, primary = T)
{
  if(is.na(mz))stop("Provide the mz!")
  if(is.na(mode))stop("Provide the polarity!")

  Ion.name.pos=c("M+3H",
             "M+2H+Na",
             "M+H+2Na",
             "M+3Na",
             "M+2H",
             "M+H+NH4",
             "M+H+Na",
             "M+H+K",
             "M+ACN+2H",
             "M+2Na",
             "M+2ACN+2H",
             "M+3ACN+2H",
             "M+H",
             "M+NH4",
             "M+Na",
             "M+CH3OH+H",
             "M+K",
             "M+ACN+H",
             "M+2Na-H",
             "M+IsoProp+H",
             "M+ACN+Na",
             "M+2K-H",
             "M+DMSO+H",
             "M+2ACN+H",
             "M+IsoProp+Na+H",
             "2M+H",
             "2M+NH4",
             "2M+Na",
             "2M+K",
             "2M+ACN+H",
             "2M+ACN+Na")

  Ion.mass.pos=c(
    "M/3 + 1.007276",
    "M/3 + 8.334590",
    "M/3 + 15.7661904",
    "M/3 + 22.989218",
    "M/2 + 1.007276",
    "M/2 + 9.520550",
    "M/2 + 11.998247",
    "M/2 + 19.985217",
    "M/2 + 21.520550",
    "M/2 + 22.989218",
    "M/2 + 42.033823",
    "M/2 + 62.547097",
    "M + 1.007276",
    "M + 18.033823",
    "M + 22.989218",
    "M + 33.033489",
    "M + 38.963158",
    "M + 42.033823",
    "M + 44.971160",
    "M + 61.06534",
    "M + 64.015765",
    "M + 76.919040",
    "M + 79.02122",
    "M + 83.060370",
    "M + 84.05511",
    "2M + 1.007276",
    "2M + 18.033823",
    "2M + 22.989218",
    "2M + 38.963158",
    "2M + 42.033823",
    "2M + 64.015765")

  Charge.pos=c(
    "3+",
    "3+",
    "3+",
    "3+",
    "2+",
    "2+",
    "2+",
    "2+",
    "2+",
    "2+",
    "2+",
    "2+",
    "1+",
    "1+",
    "1+",
    "1+",
    "1+",
    "1+",
    "1+",
    "1+",
    "1+",
    "1+",
    "1+",
    "1+",
    "1+",
    "1+",
    "1+",
    "1+",
    "1+",
    "1+",
    "1+")

  Extended.pos<-c(T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,T,F,T,T,T,T,T,T,T,T,T,T,T,T,T,T)

  Ion.name.neg<-c("M-3H",
                 "M-2H",
                 "M-H2O-H",
                 "M-H",
                 "M+Na-2H",
                 "M+Cl",
                 "M+K-2H",
                 "M+FA-H",
                 "M+Hac-H",
                 "M+Br",
                 "M+TFA-H",
                 "2M-H",
                 "2M+FA-H",
                 "2M+Hac-H",
                 "3M-H")

  Ion.mass.neg<-c("M/3 - 1.007276",
    "M/2 - 1.007276",
    "M - 19.01839",
    "M - 1.007276",
    "M + 20.974666",
    "M + 34.969402",
    "M + 36.948606",
    "M + 44.998201",
    "M + 59.013851",
    "M + 78.918885",
    "M + 112.985586",
    "2M - 1.007276",
    "2M + 44.998201",
    "2M + 59.013851",
    "3M - 1.007276")

  Charge.neg<-c("3-",
    "2-",
    "1-",
    "1-",
    "1-",
    "1-",
    "1-",
    "1-",
    "1-",
    "1-",
    "1-",
    "1-",
    "1-",
    "1-",
    "1-")

  Extended.neg<-c(T,T,T,F,F,F,F,T,T,T,T,T,T,T,T)

  adductsFile.pos<-data.frame(
	Ion.name=Ion.name.pos[!(Extended.pos & primary)],
	Ion.mass=Ion.mass.pos[!(Extended.pos & primary)],
	Charge=Charge.pos[!(Extended.pos & primary)])
  adductsFile.neg<-data.frame(
	Ion.name=Ion.name.neg[!(Extended.neg & primary)],
	Ion.mass=Ion.mass.neg[!(Extended.neg & primary)],
	Charge=Charge.neg[!(Extended.neg & primary)])

  if(tolower(mode)%in%c("pos","positive","p"))
  {
    # select the adducts (primary or extended)
    tmpAdduct<-adductsFile.pos
    if(!is.na(charge) & is.numeric(charge))
    {
      chargeSign<-NA
      chargeSign<-"+"
      tmpAdduct<-tmpAdduct[tmpAdduct[,"Charge"]==paste(charge,chargeSign,sep=""),]
    }
    if(!is.na(adduct))
    {

      tmpAdduct<-tmpAdduct[tmpAdduct[,"Ion.name"]%in%adduct,]
    }

    if(nrow(tmpAdduct)==0){
      warning("Not found! Reporting all possible adducts")
      tmpAdduct<-adductsFile.pos
    }
    signs<-sapply(str_extract(as.character(tmpAdduct[,"Ion.mass"]),"\\+|\\-"),function(x){x[[1]]})
    signs[signs=="+"]=-1
    signs[signs=="-"]=+1
    mzCoefficients<-
      str_extract(sapply(strsplit(as.character(tmpAdduct[,"Ion.mass"]),split = "\\+|\\-"),function(x){x[1]}),
                  "\\d+")

    mzCoefficients[is.na(mzCoefficients)]<-1
    mzCoefficients<-as.numeric(mzCoefficients)
    mzCoefficients[!grepl("/",as.character(tmpAdduct[,"Ion.mass"]),fixed=T)]<-
      1/ mzCoefficients[!grepl("/",as.character(tmpAdduct[,"Ion.mass"]),fixed=T)]

    result<- mz+  (as.numeric(signs)*
            as.numeric(sapply(strsplit(as.character(tmpAdduct[,"Ion.mass"]),"\\+|\\-"),function(x){x[[2]]})))

    result<- result*mzCoefficients
  }else if(tolower(mode)%in%c("neg","negative","n"))
  {
    tmpAdduct<-adductsFile.neg
    if(!is.na(charge) & is.numeric(charge))
    {
      chargeSign<-NA
     chargeSign<-"-"
      tmpAdduct<-tmpAdduct[tmpAdduct[,"Charge"]==paste(charge,chargeSign,sep=""),]
    }
    if(!is.na(adduct))
    {

      tmpAdduct<-tmpAdduct[tmpAdduct[,"Ion.name"]%in%adduct,]
    }

    if(nrow(tmpAdduct)==0){
      warning("Not found! Reporting all possible adducts")
      tmpAdduct<-adductsFile.neg
    }
    signs<-sapply(str_extract(as.character(tmpAdduct[,"Ion.mass"]),"\\+|\\-"),function(x){x[[1]]})
    signs[signs=="+"]=-1
    signs[signs=="-"]=+1
    mzCoefficients<-
      str_extract(sapply(strsplit(as.character(tmpAdduct[,"Ion.mass"]),split = "\\+|\\-"),function(x){x[1]}),
                  "\\d+")

    mzCoefficients[is.na(mzCoefficients)]<-1
    mzCoefficients<-as.numeric(mzCoefficients)
    mzCoefficients[!grepl("/",as.character(tmpAdduct[,"Ion.mass"]),fixed=T)]<-
      1/ mzCoefficients[!grepl("/",as.character(tmpAdduct[,"Ion.mass"]),fixed=T)]

    result<- mz+  (as.numeric(signs)*
                     as.numeric(sapply(strsplit(as.character(tmpAdduct[,"Ion.mass"]),"\\+|\\-"),function(x){x[[2]]})))
    result<- result*mzCoefficients

  }else
  {
    stop("Incorrect mode! Mode has to be either positive or negative!")
  }

return(data.frame(correctedMS=result,adductName=tmpAdduct[,"Ion.name"]))

}


##################################################################################################################
#########  WHO Child Growth Standards                                                                        #####
#########  Department of Nutrition for Health and Development                                                #####
#########  World Health Organization                                                                         #####
#########  Last modified on 07/10/2013     -     Developed using R version 3.0.1 (2013-05-16)                #####
#########  This code corcerns the standard approach for the prevalences, i.e. the calculation of the         #####
#########  prevalences takes into account all the valid (non-missing) z-scores for each of the indicators.   #####
##################################################################################################################

##################################################################################################################
#########  Function for calculating the z-scores and prevalences for a nutritional survey                    #####
##################################################################################################################

########################################################################
#### Auxiliar functions
########################################################################

#############################################################################
##### Prevalence calculation for the upper bound and corresponding 95% C.I.
#############################################################################

#### Without oedema (for head circumference-for-age and arm circumferecen-for-age)

prevph.L <- function(a,x,w) {
   ph <- sum((x > a)*w,na.rm=T)/sum((!is.na(x))*w,na.rm=T)
   aux <- 1.96*sqrt(ph*(1-ph)/sum((!is.na(x))*w,na.rm=T))+(1/(2*sum((!is.na(x))*w,na.rm=T)))
   vec <- c(rounde(sum((!is.na(x))*w,na.rm=T),digits=0),rounde(c(ph, max(0,ph-aux), ph+aux)*100,digits=1))
   return(vec)
   }

#### With oedema (only for weight-for-length/height and bmi-for-age)

prevph <- function(a,x,w,f) {
   f<-as.character(f)
   ph <- sum((x > a)*w,na.rm=T)/sum(((!is.na(x)) | (f=="y"))*w,na.rm=T)
   aux <- 1.96*sqrt(ph*(1-ph)/sum(((!is.na(x)) | (f=="y"))*w,na.rm=T))+(1/(2*sum(((!is.na(x)) | (f=="y"))*w,na.rm=T)))
   vec <- c(rounde(sum(((!is.na(x)) | (f=="y"))*w,na.rm=T),digits=0),rounde(c(ph, max(0,ph-aux), ph+aux)*100,digits=1))
   return(vec)
   }

#############################################################################
##### Prevalence calculation for the lower bound and corresponding 95% C.I.
#############################################################################

#### Without oedema (for length/height-for-age)

prevnh.L <- function(a,x,w) {
   ph <- sum((x < a)*w,na.rm=T)/sum((!is.na(x))*w,na.rm=T)
   aux <- 1.96*sqrt(ph*(1-ph)/sum((!is.na(x))*w,na.rm=T))+(1/(2*sum((!is.na(x))*w,na.rm=T)))
   vec <- c(rounde(sum((!is.na(x))*w,na.rm=T),digits=0),rounde(c(ph, max(0,ph-aux), ph+aux)*100,digits=1))
   return(vec)
   }

#### With oedema  (for all weight-related indicators)

prevnh <- function(a,x,w,f) {
   f<-as.character(f)
   ph <- sum((x < a | f=="y")*w,na.rm=T)/sum(((!is.na(x)) | (f=="y"))*w,na.rm=T)
   aux <- 1.96*sqrt(ph*(1-ph)/sum(((!is.na(x)) | (f=="y"))*w,na.rm=T))+(1/(2*sum(((!is.na(x)) | (f=="y"))*w,na.rm=T)))
   vec <- c(rounde(sum(((!is.na(x)) | (f=="y"))*w,na.rm=T),digits=0),rounde(c(ph, max(0,ph-aux), ph+aux)*100,digits=1))
   return(vec)
   }

###########################################
#### Weighted mean  and standard deviation
###########################################

wmean <- function(x,w) { return(rounde(sum(x*w,na.rm=T)/sum(w[!is.na(x)]),digits=2) )  }

wsd <- function(x,w) {
   mh <- sum(x*w,na.rm=T)/sum((!is.na(x))*w,na.rm=T)
   sdh<-ifelse(length(x[!is.na(x)])>0,rounde(sqrt(sum(((x-mh)^2)*w,na.rm=T)/(sum((!is.na(x))*w,na.rm=T) - 1)),digits=2),NA)
   return( sdh )
   }

######################################################################################
#### Rounding function - SPlus rounding function uses the nearest even number rule
######################################################################################

rounde <- function(x,digits=0) {
	expo<-10^digits
	return(ifelse(abs(x*expo) - floor(abs(x*expo)) < 0.5, sign(x*expo) * floor(abs(x*expo)), sign(x*expo) * (floor(abs(x*expo)) + 1))/expo)
}

######################################################################################
### Function for calculating individual Length-for-age z-scores
######################################################################################

calc.zlen<-function(mat,lenanthro){

for(i in 1:length(mat$age.days)) {

	if(!is.na(mat$age.days[i]) & mat$age.days[i]>=0 & mat$age.days[i]<=1856) {

		l.val<-lenanthro$l[lenanthro$age==mat$age.days[i] & lenanthro$sex==mat$sex[i]]
		m.val<-lenanthro$m[lenanthro$age==mat$age.days[i] & lenanthro$sex==mat$sex[i]]
		s.val<-lenanthro$s[lenanthro$age==mat$age.days[i] & lenanthro$sex==mat$sex[i]]
		mat$zlen[i]<-(((mat$clenhei[i]/m.val)^l.val)-1)/(s.val*l.val)

	}	else mat$zlen[i]<- NA

}
return(mat)
}

######################################################################################
### Function for calculating individual Head circumference-for-age z-scores
######################################################################################

calc.zhc<-function(mat,hcanthro){

for(i in 1:length(mat$age.days)) {

	if(!is.na(mat$age.days[i]) & mat$age.days[i]>=0 & mat$age.days[i]<=1856) {

		l.val<-hcanthro$l[hcanthro$age==mat$age.days[i] & hcanthro$sex==mat$sex[i]]
		m.val<-hcanthro$m[hcanthro$age==mat$age.days[i] & hcanthro$sex==mat$sex[i]]
		s.val<-hcanthro$s[hcanthro$age==mat$age.days[i] & hcanthro$sex==mat$sex[i]]
		mat$zhc[i]<-(((mat$headc[i]/m.val)^l.val)-1)/(s.val*l.val)

	}	else mat$zhc[i]<- NA

}
return(mat)
}

######################################################################################
### Function for calculating individual Weight-for-age z-scores
######################################################################################

calc.zwei<-function(mat,weianthro){

for(i in 1:length(mat$age.days)) {

	if(!is.na(mat$age.days[i]) & mat$age.days[i]>=0 & mat$age.days[i]<=1856 & mat$oedema[i]!="y") {

		l.val<-weianthro$l[weianthro$age==mat$age.days[i] & weianthro$sex==mat$sex[i]]
		m.val<-weianthro$m[weianthro$age==mat$age.days[i] & weianthro$sex==mat$sex[i]]
		s.val<-weianthro$s[weianthro$age==mat$age.days[i] & weianthro$sex==mat$sex[i]]

		mat$zwei[i]<-(((mat$weight[i]/m.val)^l.val)-1)/(s.val*l.val)
		if(!is.na(mat$zwei[i]) & mat$zwei[i]>3) {
						sd3pos<- m.val*((1+l.val*s.val*3)^(1/l.val))
						sd23pos<- sd3pos- m.val*((1+l.val*s.val*2)^(1/l.val))
						mat$zwei[i]<- 3+((mat$weight[i]-sd3pos)/sd23pos)
						}
		if(!is.na(mat$zwei[i]) & mat$zwei[i]< (-3)) {
						sd3neg<- m.val*((1+l.val*s.val*(-3))**(1/l.val))
						sd23neg<- m.val*((1+l.val*s.val*(-2))**(1/l.val))-sd3neg
						mat$zwei[i]<- (-3)+((mat$weight[i]-sd3neg)/sd23neg)
						}

		} else mat$zwei[i]<-NA
}
return(mat)
}

######################################################################################
### Function for calculating individual Arm circumference-for-age z-scores
######################################################################################

calc.zac<-function(mat,acanthro){

for(i in 1:length(mat$age.days)) {

	if(!is.na(mat$age.days[i]) & mat$age.days[i]>=91 & mat$age.days[i]<=1856) {

		l.val<-acanthro$l[acanthro$age==mat$age.days[i] & acanthro$sex==mat$sex[i]]
		m.val<-acanthro$m[acanthro$age==mat$age.days[i] & acanthro$sex==mat$sex[i]]
		s.val<-acanthro$s[acanthro$age==mat$age.days[i] & acanthro$sex==mat$sex[i]]
		mat$zac[i]<-(((mat$armc[i]/m.val)^l.val)-1)/(s.val*l.val)
		if(!is.na(mat$zac[i]) & mat$zac[i]>3) {
						sd3pos<- m.val*((1+l.val*s.val*3)^(1/l.val))
						sd23pos<- sd3pos- m.val*((1+l.val*s.val*2)^(1/l.val))
						mat$zac[i]<- 3+((mat$armc[i]-sd3pos)/sd23pos)
						}
		if(!is.na(mat$zac[i]) & mat$zac[i]< (-3)) {
						sd3neg<- m.val*((1+l.val*s.val*(-3))**(1/l.val))
						sd23neg<- m.val*((1+l.val*s.val*(-2))**(1/l.val))-sd3neg
						mat$zac[i]<- (-3)+((mat$armc[i]-sd3neg)/sd23neg)
						}

		} else mat$zac[i]<-NA

}
return(mat)
}

######################################################################################
### Function for calculating individual Triceps skinfold-for-age z-scores
######################################################################################

calc.zts<-function(mat,tsanthro){

for(i in 1:length(mat$age.days)) {

	if(!is.na(mat$age.days[i]) & mat$age.days[i]>=91 & mat$age.days[i]<=1856) {

		l.val<-tsanthro$l[tsanthro$age==mat$age.days[i] & tsanthro$sex==mat$sex[i]]
		m.val<-tsanthro$m[tsanthro$age==mat$age.days[i] & tsanthro$sex==mat$sex[i]]
		s.val<-tsanthro$s[tsanthro$age==mat$age.days[i] & tsanthro$sex==mat$sex[i]]

		mat$zts[i]<-(((mat$triskin[i]/m.val)^l.val)-1)/(s.val*l.val)
		if(!is.na(mat$zts[i]) & mat$zts[i]>3) {
						sd3pos<- m.val*((1+l.val*s.val*3)^(1/l.val))
						sd23pos<- sd3pos- m.val*((1+l.val*s.val*2)^(1/l.val))
						mat$zts[i]<- 3+((mat$triskin[i]-sd3pos)/sd23pos)
						}
		if(!is.na(mat$zts[i]) & mat$zts[i]< (-3)) {
						sd3neg<- m.val*((1+l.val*s.val*(-3))**(1/l.val))
						sd23neg<- m.val*((1+l.val*s.val*(-2))**(1/l.val))-sd3neg
						mat$zts[i]<- (-3)+((mat$triskin[i]-sd3neg)/sd23neg)
						}

		} else mat$zts[i]<-NA

}

return(mat)
}

######################################################################################
### Function for calculating individual Subscapular skinfold-for-age z-scores
######################################################################################

calc.zss<-function(mat,ssanthro){

for(i in 1:length(mat$age.days)) {

	if(!is.na(mat$age.days[i]) & mat$age.days[i]>=91 & mat$age.days[i]<=1856) {

		l.val<-ssanthro$l[ssanthro$age==mat$age.days[i] & ssanthro$sex==mat$sex[i]]
		m.val<-ssanthro$m[ssanthro$age==mat$age.days[i] & ssanthro$sex==mat$sex[i]]
		s.val<-ssanthro$s[ssanthro$age==mat$age.days[i] & ssanthro$sex==mat$sex[i]]

		mat$zss[i]<-(((mat$subskin[i]/m.val)^l.val)-1)/(s.val*l.val)
		if(!is.na(mat$zss[i]) & mat$zss[i]>3) {
						sd3pos<- m.val*((1+l.val*s.val*3)^(1/l.val))
						sd23pos<- sd3pos- m.val*((1+l.val*s.val*2)^(1/l.val))
						mat$zss[i]<- 3+((mat$subskin[i]-sd3pos)/sd23pos)
						}
		if(!is.na(mat$zss[i]) & mat$zss[i]< (-3)) {
						sd3neg<- m.val*((1+l.val*s.val*(-3))**(1/l.val))
						sd23neg<- m.val*((1+l.val*s.val*(-2))**(1/l.val))-sd3neg
						mat$zss[i]<- (-3)+((mat$subskin[i]-sd3neg)/sd23neg)
						}

		} else mat$zss[i]<-NA
}

return(mat)
}

######################################################################################
### Function for calculating individual Weight-for-length/height z-scores
######################################################################################

calc.zwfl<-function(mat,wflanthro,wfhanthro){

for(i in 1:length(mat$age.days)) {

	mat$zwfl[i]<-NA

       if(mat$oedema[i]!="y") {

		if( (!is.na(mat$age.days[i]) & mat$age.days[i]<731) | (is.na(mat$age.days[i]) & !is.na(mat$l.h[i]) & (mat$l.h[i]=="l" | mat$l.h[i]=="L")) | (is.na(mat$age.days[i]) & is.na(mat$l.h[i]) & !is.na(mat$clenhei[i]) & mat$clenhei[i]<87) ) {

			if(!is.na(mat$clenhei[i]) & mat$clenhei[i]>=45 & mat$clenhei[i]<=110) {

			### Interpolated l,m,s values

			low.len<-trunc(mat$clenhei[i]*10)/10
          upp.len<-trunc(mat$clenhei[i]*10+1)/10
			diff.len<-(mat$clenhei[i]-low.len)/0.1

			if(diff.len>0) {
			l.val<-wflanthro$l[wflanthro$length==low.len & wflanthro$sex==mat$sex[i]]+diff.len*( wflanthro$l[wflanthro$length==upp.len & wflanthro$sex==mat$sex[i]]-wflanthro$l[wflanthro$length==low.len & wflanthro$sex==mat$sex[i]] )
			m.val<-wflanthro$m[wflanthro$length==low.len & wflanthro$sex==mat$sex[i]]+diff.len*( wflanthro$m[wflanthro$length==upp.len & wflanthro$sex==mat$sex[i]]-wflanthro$m[wflanthro$length==low.len & wflanthro$sex==mat$sex[i]] )
			s.val<-wflanthro$s[wflanthro$length==low.len & wflanthro$sex==mat$sex[i]]+diff.len*( wflanthro$s[wflanthro$length==upp.len & wflanthro$sex==mat$sex[i]]-wflanthro$s[wflanthro$length==low.len & wflanthro$sex==mat$sex[i]] )
			} else {
				l.val<-wflanthro$l[wflanthro$length==low.len & wflanthro$sex==mat$sex[i]]
				m.val<-wflanthro$m[wflanthro$length==low.len & wflanthro$sex==mat$sex[i]]
				s.val<-wflanthro$s[wflanthro$length==low.len & wflanthro$sex==mat$sex[i]]
			}

			mat$zwfl[i]<-(((mat$weight[i]/m.val)^l.val)-1)/(s.val*l.val)
			if(!is.na(mat$zwfl[i]) & mat$zwfl[i]>3) {
							sd3pos<- m.val*((1+l.val*s.val*3)^(1/l.val))
							sd23pos<- sd3pos- m.val*((1+l.val*s.val*2)^(1/l.val))
							mat$zwfl[i]<- 3+((mat$weight[i]-sd3pos)/sd23pos)
						}
			if(!is.na(mat$zwfl[i]) & mat$zwfl[i]<(-3)) {
							sd3neg<- m.val*((1+l.val*s.val*(-3))**(1/l.val))
							sd23neg<- m.val*((1+l.val*s.val*(-2))**(1/l.val))-sd3neg
							mat$zwfl[i]<- (-3)-((sd3neg-mat$weight[i])/sd23neg)
							}
				}
			}

			else 		if( (!is.na(mat$age.days[i]) & mat$age.days[i]>=731) | (is.na(mat$age.days[i]) & !is.na(mat$l.h[i]) & (mat$l.h[i]=="h" | mat$l.h[i]=="H"))  | (is.na(mat$age.days[i]) & is.na(mat$l.h[i]) & !is.na(mat$clenhei[i]) & mat$clenhei[i]>=87) ) {

			if(!is.na(mat$clenhei[i]) & mat$clenhei[i]>=65 & mat$clenhei[i]<=120) {

			### Interpolated l,m,s values

			low.len<-trunc(mat$clenhei[i]*10)/10
          		upp.len<-trunc(mat$clenhei[i]*10+1)/10
			diff.len<-(mat$clenhei[i]-low.len)/0.1

			if(diff.len>0) {
			l.val<-wfhanthro$l[wfhanthro$height==low.len & wfhanthro$sex==mat$sex[i]]+diff.len*( wfhanthro$l[wfhanthro$height==upp.len & wfhanthro$sex==mat$sex[i]]-wfhanthro$l[wfhanthro$height==low.len & wfhanthro$sex==mat$sex[i]] )
			m.val<-wfhanthro$m[wfhanthro$height==low.len & wfhanthro$sex==mat$sex[i]]+diff.len*( wfhanthro$m[wfhanthro$height==upp.len & wfhanthro$sex==mat$sex[i]]-wfhanthro$m[wfhanthro$height==low.len & wfhanthro$sex==mat$sex[i]] )
			s.val<-wfhanthro$s[wfhanthro$height==low.len & wfhanthro$sex==mat$sex[i]]+diff.len*( wfhanthro$s[wfhanthro$height==upp.len & wfhanthro$sex==mat$sex[i]]-wfhanthro$s[wfhanthro$height==low.len & wfhanthro$sex==mat$sex[i]] )
          } else {
			l.val<-wfhanthro$l[wfhanthro$height==low.len & wfhanthro$sex==mat$sex[i]]
			m.val<-wfhanthro$m[wfhanthro$height==low.len & wfhanthro$sex==mat$sex[i]]
			s.val<-wfhanthro$s[wfhanthro$height==low.len & wfhanthro$sex==mat$sex[i]]
			}

			mat$zwfl[i]<-(((mat$weight[i]/m.val)^l.val)-1)/(s.val*l.val)
			if(!is.na(mat$zwfl[i]) & mat$zwfl[i]>3) {
							sd3pos<- m.val*((1+l.val*s.val*3)^(1/l.val))
							sd23pos<- sd3pos- m.val*((1+l.val*s.val*2)^(1/l.val))
							mat$zwfl[i]<- 3+((mat$weight[i]-sd3pos)/sd23pos)
							}
			if(!is.na(mat$zwfl[i]) & mat$zwfl[i]<(-3)) {
							sd3neg<- m.val*((1+l.val*s.val*(-3))**(1/l.val))
							sd23neg<- m.val*((1+l.val*s.val*(-2))**(1/l.val))-sd3neg
							mat$zwfl[i]<- (-3)-((sd3neg-mat$weight[i])/sd23neg)
							}
				}
			}
		}

		if(!is.na(mat$age.day[i]) & mat$age.days[i]>1856) mat$zwfl[i]<-NA

}

return(mat)
}

######################################################################################
### Function for calulating individual BMI-for-age z-scores
######################################################################################

calc.zbmi<-function(mat,bmianthro){

for(i in 1:length(mat$age.days)) {

	if(!is.na(mat$age.days[i]) & mat$oedema[i]!="y") {

		l.val<-bmianthro$l[bmianthro$age==mat$age.days[i] & bmianthro$sex==mat$sex[i]]
		m.val<-bmianthro$m[bmianthro$age==mat$age.days[i] & bmianthro$sex==mat$sex[i]]
		s.val<-bmianthro$s[bmianthro$age==mat$age.days[i] & bmianthro$sex==mat$sex[i]]

		mat$zbmi[i]<-(((mat$cbmi[i]/m.val)^l.val)-1)/(s.val*l.val)
		if(!is.na(mat$zbmi[i]) & mat$zbmi[i]>3) {
						sd3pos<- m.val*((1+l.val*s.val*3)^(1/l.val))
						sd23pos<- sd3pos- m.val*((1+l.val*s.val*2)^(1/l.val))
						mat$zbmi[i]<- 3+((mat$cbmi[i]-sd3pos)/sd23pos)
						}
		if(!is.na(mat$zbmi[i]) & mat$zbmi[i]< (-3)) {
						sd3neg<- m.val*((1+l.val*s.val*(-3))**(1/l.val))
						sd23neg<- m.val*((1+l.val*s.val*(-2))**(1/l.val))-sd3neg
						mat$zbmi[i]<- (-3)+((mat$cbmi[i]-sd3neg)/sd23neg)
						}

		} else mat$zbmi[i]<-NA

}

return(mat)
}

###################################################################################
#### Main function starts here: igrowup
###################################################################################

###############################################################################################################################################
#### This function can be used to:
#### 1. Calculate the z-scores for the indicators: length/height-for-age, weight-for-age, weight-for-legnth/height and body mass index-for-age
####    The output file with z-scores values is exported the file to an Excel spreadsheet (see readme file);
#### 2. Calculate the prevalence rates of stunting, underweight, wasting and overweight, and z-scores means and standard deviations. Results
####    are exported to an Excel spreadsheet, displayed by age group.
###############################################################################################################################################

#############################################################################
##### Function for calculating the z-scores for all indicators
#############################################################################

igrowup.standard <- function(FileLab="Temp",FilePath="C:\\Documents and Settings",mydf,sex,age,age.month=F,weight=rep(NA,dim(mydf)[1]),lenhei=rep(NA,dim(mydf)[1]),measure=rep(NA,dim(mydf)[1]),
           headc=rep(NA,dim(mydf)[1]),armc=rep(NA,dim(mydf)[1]),triskin=rep(NA,dim(mydf)[1]),subskin=rep(NA,dim(mydf)[1]),oedema=rep("n",dim(mydf)[1]),sw=rep(1,dim(mydf)[1])) {

#############################################################################
###########   Calculating the z-scores for all indicators
#############################################################################

   old <- options(warn=(-1))

   sex.x<-as.character(get(deparse(substitute(mydf)))[,deparse(substitute(sex))])
   age.x<-as.double(get(deparse(substitute(mydf)))[,deparse(substitute(age))])
   if(!missing(weight)) weight.x<-as.double(get(deparse(substitute(mydf)))[,deparse(substitute(weight))]) else weight.x<-as.double(weight)
   if(!missing(lenhei)) lenhei.x<-as.double(get(deparse(substitute(mydf)))[,deparse(substitute(lenhei))]) else lenhei.x<-as.double(lenhei)
   if(!missing(headc)) headc.x<-as.double(get(deparse(substitute(mydf)))[,deparse(substitute(headc))]) else headc.x<-as.double(headc)
   if(!missing(armc)) armc.x<-as.double(get(deparse(substitute(mydf)))[,deparse(substitute(armc))]) else armc.x<-as.double(armc)
   if(!missing(triskin)) triskin.x<-as.double(get(deparse(substitute(mydf)))[,deparse(substitute(triskin))]) else triskin.x<-as.double(triskin)
   if(!missing(subskin)) subskin.x<-as.double(get(deparse(substitute(mydf)))[,deparse(substitute(subskin))]) else subskin.x<-as.double(subskin)
   if(!missing(measure)) lorh.vec<-as.character(get(deparse(substitute(mydf)))[,deparse(substitute(measure))]) else lorh.vec<-as.character(measure)
   if(!missing(oedema)) oedema.vec<-as.character(get(deparse(substitute(mydf)))[,deparse(substitute(oedema))]) else oedema.vec<-oedema
   if(!missing(sw))	sw<-as.double(get(deparse(substitute(mydf)))[,deparse(substitute(sw))])	else sw<-as.double(sw)
   sw<-ifelse(is.na(sw),0,sw)

	sex.vec<-NULL

	if(age.month) age.vec<-rounde(age.x*30.4375) else age.vec<-rounde(age.x)
	lenhei.vec<-ifelse((!is.na(age.vec) & age.vec<731 & !is.na(lorh.vec) & (lorh.vec=="h" | lorh.vec=="H")),lenhei.x+0.7,#
		  ifelse((!is.na(age.vec) & age.vec>=731 & !is.na(lorh.vec) & (lorh.vec=="l" | lorh.vec=="L")),lenhei.x-0.7,lenhei.x))

   sex.vec<-ifelse(!is.na(sex.x) & (sex.x=="m" | sex.x=="M" | sex.x=="1"),1,ifelse(!is.na(sex.x) & (sex.x=="f" | sex.x=="F" | sex.x=="2"),2,NA))

   lorh.vec<-ifelse(is.na(lorh.vec) | lorh.vec=="l" | lorh.vec=="L" | lorh.vec=="h" | lorh.vec=="H",lorh.vec,NA)

   oedema.vec<-ifelse(oedema.vec=="n" | oedema.vec=="N","n",ifelse(oedema.vec=="y" | oedema.vec=="Y","y","n"))

   mat<-cbind.data.frame(age.x,as.integer(age.vec),as.double(sex.vec),weight.x,lenhei.x,lorh.vec,lenhei.vec,headc.x,armc.x,triskin.x,subskin.x,oedema.vec,sw,stringsAsFactors=F)
	names(mat)<-c("age","age.days","sex","weight","len.hei","l.h","clenhei","headc","armc","triskin","subskin","oedema","sw")

	mat$cbmi<-mat$weight/((lenhei.vec/100)^2)
	mat$zlen<-rep(NA,length(mat$age))
	mat$zwei<-rep(NA,length(mat$age))
	mat$zwfl<-rep(NA,length(mat$age))
	mat$zbmi<-rep(NA,length(mat$age))
	mat$zhc<-rep(NA,length(mat$age))
	mat$zac<-rep(NA,length(mat$age))
	mat$zts<-rep(NA,length(mat$age))
	mat$zss<-rep(NA,length(mat$age))

	mat$zlen<-rep(NA,length(mat$age))
	mat$flen<-rep(NA,length(mat$age))
	mat$fwei<-rep(NA,length(mat$age))
	mat$fwfl<-rep(NA,length(mat$age))
	mat$fbmi<-rep(NA,length(mat$age))
	mat$fhc<-rep(NA,length(mat$age))
	mat$fac<-rep(NA,length(mat$age))
	mat$fts<-rep(NA,length(mat$age))
	mat$fss<-rep(NA,length(mat$age))

#############################################################################
###########   Calculating the z-scores for all indicators
#############################################################################

cat("Please wait while calculating z-scores...\n")

### Length-for-age z-score

mat<-calc.zlen(mat,lenanthro)

### Head circumference-for-age z-score

mat<-calc.zhc(mat,hcanthro)

### Weight-for-age z-score

mat<-calc.zwei(mat,weianthro)

### Arm circumference-for-age z-score

mat<-calc.zac(mat,acanthro)

### Triceps skinfold-for-age z-score

mat<-calc.zts(mat,tsanthro)

### Subscapular skinfold-for-age z-score

mat<-calc.zss(mat,ssanthro)

### Weight-for-length/height z-score

mat<-calc.zwfl(mat,wflanthro,wfhanthro)

### BMI-for-age z-score

mat<-calc.zbmi(mat,bmianthro)

#### Rounding the z-scores to two decimals

			mat$zlen<-rounde(mat$zlen,digits=2)
			mat$zwei<-rounde(mat$zwei,digits=2)
			mat$zwfl<-rounde(mat$zwfl,digits=2)
			mat$zbmi<-rounde(mat$zbmi,digits=2)
			mat$zhc<-rounde(mat$zhc,digits=2)
			mat$zac<-rounde(mat$zac,digits=2)
			mat$zts<-rounde(mat$zts,digits=2)
			mat$zss<-rounde(mat$zss,digits=2)

#### Flagging z-score values for individual indicators

			mat$flen<-ifelse(abs(mat$zlen) > 6,1,0)
			mat$fwei<-ifelse(mat$zwei > 5 | mat$zwei < (-6),1,0)
			mat$fwfl<-ifelse(abs(mat$zwfl) > 5,1,0)
			mat$fbmi<-ifelse(abs(mat$zbmi) > 5,1,0)
			mat$fhc<-ifelse(abs(mat$zhc) > 5,1,0)
			mat$fac<-ifelse(abs(mat$zac) > 5,1,0)
			mat$fts<-ifelse(abs(mat$zts) > 5,1,0)
			mat$fss<-ifelse(abs(mat$zss) > 5,1,0)

cat(paste("Z-scores calculated - preparing matrix to be exported..."))

mat<-cbind.data.frame(mydf,mat[,-c(1,3:6,8:9)])

###################################################################################################
######### Export data frame with z-scores and flag variables
###################################################################################################

assign("matz",mat,envir = .GlobalEnv)

write.table(matz, file=paste(FilePath,"\\",FileLab,"_z_st.csv",sep=""),na="",row.names = FALSE,sep=",",quote = TRUE)

cat(paste("Z-scores calculated and exported to ",FilePath,"\\",FileLab,"_z_st.csv\n\n",sep=""))

#######################################################################################################
#### Calculating prevalences and summary statistics.
#######################################################################################################

if(any(sw <0)) stop("Negative weights are not allowed and program will stop. Prevalence tables will not be produced.")

mat.out<-mat

################################
#### Creating age group variable
################################

mat.out$sw.vec<-sw
mat.out$sex.vec<-as.double(sex.vec)
mat.out$oedema.vec<-as.character(oedema.vec)

if(age.month) mat.out$agegr <- ifelse(!is.na(age.x) & age.x<6,0,ifelse(!is.na(age.x) & age.x<12,6,#
                     ifelse(!is.na(age.x) & age.x<24,12,ifelse(!is.na(age.x) & age.x<36,24,#
                     ifelse(!is.na(age.x) & age.x<48,36,ifelse(!is.na(age.x) & age.x<61,48,NA)  )))))

else mat.out$agegr <- ifelse(!is.na(mat.out$age.days) & mat.out$age.days/30.4375<6,0,ifelse(!is.na(mat.out$age.days) & mat.out$age.days/30.4375<12,6,#
                     ifelse(!is.na(mat.out$age.days) & mat.out$age.days/30.4375<24,12,ifelse(!is.na(mat.out$age.days) & mat.out$age.days/30.4375<36,24,#
                     ifelse(!is.na(mat.out$age.days) & mat.out$age.days/30.4375<48,36,ifelse(!is.na(mat.out$age.days) & mat.out$age.days/30.4375<61,48,NA)  )))))

##############################################
#### Make z-score as missing if it is flagged
##############################################

mat.out$zlen<-ifelse(!is.na(mat.out$flen) & mat.out$flen!=0,NA,mat.out$zlen)
mat.out$zwei<-ifelse(!is.na(mat.out$fwei) & mat.out$fwei!=0,NA,mat.out$zwei)
mat.out$zwfl<-ifelse(!is.na(mat.out$fwfl) & mat.out$fwfl!=0,NA,mat.out$zwfl)
mat.out$zbmi<-ifelse(!is.na(mat.out$fbmi) & mat.out$fbmi!=0,NA,mat.out$zbmi)
mat.out$zhc<-ifelse(!is.na(mat.out$fhc) & mat.out$fhc!=0,NA,mat.out$zhc)
mat.out$zac<-ifelse(!is.na(mat.out$fac) & mat.out$fac!=0,NA,mat.out$zac)
mat.out$zts<-ifelse(!is.na(mat.out$fts) & mat.out$fts!=0,NA,mat.out$zts)
mat.out$zss<-ifelse(!is.na(mat.out$fss) & mat.out$fss!=0,NA,mat.out$zss)

##############################################
#### Include all levels of age group variable
##############################################

mat.aux<-as.data.frame(cbind(array(rep(NA,((dim(mat.out)[2]-1)*6)),dim=c(6,(dim(mat.out)[2]-1)) ),c(0,6,12,24,36,48)))
names(mat.aux)<-names(mat.out)
mat.out<-rbind(mat.out,mat.aux)

##############################################################################################
#### Make Oedema variable to be "n" if age greater than 60 completed months (>=61 months).
#### This is beacuse children with oedema counts in the prevalence even if z-score is missing
#### for weight related indicators.
##############################################################################################

mat.out$oedema.vec<-ifelse((!is.na(mat.out$age.days) & mat.out$age.days/30.4375>=61) | mat.out$oedema.vec=="NA","n",mat.out$oedema.vec)

#####################################################################################################################################################
#### Creating matrix with estimated prevalences, confidence intervals, and means and standard deviations of z-scores and exporting it to Excel file.
#####################################################################################################################################################

cat("\nPlease wait while calculating prevalences and z-score summary statistics...\n")

#### Sexes combined

#### % < -3 SD for all the indicators
mat<-t(cbind.data.frame(#
       prevnh(-3,mat.out$zwei,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevnh(-3, z$zwei, z$sw.vec, z$oedema.vec)),#
       prevnh.L(-3,mat.out$zlen,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevnh.L(-3, z$zlen, z$sw.vec)),#
       prevnh(-3,mat.out$zwfl,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevnh(-3, z$zwfl, z$sw.vec, z$oedema.vec)),#
       prevnh(-3,mat.out$zbmi,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevnh(-3, z$zbmi, z$sw.vec, z$oedema.vec))))

#### % < -2 SD for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       prevnh(-2,mat.out$zwei,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevnh(-2, z$zwei, z$sw.vec, z$oedema.vec)),#
       prevnh.L(-2,mat.out$zlen,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevnh.L(-2, z$zlen, z$sw.vec)),#
       prevnh(-2,mat.out$zwfl,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevnh(-2, z$zwfl, z$sw.vec, z$oedema.vec)),#
       prevnh(-2,mat.out$zbmi,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevnh(-2, z$zbmi, z$sw.vec, z$oedema.vec))))[,-1])

#### % > +1 SD for weight-for-length/height and bmi-for-age
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       array(rep(NA,28),dim=c(4,7)),#
       array(rep(NA,28),dim=c(4,7)),#
       prevph(1,mat.out$zwfl,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevph(1, z$zwfl, z$sw.vec, z$oedema.vec)),#
       prevph(1,mat.out$zbmi,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevph(1, z$zbmi, z$sw.vec, z$oedema.vec))))[,-1])

#### % > +2 SD for weight-for-length/height and bmi-for-age
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       array(rep(NA,28),dim=c(4,7)),#
       array(rep(NA,28),dim=c(4,7)),#
       prevph(2,mat.out$zwfl,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevph(2, z$zwfl, z$sw.vec, z$oedema.vec)),#
       prevph(2,mat.out$zbmi,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevph(2, z$zbmi, z$sw.vec, z$oedema.vec))))[,-1])

#### % > +3 SD for weight-for-length/height and bmi-for-age
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       array(rep(NA,28),dim=c(4,7)),#
       array(rep(NA,28),dim=c(4,7)),#
       prevph(3,mat.out$zwfl,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevph(3, z$zwfl, z$sw.vec, z$oedema.vec)),#
       prevph(3,mat.out$zbmi,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevph(3, z$zbmi, z$sw.vec, z$oedema.vec))))[,-1])

#### Means of z-scores for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       wmean(mat.out$zwei,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wmean(z$zwei,z$sw.vec)),#
       wmean(mat.out$zlen,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wmean(z$zlen,z$sw.vec)),#
       wmean(mat.out$zwfl,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wmean(z$zwfl,z$sw.vec)),#
       wmean(mat.out$zbmi,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wmean(z$zbmi,z$sw.vec)))))

#### Standard deviations of z-scores for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       wsd(mat.out$zwei,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wsd(z$zwei,z$sw.vec)),#
       wsd(mat.out$zlen,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wsd(z$zlen,z$sw.vec)),#
       wsd(mat.out$zwfl,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wsd(z$zwfl,z$sw.vec)),#
       wsd(mat.out$zbmi,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wsd(z$zbmi,z$sw.vec)))))

####################################################################################################################
##### Creating matrix to export as Excel file

mat[1:14,8]<-mat[1:14,17]
mat[1:14,9]<-mat[1:14,18]
mat[1:14,10:18]<-array(rep("",126),dim=c(14,9))
rm(mat1)
mat1<-rbind(c("Set 1:","Sexes","combined",rep("",15)),c("Weight","-for-","age",rep("",15)),#
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","Mean","SD","","", "","","", "","","", ""),mat[1:7,],#
                       c("Length","/height","-for-","age",rep("",14)),
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","Mean","SD","","", "","","", "","","", ""),mat[8:14,],#
                       c("Weight","-for-","length","/height",rep("",14)),
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","% > +1 SD","95%", "C.I.","% > +2 SD","95%", "C.I.","% > +3 SD","95%", "C.I.","Mean","SD"),mat[15:21,],#
                       c("BMI","-for-","age",rep("",15)),
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","% > +1 SD","95%", "C.I.","% > +2 SD","95%", "C.I.","% > +3 SD","95%", "C.I.","Mean","SD"),mat[22:28,])

for(j in 1:dim(mat1)[2]) mat1[,j]<-ifelse(mat1[,j]=="NA" | mat1[,j]=="NaN","",mat1[,j])

mat1<-cbind(c("",rep(c(""," Age"," 0-60","0-5"," 6-11"," 12-23"," 24-35"," 36-47"," 48-60"),4)),mat1)

####################################################################################################################

##### For boys and girls

for(i in 1:2) {

mat.out.sex<-mat.out[!is.na(mat.out$sex.vec) & mat.out$sex.vec==i,]

mat.aux<-as.data.frame(cbind(array(rep(NA,((dim(mat.out.sex)[2]-1)*6)),dim=c(6,(dim(mat.out.sex)[2]-1)) ),c(0,6,12,24,36,48)))
names(mat.aux)<-names(mat.out.sex)
mat.out.sex<-rbind.data.frame(mat.out.sex,mat.aux )
mat.out.sex$oedema.vec<-ifelse((!is.na(mat.out.sex$age.days) & mat.out.sex$age.days/30.4375>=61) | mat.out.sex$oedema.vec=="NA","n",mat.out.sex$oedema.vec)

#### % < -3 SD for all the indicators
mat<-t(cbind.data.frame(#
       prevnh(-3,mat.out.sex$zwei,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevnh(-3, z$zwei, z$sw.vec, z$oedema.vec)),#
       prevnh.L(-3,mat.out.sex$zlen,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevnh.L(-3, z$zlen, z$sw.vec)),#
       prevnh(-3,mat.out.sex$zwfl,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevnh(-3, z$zwfl, z$sw.vec, z$oedema.vec)),#
       prevnh(-3,mat.out.sex$zbmi,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevnh(-3, z$zbmi, z$sw.vec, z$oedema.vec))))

#### % < -2 SD for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       prevnh(-2,mat.out.sex$zwei,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevnh(-2, z$zwei, z$sw.vec, z$oedema.vec)),#
       prevnh.L(-2,mat.out.sex$zlen,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevnh.L(-2, z$zlen, z$sw.vec)),#
       prevnh(-2,mat.out.sex$zwfl,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevnh(-2, z$zwfl, z$sw.vec, z$oedema.vec)),#
       prevnh(-2,mat.out.sex$zbmi,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevnh(-2, z$zbmi, z$sw.vec, z$oedema.vec))))[,-1])

#### % > +1 SD for weight-for-length/height and bmi-for-age
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       array(rep(NA,28),dim=c(4,7)),#
       array(rep(NA,28),dim=c(4,7)),#
       prevph(1,mat.out.sex$zwfl,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevph(1, z$zwfl, z$sw.vec, z$oedema.vec)),#
       prevph(1,mat.out.sex$zbmi,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevph(1, z$zbmi, z$sw.vec, z$oedema.vec))))[,-1])

#### % > +2 SD for weight-for-length/height and bmi-for-age
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       array(rep(NA,28),dim=c(4,7)),#
       array(rep(NA,28),dim=c(4,7)),#
       prevph(2,mat.out.sex$zwfl,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevph(2, z$zwfl, z$sw.vec, z$oedema.vec)),#
       prevph(2,mat.out.sex$zbmi,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevph(2, z$zbmi, z$sw.vec, z$oedema.vec))))[,-1])

#### % > +3 SD for weight-for-length/height and bmi-for-age
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       array(rep(NA,28),dim=c(4,7)),#
       array(rep(NA,28),dim=c(4,7)),#
       prevph(3,mat.out.sex$zwfl,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevph(3, z$zwfl, z$sw.vec, z$oedema.vec)),#
       prevph(3,mat.out.sex$zbmi,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevph(3, z$zbmi, z$sw.vec, z$oedema.vec))))[,-1])

#### Means of z-scores for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       wmean(mat.out.sex$zwei,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wmean(z$zwei,z$sw.vec)),#
       wmean(mat.out.sex$zlen,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wmean(z$zlen,z$sw.vec)),#
       wmean(mat.out.sex$zwfl,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wmean(z$zwfl,z$sw.vec)),#
       wmean(mat.out.sex$zbmi,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wmean(z$zbmi,z$sw.vec)))))

#### Standard deviations of z-scores for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       wsd(mat.out.sex$zwei,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wsd(z$zwei,z$sw.vec)),#
       wsd(mat.out.sex$zlen,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wsd(z$zlen,z$sw.vec)),#
       wsd(mat.out.sex$zwfl,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wsd(z$zwfl,z$sw.vec)),#
       wsd(mat.out.sex$zbmi,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wsd(z$zbmi,z$sw.vec)))))

####################################################################################################################
##### Creating matrix to export as Excel file

mat[1:14,8]<-mat[1:14,17]
mat[1:14,9]<-mat[1:14,18]
mat[1:14,10:18]<-array(rep("",126),dim=c(14,9))

mat2<-rbind(c(paste("Set ",i+1,":",sep=""),c("Males","Females")[i],rep("",16)),c("Weight","-for-","age",rep("",15)),#
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","Mean","SD","","", "","","", "","","", ""),mat[1:7,],#
                       c("Length","/height","-for-","age",rep("",14)),
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","Mean","SD","","", "","","", "","","", ""),mat[8:14,],#
                       c("Weight","-for-","length","/height",rep("",14)),
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","% > +1 SD","95%", "C.I.","% > +2 SD","95%", "C.I.","% > +3 SD","95%", "C.I.","Mean","SD"),mat[15:21,],#
                       c("BMI","-for-","age",rep("",15)),
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","% > +1 SD","95%", "C.I.","% > +2 SD","95%", "C.I.","% > +3 SD","95%", "C.I.","Mean","SD"),mat[22:28,])

for(j in 1:dim(mat2)[2]) mat2[,j]<-ifelse(mat2[,j]=="NA" | mat2[,j]=="NaN","",mat2[,j])

mat2<-cbind(c("",rep(c(""," Age"," 0-60"," 0-5"," 6-11"," 12-23"," 24-35"," 36-47"," 48-60"),4)),mat2)

names(mat2)<-names(mat1)

mat1<-rbind(mat1,mat2)

}    #### End of loop for sex

###################################################################################################################
######### Creating another matrix for the second set of indicators
###################################################################################################################

#####################################################################################################################################################
#### Creating matrix with estimated prevalences, confidence intervals, and means and standard deviations of z-scores and exporting it to Excel file.
#####################################################################################################################################################

#### Sexes combined

#### % < -3 SD for all the indicators
mat<-t(cbind.data.frame(#
       prevnh.L(-3,mat.out$zhc,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevnh.L(-3, z$zhc, z$sw.vec)),#
       prevnh.L(-3,mat.out$zac,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevnh.L(-3, z$zac, z$sw.vec)),#
       prevnh.L(-3,mat.out$zts,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevnh.L(-3, z$zts, z$sw.vec)),#
       prevnh.L(-3,mat.out$zss,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevnh.L(-3, z$zss, z$sw.vec))))

#### % < -2 SD for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       prevnh.L(-2,mat.out$zhc,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevnh.L(-2, z$zhc, z$sw.vec)),#
       prevnh.L(-2,mat.out$zac,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevnh.L(-2, z$zac, z$sw.vec)),#
       prevnh.L(-2,mat.out$zts,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevnh.L(-2, z$zts, z$sw.vec)),#
       prevnh.L(-2,mat.out$zss,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevnh.L(-2, z$zss, z$sw.vec))))[,-1])

#### % > +1 SD for weight-for-length/height and bmi-for-age
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       prevph.L(1,mat.out$zhc,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevph.L(1, z$zhc, z$sw.vec)),#
       prevph.L(1,mat.out$zac,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevph.L(1, z$zac, z$sw.vec)),#
       prevph.L(1,mat.out$zts,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevph.L(1, z$zts, z$sw.vec)),#
       prevph.L(1,mat.out$zss,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevph.L(1, z$zss, z$sw.vec))))[,-1])

#### % > +2 SD for weight-for-length/height and bmi-for-age
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       prevph.L(2,mat.out$zhc,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevph.L(2, z$zhc, z$sw.vec)),#
       prevph.L(2,mat.out$zac,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevph.L(2, z$zac, z$sw.vec)),#
       prevph.L(2,mat.out$zts,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevph.L(2, z$zts, z$sw.vec)),#
       prevph.L(2,mat.out$zss,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevph.L(2, z$zss, z$sw.vec))))[,-1])

#### % > +3 SD for weight-for-length/height and bmi-for-age
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       prevph.L(3,mat.out$zhc,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevph.L(3, z$zhc, z$sw.vec)),#
       prevph.L(3,mat.out$zac,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevph.L(3, z$zac, z$sw.vec)),#
       prevph.L(3,mat.out$zts,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevph.L(3, z$zts, z$sw.vec)),#
       prevph.L(3,mat.out$zss,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevph.L(3, z$zss, z$sw.vec))))[,-1])

#### Means of z-scores for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       wmean(mat.out$zhc,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wmean(z$zhc,z$sw.vec)),#
       wmean(mat.out$zac,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wmean(z$zac,z$sw.vec)),#
       wmean(mat.out$zts,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wmean(z$zts,z$sw.vec)),#
       wmean(mat.out$zss,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wmean(z$zss,z$sw.vec)))))

#### Standard deviations of z-scores for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       wsd(mat.out$zhc,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wsd(z$zhc,z$sw.vec)),#
       wsd(mat.out$zac,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wsd(z$zac,z$sw.vec)),#
       wsd(mat.out$zts,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wsd(z$zts,z$sw.vec)),#
       wsd(mat.out$zss,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wsd(z$zss,z$sw.vec)))))

####################################################################################################################
##### Exporting matrix to Excel file

mat3<-rbind(c("Set 1:","Sexes","combined",rep("",15)),c("Head ","circumference","-for-","age",rep("",14)),#
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","% > +1 SD","95%", "C.I.","% > +2 SD","95%", "C.I.","% > +3 SD","95%", "C.I.","Mean","SD"),mat[1:7,],#
                       c("MUAC","-for-","age","",rep("",14)),
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","% > +1 SD","95%", "C.I.","% > +2 SD","95%", "C.I.","% > +3 SD","95%", "C.I.","Mean","SD"),mat[8:14,],#
                       c("Triceps ","skinfold","-for-","age",rep("",14)),
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","% > +1 SD","95%", "C.I.","% > +2 SD","95%", "C.I.","% > +3 SD","95%", "C.I.","Mean","SD"),mat[15:21,],#
                       c("Subscapular ","skinfold","-for-","age",rep("",14)),
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","% > +1 SD","95%", "C.I.","% > +2 SD","95%", "C.I.","% > +3 SD","95%", "C.I.","Mean","SD"),mat[22:28,])

for(j in 1:dim(mat3)[2]) mat3[,j]<-ifelse(mat3[,j]=="NA" | mat3[,j]=="NaN","",mat3[,j])

mat3<-cbind.data.frame(c("",c(c(""," Age"," 0-60"," 0-5"," 6-11"," 12-23"," 24-35"," 36-47"," 48-60"),rep(c(""," Age"," 3-60"," 3-5"," 6-11"," 12-23"," 24-35"," 36-47"," 48-60"),3))),mat3)

####################################################################################################################

##### For boys and girls

for(i in 1:2) {

mat.out.sex<-mat.out[!is.na(mat.out$sex.vec) & mat.out$sex.vec==i,]
mat.aux<- as.data.frame(cbind(array(rep(NA,((dim(mat.out.sex)[2]-1)*6)),dim=c(6,(dim(mat.out.sex)[2]-1)) ),c(0,6,12,24,36,48))	)
names(mat.aux)<-names(mat.out.sex)
mat.out.sex<-rbind(mat.out.sex, mat.aux)
mat.out.sex$oedema.vec<-ifelse((!is.na(mat.out.sex$age.days) & mat.out.sex$age.days/30.4375>=61) | mat.out.sex$oedema.vec=="NA","n",mat.out.sex$oedema.vec)

#### % < -3 SD for all the indicators
mat<-t(cbind.data.frame(#
       prevnh.L(-3,mat.out.sex$zhc,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevnh.L(-3, z$zhc, z$sw.vec)),#
       prevnh.L(-3,mat.out.sex$zac,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevnh.L(-3, z$zac, z$sw.vec)),#
       prevnh.L(-3,mat.out.sex$zts,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevnh.L(-3, z$zts, z$sw.vec)),#
       prevnh.L(-3,mat.out.sex$zss,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevnh.L(-3, z$zss, z$sw.vec))))

#### % < -2 SD for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       prevnh.L(-2,mat.out.sex$zhc,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevnh.L(-2, z$zhc, z$sw.vec)),#
       prevnh.L(-2,mat.out.sex$zac,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevnh.L(-2, z$zac, z$sw.vec)),#
       prevnh.L(-2,mat.out.sex$zts,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevnh.L(-2, z$zts, z$sw.vec)),#
       prevnh.L(-2,mat.out.sex$zss,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevnh.L(-2, z$zss, z$sw.vec))))[,-1])

#### % > +1 SD for weight-for-length/height and bmi-for-age
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       prevph.L(1,mat.out.sex$zhc,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevph.L(1, z$zhc, z$sw.vec)),#
       prevph.L(1,mat.out.sex$zac,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevph.L(1, z$zac, z$sw.vec)),#
       prevph.L(1,mat.out.sex$zts,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevph.L(1, z$zts, z$sw.vec)),#
       prevph.L(1,mat.out.sex$zss,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevph.L(1, z$zss, z$sw.vec))))[,-1])

#### % > +2 SD for weight-for-length/height and bmi-for-age
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       prevph.L(2,mat.out.sex$zhc,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevph.L(2, z$zhc, z$sw.vec)),#
       prevph.L(2,mat.out.sex$zac,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevph.L(2, z$zac, z$sw.vec)),#
       prevph.L(2,mat.out.sex$zts,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevph.L(2, z$zts, z$sw.vec)),#
       prevph.L(2,mat.out.sex$zss,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevph.L(2, z$zss, z$sw.vec))))[,-1])

#### % > +3 SD for weight-for-length/height and bmi-for-age
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       prevph.L(3,mat.out.sex$zhc,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevph.L(3, z$zhc, z$sw.vec)),#
       prevph.L(3,mat.out.sex$zac,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevph.L(3, z$zac, z$sw.vec)),#
       prevph.L(3,mat.out.sex$zts,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevph.L(3, z$zts, z$sw.vec)),#
       prevph.L(3,mat.out.sex$zss,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevph.L(3, z$zss, z$sw.vec))))[,-1])

#### Means of z-scores for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       wmean(mat.out.sex$zhc,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wmean(z$zhc,z$sw.vec)),#
       wmean(mat.out.sex$zac,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wmean(z$zac,z$sw.vec)),#
       wmean(mat.out.sex$zts,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wmean(z$zts,z$sw.vec)),#
       wmean(mat.out.sex$zss,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wmean(z$zss,z$sw.vec)))))

#### Standard deviations of z-scores for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       wsd(mat.out.sex$zhc,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wsd(z$zhc,z$sw.vec)),#
       wsd(mat.out.sex$zac,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wsd(z$zac,z$sw.vec)),#
       wsd(mat.out.sex$zts,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wsd(z$zts,z$sw.vec)),#
       wsd(mat.out.sex$zss,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wsd(z$zss,z$sw.vec)))))

####################################################################################################################
##### Exporting matrix to Excel file

mat4<-rbind.data.frame(c(paste("Set ",i+1,":",sep=""),c("Males","Females")[i],rep("",16)),c("Head ","circumference","-for-","age",rep("",14)),#
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","% > +1 SD","95%", "C.I.","% > +2 SD","95%", "C.I.","% > +3 SD","95%", "C.I.","Mean","SD"),mat[1:7,],#
                       c("MUAC","-for-","age","",rep("",14)),
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","% > +1 SD","95%", "C.I.","% > +2 SD","95%", "C.I.","% > +3 SD","95%", "C.I.","Mean","SD"),mat[8:14,],#
                       c("Triceps ","skinfold","-for-","age",rep("",14)),
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","% > +1 SD","95%", "C.I.","% > +2 SD","95%", "C.I.","% > +3 SD","95%", "C.I.","Mean","SD"),mat[15:21,],#
                       c("Subscapular ","skinfold","-for-","age",rep("",14)),
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","% > +1 SD","95%", "C.I.","% > +2 SD","95%", "C.I.","% > +3 SD","95%", "C.I.","Mean","SD"),mat[22:28,])

for(j in 1:dim(mat4)[2]) mat4[,j]<-ifelse(mat4[,j]=="NA" | mat4[,j]=="NaN","",mat4[,j])

mat4<-cbind.data.frame(c("",c(c(""," Age"," 0-60"," 0-5"," 6-11"," 12-23"," 24-35"," 36-47"," 48-60"),rep(c(""," Age"," 3-60"," 3-5"," 6-11"," 12-23"," 24-35"," 36-47"," 48-60"),3))),mat4)

names(mat4)<-names(mat3)
mat3<-rbind.data.frame(mat3,mat4)

}    #### End of loop for sex

names(mat3)<-names(mat1)

mat3<-rbind.data.frame(mat1,mat3)

###################################################################################################################
######### Export table with prevalence values and their confidence intervals, and mean and SD of the z-scores
###################################################################################################################

assign("matprev",mat3,envir = .GlobalEnv)

write.table(matprev, file=paste(FilePath,"\\",FileLab,"_prev_st.csv",sep=""),na=" ",row.names = FALSE,col.names=F,sep=",",quote = TRUE)

cat(paste("Prevalences and z-score summary statistics calculated and exported to ",FilePath,"\\",FileLab,"_prev_st.csv\n",sep=""))

on.exit(options(old))

invisible()

}   #### End of function igrowup.standard


# load packages needed to run this code
library(generativeart)
library(ggplot2)
library(tidyr)
library(dplyr)
library(gganimate)

# this function makes generative art
make_frame <- function(seed = 4182, state = 1, formula) {
  # set seed
  set.seed(seed)

  # making a data frame with the visualization
  df <- seq(from = -pi, to = pi, by = 0.02) %>%
    expand.grid(x_i = ., y_i = .) %>%
    dplyr::mutate(!!!formula)

  # split up the data frame to extract the final state
  df %>% select(x, y) %>%
    mutate(state = state)
}

# set different formulas that will be used in the animation
my_formula1 <- list(
  x = quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)),
  y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))
)

my_formula2 <- list(
  x = quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)),
  y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^4))
)

my_formula3 <- list(
  x = quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)),
  y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))
)

# make generative art for different seeds
rbind(make_frame(4182, 2, my_formula1), make_frame(2096, 1, my_formula2), make_frame(9228, 3, my_formula3)) -> df_animate

# make a data frame for background colors
df_back <- data.frame(
  xmin = -1.3, ymin = -1.3, xmax = 1.3, ymax = 1.3, x = 0, y = 0,
  fill = c("#ffde7d", "#a8e6cf", "#defcf9"),
  state = c(1, 2, 3)
)

# make an animation
# we convert x and y from cartesian to polar coordinates
# we wanted to keep visualization in polar coordinates and we wanted the background to change colors using `gganimate`
# `gganimate` only works on geoms, so the background is drawn with geom_rect()
df_animate %>%
  group_by(state) %>%
  mutate(
    r = (y-min(y))/diff(range(y)), # convert x and y to polar coordinates
    theta = 2*pi*(x-min(x))/diff(range(x))
  ) %>%
  ggplot(ggplot2::aes(x = r*sin(theta), y = r*cos(theta))) +
  geom_rect(
    data = df_back,
    aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax, fill = fill, group = 1, x = 1, y = 1),
    color = NA
  ) +
  scale_fill_identity() +
  geom_point(alpha = 0.2, size = 0, shape = 20) +
  theme_void() +
  coord_fixed(expand = FALSE) +
  transition_states(state, transition_length = 10, state_length = 0) -> p_genart

# animate
animate(p_genart,
        device = "png",
        width = 600,
        height = 600)

# save as gif
anim_save("generativeart.gif")


# load packages
library(dplyr)
library(tidyr)
library(ggplot2)
library(mirt)
library(readxl)

# Function for DIF Extraction
get.dif.items <- function(out.list,p.val,parms){
  dif.items <- NULL
  non.dif.items <- NULL
  for(i in 1:length(out.list)){ # loop list of items
    chi.sq <- out.list[[i]][2,6] #2 groups, so second row, and 6th column
    df <- out.list[[i]][2,7]
    p <- out.list[[i]][2,8]
    i.name <- names(out.list[i])
    d <- c(i.name,chi.sq,df,p,parms[i,])

    if(p < p.val){
      dif.items <- rbind(dif.items,d)
    }else{
      non.dif.items <- rbind(non.dif.items,d)
    }
  }
  if (!is.null(dif.items)) {
    dif.items <- data.frame(dif.items, row.names = NULL)
    colnames(dif.items)[1] <- "item"
    colnames(dif.items)[2] <- "chi.sq"
    colnames(dif.items)[3] <- "df"
    colnames(dif.items)[4] <- "p"

  }
  if (!is.null(non.dif.items)) {
    non.dif.items <- data.frame(non.dif.items, row.names = NULL)
    colnames(non.dif.items)[1] <- "item"
    colnames(non.dif.items)[2] <- "chi.sq"
    colnames(non.dif.items)[3] <- "df"
    colnames(non.dif.items)[4] <- "p"
  }
  r.list <- list(dif_items = dif.items, no_dif = non.dif.items)
  return(r.list)
}

# load data
belin <- read_excel('Data/IExcel_IRT_All5A.xlsx')

# Items names (column names of items)
english_items <- dplyr::select(belin, starts_with('Eng_AV_'))
math_items <- dplyr::select(belin, starts_with('Math_AV_'))
read_items <- dplyr::select(belin, starts_with('Read_AV_'))
sci_items <- dplyr::select(belin, starts_with("Sci_AV_"))

# group variable
grade <- as.character(belin$Grade)

# Eigenvalue
english_eigen <- eigen(cor(english_items))$values
english_eigen[1] / english_eigen[2]
english_eigen[1] / sum(english_eigen)

math_eigen <- eigen(cor(math_items))$values
math_eigen[1] / math_eigen[2]
math_eigen[1] / sum(math_eigen)

read_eigen <- eigen(cor(read_items))$values
read_eigen[1] / read_eigen[2]
read_eigen[1] / sum(read_eigen)

sci_eigen <- eigen(cor(sci_items))$values
sci_eigen[1] / sci_eigen[2]
sci_eigen[1] / sum(sci_eigen)

# CTT DIF ----
library(difR)

belin_mh <- cbind(math_items, select(belin, Grade))
names = c('5', '6')
difGMH(belin_mh, group = "Grade", focal.name = names,
       p.adjust.method = "BH")

difGenLogistic(belin_mh, group = "Grade", focal.name = names,
               p.adjust.method = "BH")
difGenLogistic(belin_mh, group = "Grade", focal.name = names,
               p.adjust.method = "BH", type = 'nudif')
difGenLogistic(belin_mh, group = "Grade", focal.name = names,
               p.adjust.method = "BH", type = 'udif')

# logistic regression ---
belin_mh <- belin_mh %>%
  mutate(total_score = rowSums(select(., starts_with("Math_AV_"))))

math_it2_log <- glm(Math_AV_2 ~ 1 + total_score + factor(Grade) + total_score:factor(Grade),
    data = belin_mh, family = binomial)
summary(math_it2_log)

#--------------------------------------------------------
# English -----------------------------------------------
# Fit multigroup IRT model grade is group.
mult_group_eng <- multipleGroup(data = english_items, model = 1, group = grade,
                            invariance = c(colnames(english_items),
                                           'free_means', 'free_var')) # 132 iterations

constrained_parameters_eng <- coef(mult_group_eng, simplify = TRUE)[[1]][[1]]
dif_add_eng <- DIF(mult_group_eng, c('a1', 'd'), scheme = 'drop',
                seq_state = .05)

# dif_out_eng <- get.dif.items(out.list = dif_add_eng, p.val = .05,
#                          parms = constrained_parameters_eng)
# dif_out_eng

# Freely estimate items with DIF.
model_eng <- '
 I = 1-40
 CONSTRAINB = (1-13, 15-20, 22, 23, 25, 28, 30-36, 39, a1),
    (1-13, 15-20, 22, 23, 25, 28, 30-36, 39, d)
'
mult_group_part_eng <- multipleGroup(data = english_items, model = model_eng,
                                     group = grade,
                                 invariance = c('free_means', 'free_var'),
                                 #constrain = constrain,
                                 technical = list(NCYCLES = 2000)) # 135 Iterations
parameters_eng <- coef(mult_group_part_eng, simplify = TRUE)

#--------------------------------------------------------
# Mathematics -----------------------------------------------
# Fit multigroup IRT model grade is group.
mult_group_math <- multipleGroup(data = math_items, model = 1, group = grade,
                            invariance = c(colnames(math_items),
                                           'free_means', 'free_var')) # 186 iterations

constrained_parameters_math <- coef(mult_group_math, simplify = TRUE)[[1]][[1]]
dif_add_math <- DIF(mult_group_math, c('a1', 'd'), scheme = 'drop',
               seq_state = .05)
dif_add_math

# dif_out_math <- get.dif.items(out.list = dif_add_math, p.val = .05,
#                          parms = constrained.parameters)
# dif_out_math

# Freely estimate items with DIF.
model_math <- '
 I = 1-30
 CONSTRAINB = (1, 4, 5, 8, 11, 13, 14, 17-18, 21-23, 25-30, a1),
    (1, 4, 5, 8, 11, 13, 14, 17-18, 21-23, 25-30, d)
'
mult_group_part_math <- multipleGroup(data = math_items, model = model_math,
                                      group = grade,
                                 invariance = c('free_means', 'free_var'),
                                 #constrain = constrain,
                                 technical = list(NCYCLES = 2000)) # 243 Iterations
parameters_math <- coef(mult_group_part_math, simplify = TRUE)

# probability ----
prob_item2 <- data.frame(rbind(
  cbind(probtrace(extract.item(mult_group_part_math, 2, group = 1), Theta = seq(-6, 6, .1)), theta = seq(-6, 6, .1), group = 'Grade 4'),
                         cbind(probtrace(extract.item(mult_group_part_math, 2, group = 2), Theta = seq(-6, 6, .1)), theta = seq(-6, 6, .1), group = 'Grade 5'),
                         cbind(probtrace(extract.item(mult_group_part_math, 2, group = 3), Theta = seq(-6, 6, .1)), theta = seq(-6, 6, .1), group = 'Grade 6')
                         )
                         )
prob_item2$P.0 <- as.numeric(as.character(prob_item2$P.0))
prob_item2$P.1 <- as.numeric(as.character(prob_item2$P.1))
prob_item2$theta <- as.numeric(as.character(prob_item2$theta))

p <- ggplot(prob_item2, aes(x = theta, y = P.1)) +
  geom_line(aes(group = group, color = group), size = 2) +
  scale_x_continuous("Aptitude", breaks = seq(-6, 6, 1)) +
  ylab("Probability Correct") +
  scale_color_grey("", start = 0) +
  theme_bw(base_size = 12)
ggsave(filename = "icc_math2.png", plot = p, dpi = 'retina', height = 4, width = 6,
       path = 'paper/figs')

# iteminformation ----
info_item2 <- data.frame(rbind(
  cbind(iteminfo(extract.item(mult_group_part_math, 2, group = 1), Theta = seq(-6, 6, .1)), theta = seq(-6, 6, .1), group = 'Grade 4'),
  cbind(iteminfo(extract.item(mult_group_part_math, 2, group = 2), Theta = seq(-6, 6, .1)), theta = seq(-6, 6, .1), group = 'Grade 5'),
  cbind(iteminfo(extract.item(mult_group_part_math, 2, group = 3), Theta = seq(-6, 6, .1)), theta = seq(-6, 6, .1), group = 'Grade 6')
)
)
info_item2$V1 <- as.numeric(as.character(info_item2$V1))
info_item2$theta <- as.numeric(as.character(info_item2$theta))

p <- ggplot(info_item2, aes(x = theta, y = V1)) +
  geom_line(aes(group = group, color = group), size = 2) +
  scale_x_continuous("Aptitude", breaks = seq(-6, 6, 1)) +
  ylab("Item Information") +
  viridis::scale_color_viridis("", discrete = TRUE, option = 'magma') +
  theme_bw(base_size = 12)
ggsave(filename = "info_math2.png", plot = p, dpi = 'retina', height = 4, width = 6,
       path = 'paper/figs')

# Model Implied test score ----
# test_scores <- data.frame(rbind(
#   cbind(expected.test(extract.group(mult_group_part_math, 1), Theta = seq(-6, 6, .1)), theta = seq(-6, 6, .1), group = 'Grade 4'),
#   cbind(expected.test(extract.group(mult_group_part_math, 2), Theta = seq(-6, 6, .1)), theta = seq(-6, 6, .1), group = 'Grade 5'),
#   cbind(expected.test(extract.group(mult_group_part_math, 3), Theta = seq(-6, 6, .1)), theta = seq(-6, 6, .1), group = 'Grade 6')
# )
# )

tmp <- plot(mult_group_part_math)

# tmp$panel.args
pltdata <- data.frame(lapply(tmp$panel.args, function(x) do.call(cbind, x))[[1]])
names(pltdata) <- c("theta", "tcc", "num")
pltdata$group <- paste0('Grade ', tmp$panel.args.common$groups)

p <- ggplot(pltdata, aes(x = theta, y = tcc)) +
  geom_line(aes(group = group, color = group), size = 2) +
  scale_x_continuous("Aptitude", breaks = seq(-6, 6, 1)) +
  scale_y_continuous("Model Implied Number Correct", breaks = seq(0, 30, 5),
                     limits = c(0, 30)) +
  scale_color_grey("") +
  theme_bw(base_size = 12)
ggsave(filename = "test_math.png", plot = p, dpi = 'retina', height = 4, width = 6,
       path = 'paper/figs')

# Using plink to get model implied test scores ----
library(plink)

parameters_math <- coef(mult_group_part_math, simplify = TRUE,
                        IRTpars = TRUE)

item_info <- bind_rows(
  cbind(group = 'Grade 4', drm(data.frame(parameters_math[[1]]$items[, 1:2]), seq(-6, 6, .1))@prob
        ),
  cbind(group = 'Grade 5', drm(data.frame(parameters_math[[2]]$items[, 1:2]), seq(-6, 6, .1))@prob
  ),
  cbind(group = 'Grade 6', drm(data.frame(parameters_math[[3]]$items[, 1:2]), seq(-6, 6, .1))@prob
  )
) %>%
  mutate(tcc = rowSums(select(., contains('item'))))

p <- ggplot(item_info, aes(x = theta1, y = tcc)) +
  geom_line(aes(group = group, color = group), size = 2) +
  scale_x_continuous("Aptitude", breaks = seq(-6, 6, 1)) +
  scale_y_continuous("Model Implied Number Correct", breaks = seq(0, 30, 5),
                     limits = c(0, 30)) +
  scale_color_grey("", start = 0) +
  theme_bw(base_size = 12)
ggsave(filename = "test_math.png", plot = p, dpi = 'retina', height = 4, width = 6,
       path = 'paper/figs')

#--------------------------------------------------------
# Reading -----------------------------------------------
# Fit multigroup IRT model grade is group.
mult_group_read <- multipleGroup(data = read_items, model = 1, group = grade,
                                 invariance = c(colnames(read_items),
                                                'free_means', 'free_var')) # 144 iterations

constrained_parameters_read <- coef(mult_group_read, simplify = TRUE)[[1]][[1]]
dif_add_read <- DIF(mult_group_read, c('a1', 'd'), scheme = 'drop',
                    seq_state = .05)
dif_add_read

# dif_out_read <- get.dif.items(out.list = dif_add_read, p.val = .05,
#                               parms = constrained.parameters)
# dif_out_read

# Freely estimate items with DIF.
model_read <- '
  I = 1-30
  CONSTRAINB = (2-18, 21, 24-28, 30, a1),
    (2-18, 21, 24-28, 30, d)
'
mult_group_part_read <- multipleGroup(data = read_items, model = model_read,
                                      group = grade,
                                      invariance = c('free_means', 'free_var'),
                                      #constrain = constrain,
                                      technical = list(NCYCLES = 2000)) # 144 Iterations
parameters_read <- coef(mult_group_part_read, simplify = TRUE)

#--------------------------------------------------------
# Science -----------------------------------------------
# Fit multigroup IRT model grade is group.
mult_group_sci <- multipleGroup(data = sci_items, model = 1, group = grade,
                                 invariance = c(colnames(sci_items),
                                                'free_means', 'free_var')) # 171 iterations

constrained_parameters_sci <- coef(mult_group_sci, simplify = TRUE)[[1]][[1]]
dif_add_sci <- DIF(mult_group_sci, c('a1', 'd'), scheme = 'drop',
                    seq_state = .05)
dif_add_sci

# dif_out_sci <- get.dif.items(out.list = dif_add_sci, p.val = .05,
#                               parms = constrained.parameters)
# dif_out_sci

# Freely estimate items with DIF.
model_sci <- '
  I = 1-28
  CONSTRAINB = (2-14, 16-21, 23-28, a1),
    (2-14, 16-21, 23-28, d)
'
mult_group_part_sci <- multipleGroup(data = sci_items, model = model_sci,
                                      group = grade,
                                      invariance = c('free_means', 'free_var'),
                                      #constrain = constrain,
                                      technical = list(NCYCLES = 2000)) # 122 Iterations
parameters_sci <- coef(mult_group_part_sci, simplify = TRUE)

# save models
save(mult_group_part_eng, mult_group_part_math, mult_group_part_read, mult_group_part_sci,
     file = 'Data/multiple_group_models.rda')

M2(mult_group_part_eng)
M2(mult_group_part_math)
M2(mult_group_part_read)
M2(mult_group_part_sci)

# Sex DIF ----
sex <- as.character(belin$ngender)

# English -----------------------------------------------
# Fit multigroup IRT model sex is group.
mult_group_eng <- multipleGroup(data = english_items, model = 1, group = sex,
                                invariance = c(colnames(english_items),
                                               'free_means', 'free_var')) # 30 iterations

constrained_parameters_eng <- coef(mult_group_eng, simplify = TRUE)[[1]][[1]]
dif_add_eng <- DIF(mult_group_eng, c('a1', 'd'), scheme = 'drop',
                   seq_state = .05)

# dif_out_eng <- get.dif.items(out.list = dif_add_eng, p.val = .05,
#                          parms = constrained_parameters_eng)
# dif_out_eng

# Freely estimate items with DIF.
model_eng <- '
I = 1-40
CONSTRAINB = (1-8, 10, 12, 14-16, 18-30, 32, 34, 36-38, 40, a1),
(1-8, 10, 12, 14-16, 18-30, 32, 34, 36-38, 40, d)
'
mult_group_part_eng <- multipleGroup(data = english_items, model = model_eng,
                                     group = sex,
                                     invariance = c('free_means', 'free_var'),
                                     #constrain = constrain,
                                     technical = list(NCYCLES = 2000)) # 38 Iterations
parameters_eng <- coef(mult_group_part_eng, simplify = TRUE)

# Mathematics -----------------------------------------------
# Fit multigroup IRT model grade is group.
mult_group_math <- multipleGroup(data = math_items, model = 1, group = sex,
                                 invariance = c(colnames(math_items),
                                                'free_means', 'free_var')) # 33 iterations

constrained_parameters_math <- coef(mult_group_math, simplify = TRUE)[[1]][[1]]
dif_add_math <- DIF(mult_group_math, c('a1', 'd'), scheme = 'drop',
                    seq_state = .05)
dif_add_math

# dif_out_math <- get.dif.items(out.list = dif_add_math, p.val = .05,
#                          parms = constrained.parameters)
# dif_out_math

# Freely estimate items with DIF.
model_math <- '
I = 1-30
CONSTRAINB = (1-8, 10-12, 16-20, 22, 23, 25-28, 30, a1),
(1-8, 10-12, 16-20, 22, 23, 25-28, 30, d)
'
mult_group_part_math <- multipleGroup(data = math_items, model = model_math,
                                      group = sex,
                                      invariance = c('free_means', 'free_var'),
                                      #constrain = constrain,
                                      technical = list(NCYCLES = 2000)) # 19 Iterations
parameters_math <- coef(mult_group_part_math, simplify = TRUE)

#--------------------------------------------------------
# Reading -----------------------------------------------
# Fit multigroup IRT model grade is group.
mult_group_read <- multipleGroup(data = read_items, model = 1, group = sex,
                                 invariance = c(colnames(read_items),
                                                'free_means', 'free_var')) # 50 iterations

constrained_parameters_read <- coef(mult_group_read, simplify = TRUE)[[1]][[1]]
dif_add_read <- DIF(mult_group_read, c('a1', 'd'), scheme = 'drop',
                    seq_state = .05)
dif_add_read

# dif_out_read <- get.dif.items(out.list = dif_add_read, p.val = .05,
#                               parms = constrained.parameters)
# dif_out_read

# Freely estimate items with DIF.
model_read <- '
  I = 1-30
  CONSTRAINB = (1, 4-9, 11-13, 15-20, 22, 23, 25-27, 29, a1),
    (1, 4-9, 11-13, 15-20, 22, 23, 25-27, 29, d)
'
mult_group_part_read <- multipleGroup(data = read_items, model = model_read,
                                      group = sex,
                                      invariance = c('free_means', 'free_var'),
                                      #constrain = constrain,
                                      technical = list(NCYCLES = 2000)) # 54 Iterations
parameters_read <- coef(mult_group_part_read, simplify = TRUE)

#--------------------------------------------------------
# Science -----------------------------------------------
# Fit multigroup IRT model grade is group.
mult_group_sci <- multipleGroup(data = sci_items, model = 1, group = sex,
                                invariance = c(colnames(sci_items),
                                               'free_mean', 'free_var')) # 27 iterations

constrained_parameters_sci <- coef(mult_group_sci, simplify = TRUE)[[1]][[1]]
dif_add_sci <- DIF(mult_group_sci, c('a1', 'd'), scheme = 'drop',
                   seq_state = .05)
dif_add_sci

# dif_out_sci <- get.dif.items(out.list = dif_add_sci, p.val = .05,
#                               parms = constrained.parameters)
# dif_out_sci

# Freely estimate items with DIF.
model_sci <- '
  I = 1-28
  CONSTRAINB = (1-3, 5, 6, 9-10, 13, 15-18, 20-21, 23-27, a1),
    (1-3, 5, 6, 9-10, 13, 15-18, 20-21, 23-27, d)
'
mult_group_part_sci <- multipleGroup(data = sci_items, model = model_sci,
                                     group = sex,
                                     invariance = c('free_mean', 'free_var'),
                                     #constrain = constrain,
                                     technical = list(NCYCLES = 2000)) # 39 Iterations
parameters_sci <- coef(mult_group_part_sci, simplify = TRUE)


require(rms)
d <- data.frame(time=1:500, death=sample(0:1, 500, TRUE))
f <- npsurv(Surv(time, death) ~ 1, data=d, conf.type='log-log')
g <- function(y) 1 - y
survplot(f, fun=g)
survplot(f, fun=g, conf='bars')


#!/usr/bin/env Rscript
#
# Calculate mean pairwise R^2 between variants in genes.
#

library(data.table)
library(dplyr)
library(dtplyr)

maf = function(g) {
    r = sum(g, na.rm=TRUE) / sum(!is.na(g))
    min(r, 1-r)
}

argv = commandArgs(trailingOnly=TRUE)
bedfile = argv[1]
genofile = argv[2]
min_maf = as.numeric(argv[3])
chunk = as.numeric(argv[4])
nchunks = as.numeric(argv[5])

genos = fread(genofile, header=TRUE, showProgress=FALSE)
mafs = apply(as.matrix(genos[, -(1:3)]), 1, maf)
genos = genos[mafs >= min_maf, ]

g = t(as.matrix(genos[, -(1:3), with=FALSE]))

genes = fread(bedfile, header=FALSE)
gene_ids = gsub('ID=(.+?);.+', '\\1', genes[[9]])
chunk_size = ceiling(nrow(genes) / nchunks)
first = (chunk - 1) * chunk_size + 1
last = chunk * chunk_size
if(last > nrow(genes)) { last = nrow(genes) }
## Note that issues with rounding to the nearest whole number mean
## that sometimes the last few chunks will be empty and cause an
## error.

result = matrix(nrow=(last-first+1), ncol=nrow(genes))
colnames(result) = gene_ids
rownames(result) = gene_ids[first:last]

k = 0
for(i in first:last) {
    for(j in 1:nrow(genes)) {
        if(!is.na(result[i-first+1, j])) {
            next
        }
        g1_vars = genos[['contig']] == genes[i][[1]] &
            genos[['pos']] >= genes[i][[4]] &
            genos[['pos']] <= genes[i][[5]]
        g2_vars = genos[['contig']] == genes[j][[1]] &
            genos[['pos']] >= genes[j][[4]] &
            genos[['pos']] <= genes[j][[5]]
        if(sum(g1_vars) && sum(g2_vars)) {
            g1 = g[, g1_vars]
            g2 = g[, g2_vars]
            r2 = round(mean(cor(g1, g2, use='pairwise.complete.obs')^2,
                            na.rm=TRUE), 4)
        } else {
            r2 = NaN
        }
        result[i-first+1, j] = r2
        k = k + 1
        if(j >= first && j <= last) {
            result[j-first+1, i] = r2
            k = k + 1
        }
        if(k %% 10000 == 0) {
            cat(k, 'genes out of', nrow(result)*ncol(result), '\n', file=stderr())
        }
    }
}

write.table(result, file=stdout(), col.names=(chunk == 1),
            row.names=TRUE, quote=FALSE, sep='\t')


data(ms_world) ## measles case data
data(contact_countries) ## mapping of countries in ESEN2 to countries in POLYMOD

## country-specific R0 scaling
data(polymod)

contact_r0 <- list()
for (country in survey_countries(polymod))
{
  m <- contact_matrix(survey=polymod, countries=country, n=100, symmetric=TRUE,
                      estimated.contact.age = "sample", sample.all.age.groups = TRUE,
                      age.limits=seq(0, 65, by=5))
  contact_r0[[country]] <- vapply(m$matrices, function(x) {
    as.numeric(eigen(x$matrix, only.values = TRUE)$values[1])
  }, 0)
}

contact_r0_means <- vapply(contact_r0, mean, 0)
ccr0 <- data.frame(country=names(contact_r0_means), contact_r0=contact_r0_means) %>%
  remove_rownames %>%
  mutate(rel_r0 = contact_r0 / mean(contact_r0))

cr0 <- tibble(country=factor(names(contact_countries)), polymod=contact_countries) %>%
    remove_rownames %>%
    left_join(ccr0 %>%
              dplyr::rename(polymod=country) %>%
              mutate(polymod=as.character(polymod)), by="polymod") %>%
    mutate(polymod=factor(polymod),
           country=countrycode(country, "country.name", "eurostat.name"))

model_adjImm <- sero_adjImm %>%
    gather(variable, immunity, ends_with("_immunity")) %>%
    separate(variable, c("model", "dump")) %>%
    mutate(model=recode_factor(model, adjusted="contact-adjusted", mean="plain"),
           country=countrycode(country, "country.name", "eurostat.name")) %>%
    select(-dump) %>%
    left_join(cr0, by=c("country")) %>%
    rename(scaled=rel_r0) %>%
    mutate(fixed=1) %>%
    gather(r0_model, rel_r0, fixed, scaled) %>%
    mutate(susceptibility=(1-immunity)*rel_r0) %>%
    select(-contact_r0, -rel_r0)

survey_years <- model_adjImm %>%
    group_by(country) %>%
    summarise(survey_yr=as.integer(max(year, na.rm=TRUE)))

ms_cases <- ms_world %>%
    tbl_df() %>%
    inner_join(survey_years, by=("country"))

horizon <- 10

horizon_col <- paste("years", horizon, sep=".")
case_col <- paste("cases", horizon, sep=".")
ms_cases %<>%
  replace_na(list(cases=0)) %>%
  mutate(!!horizon_col := if_else(year > survey_yr & year <= survey_yr + horizon, 1, 0),
         !!case_col := !!sym(horizon_col) * cases)

msw <- ms_cases %>%
    select(-year) %>%
    rename(year=survey_yr) %>%
    select(-starts_with("years.")) %>%
    gather(variable, cases, starts_with("cases.")) %>%
    separate(variable, c("dummy", "window"), sep="\\.") %>%
    mutate(window=as.integer(window)) %>%
    select(-dummy) %>%
    group_by(country, window, year) %>%
    summarise(sum.cases=sum(cases),
              max.cases=max(cases)) %>%
    rowwise %>%
    mutate(pop_df=list(wpp_age(country, year)),
           population=sum(pop_df$population)) %>%
    select(-pop_df) %>%
    ungroup %>%
    mutate(cases.per.million.per.year = signif(sum.cases / (population*window)*1e6),
           max.cases.per.million = signif(max.cases / (population)*1e6))

threshold_test <- seq(0.8, 1, by=0.01)

measure <- "cases.per.million.per.year"
measure_threshold <- 5
method <- "spearman"

corr_coeff <- function(df)
{
    corr <- cor.test(1 - df$susceptibility, log(df[[measure]]), method=method)
    correlation <- data.frame(corr[c("estimate", "p.value")])

    outbreaks <- df[[measure]] > measure_threshold
    immunity <- 1 - df$susceptibility
    correct_threshold <-
        lapply(threshold_test, function(t) {sum(outbreaks == (immunity < t))})
    correct <-
        data.frame(threshold=threshold_test, correct=unlist(correct_threshold))

    n <- nrow(df)
    return(tibble(correlation=list(correlation), correct=list(correct), n))
}

cc <- model_adjImm %>%
    left_join(msw, by=c("country", "year")) %>%
    group_by(sample, eqi, r0_model, model, vaccination, window) %>%
    nest %>%
    mutate(corr=map(data, corr_coeff)) %>%
    select(-data) %>%
    unnest(corr)

scorr <- cc %>%
    unnest(correlation) %>%
    group_by(eqi, r0_model, model, vaccination, window) %>%
    summarise(p.value=mean(p.value),
              median=median(estimate),
              min.estimate=quantile(estimate, 0.05),
              max.estimate=quantile(estimate, 0.95),
              n=n()) %>%
    ungroup() %>%
    arrange(median) %>%
    mutate_at(vars(5:ncol(.)), signif, digits=2)

## correlation summary table
opts_current$set(label = "correlations")
scorr %>%
    mutate(mean_ci=paste0(median, "~(", min.estimate, ", ", max.estimate, ")")) %>%
    arrange(model, r0_model, eqi) %>%
    select(`Immunity model`=model, `$R_0$ model`=r0_model, `Vaccination model`=vaccination, `Equivocal samples`=eqi,
           `Correlation~(90\\% CI)`=mean_ci) %>%
    kable("latex",
          escape=FALSE, linesep="", booktabs=TRUE,
          caption="Spearman's rank correlation between immunity estimated from nationwide serology and~(if contact-adjusted) contact studies on the one hand and the mean number of cases in the 10 years following the studies on the other. The model with the greatest absolute correlation is highlighted in bold.") %>%
    kable_styling(latex_options=c("hold_position")) %>%
    write("table_2.tex")

## misclassification error
smce <- cc %>%
    unnest(correct) %>%
    group_by(eqi, r0_model, model, vaccination, window, threshold) %>%
    dplyr::summarise(median=median(1-correct/n),
                     mean=mean(1-correct/n),
                     min=mean-sd(1-correct/n),
                     max=mean+sd(1-correct/n)) %>%
    ungroup

## figures for paper
p <- ggplot(msw %>%
            arrange(cases.per.million.per.year) %>%
            mutate(country=factor(country, levels=unique(country))),
            aes(x=country, y=100*cases.per.million.per.year)) +
    geom_bar(stat="identity") +
    geom_text(aes(label=scales::comma(max.cases)), position=position_dodge(width=0.9), vjust=-0.3) +
    expand_limits(y=50000) +
    theme(axis.text.x=element_text(angle = 45, vjust = 1, hjust = 1)) +
    scale_x_discrete("") +
    geom_vline(xintercept=9.5, linetype="dotted", lwd=0.7) +
    geom_hline(yintercept=500, linetype="dotted", lwd=0.7) +
    scale_y_log10("Cases per year per million",
                  breaks=10^(0:4), labels=10^((-2):2))
save_plot("figure_1.pdf", p, base_aspect_ratio = 1.9)

smce_select <- smce %>%
    filter(eqi == "positive", r0_model=="fixed", vaccination=="projected", threshold < 1)

p <- ggplot(smce_select, aes(x=threshold, y=mean, ymin=min, ymax=max)) +
    facet_grid(~model) +
    geom_point()  +
    geom_line() +
    geom_ribbon(alpha=0.25) +
    scale_x_continuous("Threshold level", label=scales::percent) +
    scale_y_continuous("Misclassification error")

save_plot("figure_2.pdf", p, base_aspect_ratio = 1.9, base_height = 3)

number_formatter <- function(x)
{
    return(as.character(if_else(x >= 10, round(x), if_else(x >= 1, round(x, 1), signif(x, 2)))))
}

esen2_adjImm <- model_adjImm %>%
    filter(eqi == "positive", vaccination=="projected") %>%
    group_by(country, model) %>%
    summarise(immunity=mean(immunity)) %>%
    mutate(immunity=signif(immunity, 2)) %>%
    spread(model, immunity)

## pretty format summary table
opts_current$set(label = "outbreaks")
msw %>%
    left_join(esen2_adjImm) %>%
    arrange(max.cases.per.million) %>%
    dplyr::select(country, sum.cases, max.cases, cases.per.million.per.year, max.cases.per.million,
           `contact-adjusted`, plain) %>%
    mutate(country=as.character(country),
           sum.cases=as.integer(sum.cases),
           max.cases=as.integer(max.cases),
           cases.per.million.per.year=formattable(cases.per.million.per.year, formatter=number_formatter),
           max.cases.per.million=formattable(max.cases.per.million, formatter=number_formatter)) %>%
    mutate_all(linebreak) %>%
    kable("latex",
          col.names=linebreak(c("Country",
                                "Total\n(10 years)",
                                "Maximum\nannual",
                                "Mean annual\n(per million)",
                                "Maximum\nannual\n(per million)",
                                "contact-\nadjusted",
                                "plain"),
                              align="c"),
          escape=FALSE, linesep="", booktabs=TRUE,
          caption="Measles cases in the 10 years following the ESEN2 serological study, and mean estimated population immunity~(contact-adjusted or not, with fixed $R_0$ and equivocal samples interpreted as positive) based on the study and adjusted for vaccination uptake.") %>%
    add_header_above(c(" ", Cases=4, Immunity=2)) %>%
    kable_styling(latex_options=c("hold_position")) %>%
    ## kable_as_image("esen2") %>%
    write("table_1.tex")


#BOX PLOTS
boxplot(mpg~cyl, data=mtcars, main='Car Mileage Data', xlab='Number of Cylinders', ylab='Miles Per Gallon')

boxplot(mpg~cyl, data=mtcars, notch=TRUE, varwidth=TRUE, col='red', main='Car Mileage Data', xlab='Number of Cylinders', ylab='Miles Per Gallon')

#BOX PLOTS | TWO CROSSED FACTORS
mtcars$cyl.f<-factor(mtcars$cyl, levels=c(4,6,8), labels=c("4","6","8")) #create factor for # of cylinders

mtcars$am.f<-factor(mtcars$am, levels=c(0,1), labels=c("auto","standard")) #create factor for transmission type

boxplot(mpg~am.f *cyl.f, data=mtcars, varwidth=TRUE, col=c("gold","darkgreen"), main="MPG Distribution by Auto Type", xlab="Auto Type") #plot