##################################################################################################################
#########  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 restricted approach for the prevalences, i.e. the calculation of the       #####
#########  prevalences takes into account only records with all z-scores valid (non-missing) for the first   #####
#########  four indicators: weight-for-age, length/height-for-age, weight-for-length/height and BMI-for-age. #####
#########  Note: this analysis provides results only for these four 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.
#############################################################################

#### 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 calulating 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])) {

		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 calulating 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$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 calulating 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.restricted <- function(FileLab="Temp",FilePath="C:\\Documents and Settings",mydf,sex,age,age.month=F,weight,lenhei,measure=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))])
   weight.x<-as.double(get(deparse(substitute(mydf)))[,deparse(substitute(weight))])
   lenhei.x<-as.double(get(deparse(substitute(mydf)))[,deparse(substitute(lenhei))])
   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,oedema.vec,sw,stringsAsFactors=F)
	names(mat)<-c("age","age.days","sex","weight","len.hei","l.h","clenhei","oedema","sw")

	mat$cbmi<-mat$weight/((lenhei.vec/100)^2)
	mat$zlen<-NULL
	mat$flen<-NULL
	mat$zwei<-NULL
	mat$fwei<-NULL
	mat$zwfl<-NULL
	mat$fwfl<-NULL
	mat$zbmi<-NULL
	mat$fbmi<-NULL

#############################################################################
###########   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)

### Weight-for-age z-score

mat<-calc.zwei(mat,weianthro)

### 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)

#### 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<-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_rc.csv",sep=""),na="",row.names = FALSE,sep=",",quote = TRUE)

cat(paste("Z-scores calculated and exported to ",FilePath,"\\",FileLab,"_z_rc.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<-mat.out[!is.na(mat.out$zlen) & !is.na(mat.out$zwei) & !is.na(mat.out$zwfl) & !is.na(mat.out$zbmi),]
if(dim(mat.out)[1]==0) stop("\n\nNo non-missing z-score values are available for calculating prevalences with the restricted approach. Program will stop!\n\n.")

##############################################
#### 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)))))

####################################################################################################################
##### Exporting matrix to 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.data.frame(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.data.frame(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)))))

####################################################################################################################
##### Exporting matrix to 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.data.frame(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.data.frame(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

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

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

write.table(matprev, file=paste(FilePath,"\\",FileLab,"_prev_rc.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_rc.csv\n",sep=""))

on.exit(options(old))

invisible()

}   #### End of function igrowup.standard


###################### analysis 0 ################
idn = read.csv(file.choose())$idn
ind = read.csv(file.choose())$ind
t.test(idn,ind, paired = TRUE)

###################### analysis 1 ################
dat=read.csv(file.choose()) # read .csv file
d=dat
head(d)

library(plyr)

d$asked_sdn = (d$asked_sdn==1)
head(d$asked_sdn)

d$asked_founders = (d$asked_founders==1)
head(d$asked_founders)

summary(d$asked_sdn)
summary(d$asked_founders)

d$asked= (d$asked_sdn | d$asked_founders)
summary(d$asked)

r=glm(asked~control, data=d, family="binomial");summary(r)
exp(coef(r))

d$social= (d$control==0)
summary(d$social)
r=glm(asked~social, data=d, family="binomial");summary(r)
exp(coef(r))
summary(d$asked)

###################### analysis 2 ################
d=read.csv(file.choose()) # read .csv file
head(d)

library(plyr)

d$asked_sdn = (d$asked_sdn==1)
head(d$asked_sdn)

d$asked_founders = (d$asked_founders==1)
head(d$asked_founders)

summary(d$asked_sdn)
summary(d$asked_founders)

d$asked= (d$asked_sdn | d$asked_founders)
summary(d$asked)

r=glm(asked~study, data=d, family="binomial");summary(r)
exp(coef(r))

summary(r)
plot(d$asked,d$study,xlab="Asking int.",ylab="Presence of collect.")
curve(predict(r,data.frame(study=x),type="resp"),add=TRUE)

###################### analysis 3 ################
d=read.csv(file.choose()) # read .csv file
head(d)

library(plyr)

d$asked = (d$asked==1)
head(d$asked)

d$accepted = (d$accepted==1)
head(d$accepted)

r=glm(accepted~study, data=d, family="binomial");summary(r)
exp(coef(r))

###################### analysis 4 ################
### Efficacy
individuals=read.csv(file.choose())$individuals
collective=read.csv(file.choose())$collective
t.test(individuals,collective, paired = FALSE)
sd(individuals)
mean(individuals)
sd(collective)
mean(collective)

###################### analysis 5 ################
f_group=read.csv(file.choose())
f_person=read.csv(file.choose())
merged = rbind(f_group, f_person)
#merged[is.na(merged)] = 0
merged=na.omit(merged)
merged$ask_collective = (merged$giver_id == 2)
merged$ask_individual = !merged$ask_collective
head(merged)
head(merged$asker_giver.reachable_max.cs)

library(ggplot2)
ggplot(merged, aes(asker_giver.reachable_max.cs, giver.all_target_max.cs)) + geom_point() + xlim(0,10) + ylim(0,10) + geom_abline(slope=1, intercept=0)
cor.test(merged$asker_giver.reachable_max.cs, merged$giver.all_target_max.cs)

l <- glm(ask_collective ~ asker_giver.reachable_max.cs, data=merged, family="binomial")
summary(l)
exp(coef(l))

l2 <- glm(ask_collective ~ giver.reachable_target_max.cs, data=merged, family="binomial")
summary(l2)
exp(coef(l2))


library(Hmisc)
par(mfrow=c(2,2))
w <- 2
for(i in 1:4) {
  if(w==1) {
    y <- exp(rnorm(20))
  } else {
    x <- rnorm(20)
    y <- rnorm(20)
    plot(x, y)
    z <- list(x=x, y=y)
  }
  for(m in c('maxdim','area'))
    {
      for(numbins in c(25,100))
        {
          u <- largest.empty(z$x, z$y, pl=TRUE,
                             height=.05*diff(range(z$x)),
                             width =.05*diff(range(z$y)),
                             method=m, numbins=numbins)
          text(u, labels=m, adj=.5)
          if(w==2) points(z)
        }
    }
}

par(mfrow=c(1,1))
set.seed(1)
x <- rnorm(1000); y <- rnorm(1000)
plot(x,y)
for(m in c('area', 'rexhaustive', 'exhaustive')) {
  cat('Method:', m, '\n')
  print(system.time(largest.empty(x, y,
                                  width=1.5, height=.5,
                                  method=m, pl=TRUE)))
}
comp <- function(a, b) {
  i <- identical(a,b)
  if(!i) print(cbind(a,b))
  i
}

for(i in 1:70) {
  cat(i,'\n')
  set.seed(i)
  n <- sample(8:800, 1)
  x <- runif(n); y <- runif(n)
  plot(x, y)
  xl <- range(pretty(x)); yl <- range(pretty(y))
  a <- largest.empty(x, y, xlim=xl, ylim=yl, width=.03, height=.03,
                     method='rexhaustive', pl=TRUE)
  b <- largest.empty(x, y, xlim=xl, ylim=yl, width=.03, height=.03,
                     method='exhaustive',  pl=TRUE)
  comp(a[Cs(x,y,area)], b[Cs(x,y,area)])
  comp(a$rect$x, b$rect$x)
  comp(a$rect$y, b$rect$y)
}

par(mfrow=c(2,2))
N <- 100; set.seed(8237)
for(i in 1:4) {
  x <- runif(N); y <- runif(100)
  plot(x, y, pch="+", xlim=c(0,1), ylim=c(0,1), col="darkgray")
  for(m in c('area', 'rexhaustive', 'exhaustive')) {
    z <- largest.empty(x, y, 0.075, 0.075, pl=TRUE, numbins=100,
                       xlim=c(0,1), ylim=c(0,1), method=m)
    cat(m, 'largest.empty Area:', z$area, '\n')
    print(cbind(z$rect$x, z$rect$y))
  }
}

if(FALSE) {
z <- Ecdf(y)
points(lr(z$x, z$y, width=1.5, height=.05, pl=0, numbins=20))

lr <- function(x, y, xlim=par('usr')[1:2], ylim=par('usr')[3:4],
               width, height, numbins=25, pl=1)
  {
    area <- 0
    xinc <- diff(xlim)/numbins
    yinc <- diff(ylim)/numbins
    i <- 1
    j <- 0
    for(xl in seq(xlim[1], xlim[2]-width, by=xinc))
      {
        for(yl in seq(ylim[1],ylim[2]-height, by=yinc))
          {
            j <- j + 1
            if(j > 500) stop()
            xr <- if(any(x >= xl & y >= yl)) min(x[x >= xl & y >= yl])
            else xlim[2]
            yu <- if(any(y >= yl & x >= xl)) min(y[y >= yl & x >= xl])
            else ylim[2]

            if(pl==1)
              {
##                Ecdf(Y)
                i <- i + 1
                if(i > 8) i <- 2
                polygon(c(xl,xr,xr,xl),c(yl,yl,yu,yu), col=i)
              }
            ar <- (yu-yl)*(xr-xl)
            if(ar > area)
              {
                area <- ar
                x1 <- xl
                x2 <- xr
                y1 <- yl
                y2 <- yu
                if(pl==2)
                  {
                    i <- i + 1
                    if(i > 8) i <- 2
                    polygon(c(x1,x2,x2,x1),c(y1,y1,y2,y2), col=i)
                  }
              }
            }
      }
    list(x=mean(c(x1,x2)), y=mean(c(y1,y2)))
  }

lr <- function(x, y, xlim=par('usr')[1:2], ylim=par('usr')[3:4],
               width, height, numbins=25, pl=0)
  {
    area <- 0
    xinc <- diff(xlim)/numbins
    yinc <- diff(ylim)/numbins
    i <- 1
    for(xl in seq(xlim[1], xlim[2]-width, by=xinc))
      {
        for(yl in seq(ylim[1],ylim[2]-height, by=yinc))
          {
            for(xr in seq(xl+width,xlim[2],by=xinc))
              {
                for(yu in seq(yl+height,ylim[2],by=yinc))
                  {
                    if(any(x >= xl & x <= xr & y >= yl & y <= yu)) break
                    if(pl==1)
                      {
                        Ecdf(Y)
                        polygon(c(xl,xr,xr,xl),c(yl,yl,yu,yu), col=2)
                      }

##                    if(!any(x >= xl & x <= xr & y >= yl & y <= yu))
                      {
                        ar <- (yu-yl)*(xr-xl)
                        if(ar > area)
                          {
                            area <- ar
                            x1 <- xl
                            x2 <- xr
                            y1 <- yl
                            y2 <- yu
                            if(pl==2)
                              {
                                i <- i + 1
                                if(i > 8) i <- 2
                                polygon(c(x1,x2,x2,x1),c(y1,y1,y2,y2), col=i)
                              }
                          }
                      }
                  }
              }
          }
      }
    list(x=mean(c(x1,x2)), y=mean(c(y1,y2)))
  }
}


library(matrixStats)
# Test that sum of all possible pattrens is 1
test_sum1<-function(vbeta_s,cmat,vlambda,HHcomposition,npower,ascertain=-1){
    nclass=ncol(HHcomposition)
    assert<-all(apply(HHcomposition,1,function(vfam){
        #mcases<-[1:nclass+nclass]
        expandmcase<-expand.grid(0:vfam[1],0:vfam[2],0:vfam[3],0:vfam[4],0:vfam[5]) # all possible infection pattern in family composition vfam
        line_iter<-c(vfam,vfam*0,1)

        issum1<-all.equal(0, logSumExp(
                sapply(1:nrow(expandmcase),function(r){
                    line_iter[1:nclass+nclass]=unlist(expandmcase[r,])
                    return(logLK_HH(vbeta_s,cmat,vlambda,matrix(line_iter,1),npower,ascertain))
                })
            )
        )

        return(issum1)
    }))
    return(assert)
}

test_nocase<-function(vbeta_s,cmat,vlambda,HHcomposition,npower,ascertain=-1){
    nclass=ncol(HHcomposition)
    assert<-all(apply(HHcomposition,1,function(HHcomp_line){
        vfam=HHcomp_line
        #mcases<-[1:nclass+nclass]
        vcases<-numeric(nclass) # all possible infection pattern in family composition vfam
        data_line<-c(vfam,vcases,1)

        iscorrect<-all.equal(sum(-vlambda*vfam),
                logLK_HH(vbeta_s,cmat,vlambda,matrix(data_line,1),npower,ascertain)
        )

        return(iscorrect)
    }))
    return(assert)
}


# Init
data_dir <- "data/2020-07-07-deep-learning-sys-rev/"
test_data_dir <- paste0(data_dir, "test/_data/")

# Libraries
library(meta)
library(dmetar)
library(metafor)
library(xlsx)
library(data.table)
library(ggplot2)
library(gridExtra)
library(dplyr)
library(ggrepel)

# Source
source("2020-07-07-deep-learning-sys-rev/dmetar.r")

# Load data
#
metacont <- read.xlsx2(paste0(test_data_dir, "metacont.xlsx"), sheetIndex=1)
metacont[] <- lapply(metacont, as.character)
metacont[,2:dim(metacont)[2]] <- lapply(metacont[,2:dim(metacont)[2]], as.numeric)
metacont <- data.table(metacont)
metacont <- metacont[Author != ""]

#
load(file = paste0(test_data_dir, "Meta_Analysis_Data.rdata"))
str(Meta_Analysis_Data)
madata <- Meta_Analysis_Data

#
load(paste0(test_data_dir, "binarydata.RData"))
str(binarydata)

#
load(paste0(test_data_dir, "mvreg_data.rda"))

# Analysis
# source: https://bookdown.org/MathiasHarrer/Doing_Meta_Analysis_in_R/fixed.html

# fixed effects
# for pre-calculated effect size
m <- metagen(TE,                      # effect size (Cohen's d or Hedges' g)
             seTE,                    # standard error of calculated effect
             data=madata,             # data.frame
             studlab=Author,          # study name
             comb.fixed = TRUE,       # fixed effect?
             comb.random = FALSE,     # random effect?
             prediction=TRUE,         # print prediction?
             sm="SMD")                # summary measure (MD=mean diff; SMD=cohen's d/ hedges' g)

m

# individual effect sizes
# number of studies included (k)
# overall effect (g) and confidence interval
# between-study heterogenity tau^2/ I^2/ Q test

# 0% to 40%: might not be important;
# 30% to 60%: may represent moderate heterogeneity*;
# 50% to 90%: may represent substantial heterogeneity*;
# 75% to 100%: considerable heterogeneity*.
# source: https://tinyurl.com/q-test-1

# for raw data
m.raw <- metacont(Ne,    # column name for number of participants in experimental/ intervention group
                  Me,    # column name for mean of experimental/ intervention group
                  Se,    # column name for standard deviation of experimental/ intervention group
                  Nc,    # column name for number of participants in control group
                  Mc,    # column name for mean of control group
                  Sc,    # column name for standard deviation of control group
                  data=metacont,
                  studlab=Author,
                  comb.fixed = TRUE,
                  comb.random = FALSE,
                  prediction=TRUE,
                  sm="SMD")

m.raw

# random effects

# pre-calculated effect sizes

m.hksj <- metagen(TE,
                  seTE,
                  data = madata,
                  studlab = paste(Author),
                  comb.fixed = FALSE,
                  comb.random = TRUE,
                  method.tau = "SJ",   # method to calculate tau. Most popular HKSJ
                  hakn = TRUE,
                  prediction = TRUE,
                  sm = "SMD")
m.hksj
find.outliers(m.hksj)

fo <- find.outliers(m.hksj)
# meta::forest(fo, col.predict = "blue")

inf.analysis <- InfluenceAnalysis(x = m.hksj,
                                  random = TRUE)
summary(inf.analysis)
dmetar:::plot.InfluenceAnalysis(inf.analysis, "influence")
dmetar:::plot.InfluenceAnalysis(inf.analysis, "baujat")
dmetar:::plot.InfluenceAnalysis(inf.analysis, "es")
dmetar:::plot.InfluenceAnalysis(inf.analysis, "is")

# raw data

m.hksj.raw <- metacont(Ne,
                       Me,
                       Se,
                       Nc,
                       Mc,
                       Sc,
                       data = metacont,
                       studlab = paste(Author),
                       comb.fixed = FALSE,
                       comb.random = TRUE,
                       method.tau = "SJ",
                       hakn = TRUE,
                       prediction = TRUE,
                       sm = "SMD")
m.hksj.raw
forest(m.hksj.raw)

# binary data

str(binarydata)
m.bin <- metabin(Ee,
                 Ne,
                 Ec,
                 Nc,
                 data = binarydata,
                 studlab = paste(Author),
                 comb.fixed = FALSE,
                 comb.random = TRUE,
                 method.tau = "SJ",
                 hakn = TRUE,
                 prediction = TRUE,
                 incr = 0.1,
                 sm = "RR")
m.bin

labbe.metabin(x = m.bin,
              bg = "blue",
              studlab = TRUE,
              col.random = "red")

# Multiple regression

mvreg.data$continent <- factor(mvreg.data$continent)
cor(mvreg.data[,3:5])

model1 <- rma(yi = yi,             # effect size
              sei = sei,           # standard error of effect size
              data = mvreg.data,   # data
              method = "ML",       # tau-squared method. ML or REML advised for multiple reg
              mods = ~ quality,    # regression variables
              test = "knha")       # regression coefficient tests
model1

model2 <- rma(yi = yi,
              sei = sei,
              data = mvreg.data,
              method = "ML",
              mods = ~ quality + reputation,
              test="knha")
model2

anova(model1, model2)

permutest(model2)

interaction.model <- rma(yi=yi,
                         sei=sei,
                         data=mvreg.data,
                         method = "REML",
                         mods = ~ pubyear*continent,
                         test="knha")
interaction.model

multimodel.inference(TE = "yi",
                     seTE = "sei",
                     data = mvreg.data,
                     predictors = c("pubyear", "quality", "reputation", "continent"),
                     interaction = FALSE)

# Checking for publication biases

funnel(m.hksj,xlab = "Hedges' g",studlab = TRUE)
funnel(m.hksj, xlab="Hedges' g",
       contour = c(.95,.975,.99),
       col.contour=c("darkblue","blue","lightblue")) +
    legend(1.4, 0, c("p < 0.05", "p<0.025", "< 0.01"), bty = "n",
           fill=c("darkblue","blue","lightblue"))
eggers.test(x = m.hksj)
trimfill(m.hksj)
pcurve(m.hksj)
pcurve(m.hksj, effect.estimation = TRUE, N = N.m.hksj, dmin = 0, dmax = 1)


classify_data = classify_mature(table, varNames = c("cm", "total"),
                                varSex = "sex", selectSex = NULL, method = "ld")
par(mfrow = c(2,2))
plot(classify_data)

plot(classify_data, xlab = "cm (mm.)", ylab = "total (mm)", legendPlot = FALSE)
legend("Centimetros", "%", bty = "n")

plot(classify_data, xlab = "cm (mm.)", ylab = "total (mm)",
     col = c(2, 3), pch = c(5, 6), legendPlot = TRUE)

plot(classify_data, xlab = "cm (mm.)", ylab = "total (mm)",
     col = c(2, 3), pch = c(5, 6), lty_lines = c(1, 2), lwd_lines = c(1, 3),
     cex = c(1, 3), main = "Classification")

my_ogive_fq = morph_mature(classify_data, method = "fq", niter = 1000)

print(my_ogive_fq)

my_ogive_bayes = morph_mature(classify_data, method = "bayes", niter = 1000)

print(my_ogive_bayes)

par(mfrow = c(2,2))
plot(my_ogive_bayes, xlab = "cm (mm.)", ylab = "L50", col = c("blue", "red"))

plot(my_ogive_fq, xlab = "cm (mm.)", ylab = "L50", col = c("blue", "red"), onlyOgive = TRUE)


library(quantmod)

rm(list = ls())

stock <- na.omit(get(getSymbols('AAPL')))

pl <- setNames( rep( 0, length(Cl(stock)) ), time(stock) ) # [p]rofit and [l]ose vector

hi_max <- lag(runMax(Hi(stock), 3))
lo_min <- lag(runMin(Lo(stock), 3))

flag <- FALSE
for (m in 4:(nrow(stock)-1)) {
    if ( flag == FALSE && Cl(stock)[m] > hi_max[m] ) {
        long <- as.numeric( Op(stock)[m+1] )
        flag <- TRUE
    }
    else if ( flag == TRUE && Cl(stock)[m] < lo_min[m] ) {
        pl[m] <- as.numeric( Op(stock)[m+1] ) - long
        flag <- FALSE
    }
}

plot( cumsum(pl), type='l', col='red', lwd=2 )


#' Function that creates a skewed sinusoidal growth rate (GR) curve
#' from a list of parameters
#'
#' Takes the specified parameters for amplitude, period, phase, average value
#' and skewness factor as well as the number of years specified and the time
#' interval. It then creates a skewed sinusoid based on the boundary conditions.
#' The skewness factor (\code{G_skw}) determines whether the sinusoid is skewed
#' towards the front (\code{G_skw < 50}) or the back of the annual peak in
#' growth rate (\code{G_skw > 50}).
#' Used as intermediate step during iterative modeling.
#'
#' @param G_par List of four parameters describing (in order) amplitude
#' (\code{G_amp}; in micrometer/day), period (\code{G_per}; in days), phase
#' (\code{G_pha} in day of the year), average growth rate (\code{G_av}; in
#' micrometer/day) and the skewness factor (\code{G_skw} between 0 and 100)
#' @param years Length of the preferred sinusoid in number of years (defaults
#' to 1)
#' @param t_int Time interval of sinusoidal record (in days)
#' @return A matrix containing columns for time (in days) and GR
#' (in micrometer/day)
#' @references
#'   \doi{10.1016/j.palaeo.2017.09.034}
#' @examples
#' # Set parameters
#' G_amp <- 20
#' G_per <- 365
#' G_pha <- 100
#' G_av <- 15
#' G_skw <- 70
#' G_par <- c(G_amp, G_per, G_pha, G_av, G_skw)
#' # Run GR model function
#' GR <- growth_rate_curve(G_par, 1, 1)
#' @export
growth_rate_curve <- function(G_par, # Function to create growth rate as function of time based on parameters
    years = 1, # Default number of years of the record = 1
    t_int = 1 # Default time interval = 1 day
    ){

    G_amp <- G_par[1] # Seasonal range in Growth rate (um/d)
    G_per <- G_par[2] # Period of growth rate seasonality (days)
    G_pha <- G_par[3] # Timing of peak in growth rate (day of the year)
    G_av <- G_par[4] # Annual average growth rate (um/d)
    G_skw <- G_par[5] # Skewness factor in growth rate sinusoid (-)

    t <- seq(0, G_per, t_int) # Define time axis based on the number of days in a year and the time interval

    GR <- rep(NA, length(t)) # Create empty growth rate vector
    # Build GR vector piece by piece based on parameters
    # Check if t is between the time of maximum growth and the subsequent time of minimum growth but before the peak, add one period's length if it is
    if(length(t[(((t - G_pha) %% G_per) < (G_per * (100 - G_skw) / 100)) & (t < G_pha)]) > 0){ # Catch "replacement has length zero" errors
        GR[(((t - G_pha) %% G_per) < (G_per * (100 - G_skw) / 100)) & (t < G_pha)] <- G_av + G_amp/2 * sin(2 * pi * (t[(((t - G_pha) %% G_per) < (G_per * (100 - G_skw) / 100)) & (t < G_pha)] + G_per - G_pha + (G_per * (100 - G_skw) / 50)/4) / (G_per * (100 - G_skw) / 50))
    }
    # Check if t is between the time of maximum growth and the subsequent time of minimum growth but still after the peak
    if(length(t[(((t - G_pha) %% G_per) < (G_per * (100 - G_skw) / 100)) & (t >= G_pha)]) > 0){ # Catch "replacement has length zero" errors
        GR[(((t - G_pha) %% G_per) < (G_per * (100 - G_skw) / 100)) & (t >= G_pha)] <- G_av + G_amp/2 * sin(2 * pi * (t[(((t - G_pha) %% G_per) < (G_per * (100 - G_skw) / 100)) & (t >= G_pha)] - G_pha + (G_per * (100 - G_skw) / 50)/4) / (G_per * (100 - G_skw) / 50))
    }
    # Check if t is between the time of maximum growth and the previous time of minimum growth but still before the peak, subtract one period's length if it is
    if(length(t[(((t - G_pha) %% G_per) >= (G_per * (100 - G_skw) / 100)) & (t > G_pha)]) > 0){
        GR[(((t - G_pha) %% G_per) >= (G_per * (100 - G_skw) / 100)) & (t > G_pha)] <- G_av + G_amp/2 * sin(2 * pi * (t[(((t - G_pha) %% G_per) >= (G_per * (100 - G_skw) / 100)) & (t > G_pha)] - G_per - G_pha + (G_per * G_skw / 50)/4) / (G_per * G_skw / 50))
    }
    if(length(t[(((t - G_pha) %% G_per) >= (G_per * (100 - G_skw) / 100)) & (t <= G_pha)]) > 0){
        GR[(((t - G_pha) %% G_per) >= (G_per * (100 - G_skw) / 100)) & (t <= G_pha)] <- G_av + G_amp/2 * sin(2 * pi * (t[(((t - G_pha) %% G_per) >= (G_per * (100 - G_skw) / 100)) & (t <= G_pha)] - G_pha + (G_per * G_skw / 50)/4) / (G_per * G_skw / 50))
    }
    # Replace negative growth rates with zeroes
    GR[GR < 0] <- 0
    # Multiply t and GR with number of years
    if(years > 1){
        t <- c(t, rep(t[-1], years - 1) + rep(seq(365, 365 * (years - 1), 365), each = 365))
        GR <- c(GR, rep(GR[-1], years - 1))
    }
    # Collate results and export
    res <- cbind(t, GR)
    return(res)
}


# Putting it all together
library(ggplot2)

set.seed(12345666)
Time = rep(c(0.5,1,2,4,8,12,18,24))
N = 6
DOSE = 100*exp(0.4*rnorm(N))
ID = sort(rep(seq(1,N,1),length(Time)))
Time <- rep(Time, N)
K1 = 0.1*exp(0.2*rnorm(N))
K2 = 0.8*exp(0.4*rnorm(N))

my.data <- data.frame(ID=seq(1,N,1), K1, K2, DOSE)
my.data <- merge(my.data, data.frame(Time = Time, ID=ID))

my.data$Concentration = my.data$DOSE*(my.data$K2*my.data$K1/(my.data$K2-my.data$K1))*(exp(-my.data$K1*(my.data$Time)) - exp(-my.data$K2*(my.data$Time)) )*exp(0.3*rnorm(length(my.data$Time))) + 0.2*rnorm(length(my.data$Time))

my.data2 <- data.frame(my.data, ID2 = 1)
for(id in 2:N){
  my.data2 <- rbind(my.data2, data.frame(my.data, ID2 = id))
}

temp <- my.data2$ID
my.data2$ID = my.data2$ID2
my.data2$ID2 <- temp

gg <- ggplot(data = my.data, aes(x = Time, y = Concentration)) + theme_gray(base_size = 14)
gg <- gg + geom_line(aes(group = ID, color = factor(ID), linetype = factor(ID)), size = 1)
gg <- gg + geom_point(aes(color = factor(ID), shape = factor(ID)), size = 4)
gg <- gg + scale_y_log10() + ggColor()
gg <- gg + theme(  legend.position="none"  )
gg

ggsave(file="Plot41a.png", width = 80, height = 80, units = "mm", dpi = 300)

gg <- ggplot(data = my.data, aes(x = Time, y = Concentration)) + theme_minimal(base_size = 14)
gg <- gg + geom_line(aes(group = ID, linetype = factor(ID)), size = 1)
gg <- gg + scale_y_log10() + ggColor()+ xlab("Time (hours)") + ylab("Concentration (ng/mL)")
gg <- gg + theme(panel.grid.minor=element_blank(),        legend.position="none"  )
gg

ggsave(file="Plot41b.png", width = 80, height = 80, units = "mm", dpi = 300)

gg <- ggplot(data = my.data2, aes(x = Time, y = Concentration)) + theme_minimal(base_size = 14)
gg <- gg + geom_line(aes(group = ID2), size = 1, color = rgb(0.75,0.75,0.75)) + scale_y_log10() + ggColor()
gg <- gg + geom_line(data = my.data, aes(x = Time, y = Concentration,group = ID), size = 1)+
  scale_x_continuous(breaks = c(12,24)) + xlab("Time (hours)") + ylab("Concentration (ng/mL)")
gg <- gg + theme(panel.grid.minor=element_blank(),
                 legend.position="none",
                 strip.text.x = element_blank()
)
gg + facet_wrap(~ID)

ggsave(file="Plot41c.png", width = 80, height = 80, units = "mm", dpi = 300)


MRHCA<-function(cor_M,MR_E,step_size0=50,p_sig0=0.05,Hit_score_cutoff=100)
{
	  cor_c<-cor_M
        diag(cor_c)<-0
        #cor_c<-abs(cor_c)
        cor_r_rank1<-apply(cor_c,1,rank)
        cor_r_rank2<-t(apply(cor_c,2,rank))
        cor_r_rank1<-nrow(cor_r_rank1)-cor_r_rank1+1
        cor_r_rank2<-nrow(cor_r_rank2)-cor_r_rank2+1
        MR_M<-cor_r_rank1*cor_r_rank2
	  ddd<-MR_E
        null_growth_rate<-c()
        step_size<-step_size0   #parameter
	  print("Generating Empirical Null Growth Rate")
        for(i in 1:nrow(ddd))
        {
               x0<-sqrt(sort(ddd[i,]))
               null_growth_rate<-rbind(null_growth_rate,calculate_growth_rate(x0,step=step_size))
        }
	  print("Hub Identification")
        hub_info_all<-c()
        sig_N<-ncol(null_growth_rate)   #parameter
        p_sig<-p_sig0   #parameter
        hub_sig_cut<-Hit_score_cutoff      #parameter
        for(i in 1:nrow(MR_M))
        {
                x0<-sqrt(sort(MR_M[i,]))
                tg_growth_rate<-calculate_growth_rate(x0,step=50)
                is_sig<-growth_rate_significance(tg_growth_rate,null_growth_rate,sig_N)<p_sig
                S_all<-growth_rate_scoring(is_sig)
                cluster_bound<-0
                if_hub<-0
                if((max(S_all)>hub_sig_cut)&(sum(tg_growth_rate[1:50]>0.7)==0))
                {
                        cluster_bound<-max(which(S_all==max(S_all)))
                        if_hub<-1
                }
                hub_info<-c(if_hub,cluster_bound)
                hub_info_all<-rbind(hub_info_all,hub_info)
        }
        rownames(hub_info_all)<-rownames(MR_M)
        return(list(hub_info_all,MR_M))
}

Empirical_null_distribution_MR<-function(data,Rounds=1000)
{
        N<-nrow(data)
        aaa<-runif(N*Rounds,0,1)
        bbb1<-rep(0,length(aaa))
        bbb2<-rep(0,length(aaa))
        for(i in 1:length(aaa))
        {
                bbb1[i]<-rbinom(1,N-1,aaa[i])
                bbb2[i]<-rbinom(1,N-1,aaa[i])
        }
        ccc<-(bbb1+1)*(bbb2+1)
        ddd<-matrix(ccc,Rounds,N)
        return(ddd)
}

growth_rate_scoring<-function(is_sig,up_score=1,down_score=-2,delete_top=10)
{
	S<-0
	S_all<-c()
	for(i in 1:length(is_sig))
	{
		if(i<delete_top)
		{
			S<-S+0
			S_all<-c(S_all,S)
		}
		else
		{
			if(is_sig[i]==1)
			{
				S<-S+up_score
				S_all<-c(S_all,S)
			}
			if(is_sig[i]==0)
			{
				S<-S+down_score
				S_all<-c(S_all,S)
			}
		}
	}
	return(S_all)
}

growth_rate_significance<-function(tg_growth_rate,null_growth_rate,sig_N)
{
	growth_rate_sig<-rep(0,sig_N)
	for(i in 1:sig_N)
	{
		growth_rate_sig[i]<-sum(tg_growth_rate[i]>=null_growth_rate[,i])
	}
	growth_rate_sig<-growth_rate_sig/nrow(null_growth_rate)
	return(growth_rate_sig)
}

calculate_growth_rate<-function(x0,step=20)
{
	gr_all<-rep(0,length(x0))
	for(i in 1:length(x0))
	{
		sid<-max(1,i-step)
		eid<-min(length(x0),i+step)
		tg_id<-c(sid:eid)
		l<-eid-sid+1
		gr_all[i]<-(x0[eid]-x0[sid])/l
	}
	return(gr_all)
}

calculate_MR<-function(tg_id,Rank_index)
{
N<-nrow(Rank_index)
K<-ncol(Rank_index)
MR_result<-rep(0,N)
for(i in 1:N)
{
R1<-K+1
R2<-K+1
if(sum(tg_id==Rank_index[i,])>0)
{
R1<-which(Rank_index[i,]==tg_id)
}
if(sum(i==Rank_index[tg_id,])>0)
{
R2<-which(Rank_index[tg_id,]==i)
}
MR_result[i]<-R1*R2
#if(i%%1000==1)
#{
#print(i)
#}
}
MR_result[tg_id]<-K^2
return(MR_result)
}

MRHCA_small_hub_identificaiton<-function(MRHCA_output,data,MR_E)
{
hubs_small_result<-MRHCA_output
data_c<-data
MR_M<-hubs_small_result[[2]]
MR_M0<-MR_M
for(i in 1:nrow(MR_M0))
{
	MR_M0[i,]<-sort(MR_M0[i,])
}
############
MR_E0<-MR_E
for(i in 1:nrow(MR_E0))
{
	MR_E0[i,]<-sort(MR_E0[i,])
}
#############
ccc<-hubs_small_result[[1]]
tg_cut_id<-100
tg_hubs<-c()
if(sum(ccc[,1]==1)>0)
{
	tg_cut_id<-max(min(ccc[which(ccc[,1]==1),2]),100)
	tg_hubs<-names(which(hubs_small_result[[1]][,1]==1))
}
print("Cut Smallest Module Size!!!\n")
print(tg_cut_id)
MR_M_c<-sqrt(MR_M0[,1:tg_cut_id])
MR_E_c<-sqrt(MR_E0[,1:tg_cut_id])
p_cut<-0.01
stat_MR<-MR_M_c*0
for(i in 1:ncol(stat_MR))
{
	stat_MR[,i]<-MR_M_c[,i]<quantile(MR_E_c[,i],p_cut)
}
cumsum_MR<-stat_MR*0
for(i in 1:nrow(stat_MR))
{
	cumsum_MR[i,]<-cumsum(stat_MR[i,])
}

for(i in 1:nrow(cumsum_MR))
{
	if(length(which(cumsum_MR[i,]!=0))==0)
	{
		fff<-rep(1,length(cumsum_MR[i,]))
	}
	else
	{
		tg_ids<-min(which(cumsum_MR[i,]!=0))
		fff<-c(rep(1,tg_ids-1),1:(length(cumsum_MR[i,])-tg_ids+1))
	}
	cumsum_MR[i,]<-cumsum_MR[i,]/fff
}

#intersect(names(which(apply(cumsum_MR>0.8,1,sum)>5)),tg_hubs)
tg_id_ccc<-setdiff(names(which(apply(cumsum_MR>0.8,1,sum)>2)),tg_hubs)
small_hub_info<-c()
small_hubs<-c()
small_hub_info_selected<-c()
if(length(tg_id_ccc)>0)
{
for(i in 1:length(tg_id_ccc))
{
	x0<-sqrt(sort(MR_M[tg_id_ccc[i],]))
	tg_growth_rate<-calculate_growth_rate(x0,step=10)
	ccc<-cumsum(tg_growth_rate<0.5)-cumsum(tg_growth_rate>1)*100-cumsum(tg_growth_rate>0.85)*5
	ddd<-ccc/c(1:length(ccc))
	if((sum(ccc[1:10]<0)==0)&(max(ccc)>0.8))
	{
		if(sum(ddd<0)>0)
		{
			small_hub_info<-rbind(small_hub_info,c(1,min(which(ddd<0))))
		}
		else
		{
			small_hub_info<-rbind(small_hub_info,c(1,ncol(MR_M)))
		}
		small_hubs<-c(small_hubs,tg_id_ccc[i])
	}
}
rownames(small_hub_info)<-small_hubs
small_hub_info_selected<-small_hub_info[which(small_hub_info[,2]<=300),]
if(length(which(small_hub_info[,2]<=300))==1)
{
	tg_id<-rownames(small_hub_info)[which(small_hub_info[,2]<=300)]
	small_hub_info_selected<-t(as.matrix(small_hub_info_selected))
	rownames(small_hub_info_selected)<-tg_id
}
print("small hub selected: ")
print(length(which(small_hub_info[,2]<=300)))
print("small hub removed: ")
print(length(which(small_hub_info[,2]>300)))
#hist(small_hub_info[,2],breaks=100)
}
return(small_hub_info_selected)
}

########################
#Fast version functions
########################

Empirical_null_distribution_MR_F<-function(data,K=1000,Rounds=1000)
{
        N<-nrow(data)
	  M<-K
        aaa<-runif(N*Rounds,0,1)
        bbb1<-rep(0,length(aaa))
        bbb2<-rep(0,length(aaa))
        for(i in 1:length(aaa))
        {
                bbb1[i]<-rbinom(1,N-1,aaa[i])
                bbb2[i]<-rbinom(1,N-1,aaa[i])
        }
        bbb1[which(bbb1>(M))]<-M
        bbb2[which(bbb2>(M))]<-M
        ccc<-(bbb1+1)*(bbb2+1)
        ddd<-matrix(ccc,Rounds,N)
        return(ddd)
}

Compute_rank_index<-function(data,K)
{
	Rank_index<-c()
	for(i in 1:nrow(data))
	{
		cor_cc<-cor(t(data),data[i,])
		cor_cc[i]<-0
		Rank_index<-rbind(Rank_index,order(-abs(cor_cc))[1:K])
	}
	rownames(Rank_index)<-rownames(data)
	return(Rank_index)
}

MRHCA_fast_version<-function(Rank_index,MR_E,K=500,step_size0=50,p_sig0=0.05,Hit_score_cutoff=100,TN_p=1)
{
	sig_N0<-floor(K*0.75)
	hub_sig_cut0<-Hit_score_cutoff
	MR_id<-1:nrow(Rank_index)
	if(TN_p<1)
	{
		MR_id<-names(sort(table(Rank_index),decreasing=T))
		MR_id<-as.numeric(MR_id)
	}
	MR_EM<-c()
	TN<-floor(nrow(Rank_index)*TN_p)
	rnames<-c()
	print("Compute MR")
	for(i in 1:TN)
	{
		tg_id<-MR_id[i]
		a1<-calculate_MR(tg_id,Rank_index)
		rnames<-c(rnames,tg_id)
		MR_EM<-rbind(MR_EM,a1)
	}
	rownames(MR_EM)<-rnames
	colnames(MR_EM)<-c(1:length(a1))
	#print("Compute Empirical Null Distribution")
	####calculate null distribution of MR
	ddd2<-MR_E
	####calculate null distribution of MR growth rate
	null_growth_rate<-c()
	step_size<-step_size0	#parameter
	for(i in 1:nrow(ddd2))
	{
		x0<-sqrt(sort(ddd2[i,]))
		null_growth_rate<-rbind(null_growth_rate,calculate_growth_rate(x0,step=step_size))
	}
	print("Hub Identification")
	hub_info_all<-c()
	sig_N<-sig_N0	#parameter
	p_sig<-p_sig0	#parameter
	hub_sig_cut<-hub_sig_cut0	#parameter
	for(i in 1:nrow(MR_EM))
	{
		x0<-sqrt(sort(MR_EM[i,]))
		#x0<-sqrt(sort(calculate_MR(i,Rank_index)))
		tg_growth_rate<-calculate_growth_rate(x0,step=50)
		is_sig<-growth_rate_significance(tg_growth_rate,null_growth_rate,sig_N)<p_sig
		S_all<-growth_rate_scoring(is_sig)
		cluster_bound<-0
		if_hub<-0
		if((max(S_all)>hub_sig_cut)&(sum(tg_growth_rate[1:50]>0.7)==0))
		{
			cluster_bound<-max(which(S_all==max(S_all)))
			if_hub<-1
		}
		hub_info<-c(if_hub,cluster_bound,0)
		if(cluster_bound==sig_N)
		{
			hub_info[3]<-max(which(tg_growth_rate!=0))
		}
		hub_info_all<-rbind(hub_info_all,hub_info)
	}
	hub_info_all[which(hub_info_all[,2]==sig_N),2]<-0
	rownames(hub_info_all)<-rownames(MR_EM)
	return(list(hub_info_all,MR_EM))
}


#Parse in arguments to the function
sum_a_b <-function(a,b) {
  result <- a + b #calculation
  return (result) #return the result
}
sum_a_b(10,5)#Arguments for the function

#Parse in arguments to the function
pow <- function(a,b){
  result <- a^b#calculation
  return(result)#return the result
}
pow(10,3)#Arguments for the function


cocktailsort <- function(x)
{
   lenx <- length(x)
   repeat
   {
      swapped <- FALSE
      for(i in 1:(lenx-1))
      {
         if(x[i] > x[i+1])
         {
            temp <- x[i]
            x[i] <- x[i+1]
            x[i+1] <- temp
            swapped <- TRUE
         }
      }
      if(!swapped) break

      swapped <- FALSE
      for(i in (lenx-1):1)
      {
         if(x[i] > x[i+1])
         {
            temp <- x[i]
            x[i] <- x[i+1]
            x[i+1] <- temp
            swapped <- TRUE
         }
      }
      if(!swapped) break
   }
   x
}

print(cocktailsort(c(5, -1, 101, -4, 0, 1, 8,    6,  2, 3)))


#!/usr/bin/Rscript

## Author: David Eccles (gringer), 2009 <programming@gringer.org>

## error.r -- generates error plot (false/true positive/negative) for a diagnostic test

usage <- function(){
  cat("usage: ./error.r",
      "<file> <Case/Control Split location> [-flip]]\n");
  cat("Other options:\n");
  cat("-help          : show only this screen\n");
  cat("-flip          : invert positive/negative classification\n");
  cat("-vline <float> : place a vertical line at <location>\n");
  cat("-hline <float> : place a horizontal line at <location>\n");
  cat("-batch         : batch mode output\n");
  cat("-header        : display batch mode header\n");
  cat("-roc           : ROC analysis, with AUC calculation\n");
}

infile.df <- FALSE;
splitLoc <- FALSE;
flip <- FALSE;
doROC <- FALSE;
batchMode <- FALSE;
batchHeader <- FALSE;

vlineLocs <- NULL;
hlineLocs <- NULL;

argLoc <- 1;
while(!is.na(commandArgs(TRUE)[argLoc])){
  if(file.exists(commandArgs(TRUE)[argLoc])){ # file existence check
    if(infile.df == FALSE){
      infile.df <- read.table(commandArgs(TRUE)[argLoc], row.names = 1);
    } else{
      cat("Error: More than one input file specified\n");
      usage();
      quit(save = "no", status=1);
    }
  } else {
    if(length(grep("^[0-9]+$",commandArgs(TRUE)[argLoc])) > 0){
      splitLoc <- as.numeric(commandArgs(TRUE)[argLoc]);
    }
    if(commandArgs(TRUE)[argLoc] == "-flip"){
      flip <- TRUE;
    }
    if(commandArgs(TRUE)[argLoc] == "-roc"){
      doROC <- TRUE;
    }
    if(commandArgs(TRUE)[argLoc] == "-batch"){
      batchMode <- TRUE;
    }
    if(commandArgs(TRUE)[argLoc] == "-header"){
      batchHeader <- TRUE;
      batchMode <- TRUE;
    }
    if(commandArgs(TRUE)[argLoc] == "-vline"){
      vlineLocs <- c(vlineLocs, as.numeric(commandArgs(TRUE)[argLoc+1]));
      argLoc <- argLoc + 1;
    }
    if(commandArgs(TRUE)[argLoc] == "-hline"){
      hlineLocs <- c(hlineLocs, as.numeric(commandArgs(TRUE)[argLoc+1]));
      argLoc <- argLoc + 1;
    }
    if(commandArgs(TRUE)[argLoc] == "-help"){
      usage();
      quit(save = "no", status=0);
    }
  }
  argLoc <- argLoc + 1;
}

if((infile.df == FALSE) || (splitLoc == FALSE)){
  usage();
  quit(save = "no", status=2);
}

if(flip){
  infile.df$V2 <- 1 - infile.df$V2;
}

error.cutoff <- seq(0,1,length.out = 101);
if(doROC){
  error.cutoff <- c(0,sort(unique(infile.df[,"V2"])),1);
}
error.res <- data.frame(Cutoff = error.cutoff,
                        TP = tapply(error.cutoff, 1:length(error.cutoff),
                          function(x){length(which(infile.df[(1:splitLoc),"V2"] >= x))}) /
                        length(infile.df[(1:splitLoc),"V2"]),
                        FP = tapply(error.cutoff, 1:length(error.cutoff),
                          function(x){length(which(infile.df[-(1:splitLoc),"V2"] >= x))}) /
                        length(infile.df[-(1:splitLoc),"V2"]),
                        TN = tapply(error.cutoff, 1:length(error.cutoff),
                          function(x){length(which(infile.df[-(1:splitLoc),"V2"] < x))}) /
                        length(infile.df[-(1:splitLoc),"V2"]),
                        FN = tapply(error.cutoff, 1:length(error.cutoff),
                          function(x){length(which(infile.df[(1:splitLoc),"V2"] < x))}) /
                        length(infile.df[(1:splitLoc),"V2"]));

#error.res$PPV = error.res$TP / (error.res$TP + error.res$FP);
#error.res$NPV = error.res$TN / (error.res$TN + error.res$FN);

pdf("output_error.pdf",width = 8, height = 8);
if(doROC){
  plot(0.5,0.5,xlim = c(0,1), ylim = c(0,1), type = "n",
       xlab = "False Positive Rate (1 - specificity)",
       ylab = "True Positive Rate (sensitivity)");
  tpr <- error.res$TP / (error.res$TP+error.res$FN); # sensitivity
  fpr <- error.res$FP / (error.res$FP+error.res$TN); # 1 - specificity
  plotAUC <- -1 * sum((tpr[-1] - (diff(tpr)/2)) * diff(fpr));
  if(plotAUC < 0.5){
    tpr = 1 - tpr;
    fpr = 1 - fpr;
    plotAUC = 1 - plotAUC;
  }
  cornerDistance <- sqrt((1-tpr)^2 + (0-fpr)^2);
  closestPoint <- which(cornerDistance == min(cornerDistance))[1];
  points(fpr, tpr, type = "l", col = "black");
  points(fpr[closestPoint], tpr[closestPoint],
         type = "p", cex = 2, col = "red");
  ## points(fpr[round(length(fpr)/4)], tpr[round(length(tpr)/4)],
  ##        type = "p", cex = 2, col = "red");
  ## points(fpr[round(1 + length(fpr)/2)], tpr[round(1 + length(tpr)/2)],
  ##        type = "p", cex = 2, col = "red");
  ## points(fpr[round(length(fpr)*3/4)], tpr[round(length(tpr)*3/4)],
  ##        type = "p", cex = 2, col = "red");
  abline(h = hlineLocs, v = vlineLocs);
  ## AUC, assumes curve is broken into trapezoids, with tpr[1] being highest point on curve
  ## text(fpr[round(1 + length(fpr)/2)], tpr[round(1 + length(tpr)/2)],
  ##      paste("Median value = ",error.cutoff[round(1 + length(fpr)/2)]));
  text(fpr[closestPoint], tpr[closestPoint], round(error.cutoff[closestPoint],3), adj = c(-0.2,2));
  ## text(fpr[round(length(fpr)/4)], tpr[round(length(tpr)/4)], round(error.cutoff[round(length(tpr)/4)],3), adj = c(-0.2,2));
  ## text(fpr[round(1+length(fpr)/2)], tpr[round(1+length(tpr)/2)], round(error.cutoff[round(1+length(tpr)/2)],3), adj = c(-0.2,2));
  ## text(fpr[round(length(fpr)*3/4)], tpr[round(length(tpr)*3/4)], round(error.cutoff[round(length(tpr)*3/4)],3), adj = c(-0.2,2));
  text(0.75, 0.25, paste("AUC =",round(plotAUC,4)));
  lines(c(0,1), c(0,1), lty = 2);
  if(!batchMode){
    cat("AUC =",round(plotAUC,4),"; ");
  }
  if(length(vlineLocs) > 0){
    cutoffLoc <- which(abs(fpr - vlineLocs[1]) == min(abs(fpr - vlineLocs[1])))[1];
    cat("Value closest to FPR of ", vlineLocs[1], " = ", error.cutoff[cutoffLoc],
        " (TPR = ",tpr[cutoffLoc],", FPR = ",
        fpr[cutoffLoc],") [counts TP=",error.res$TP[cutoffLoc], ", FP=",error.res$FP[cutoffLoc],
        ", TN=",error.res$TN[cutoffLoc], ", FN=",error.res$FN[cutoffLoc], ", RR = ",error.res$TP[cutoffLoc]/error.res$FP[cutoffLoc],"]\n",sep="");
  }
  if (length(hlineLocs) > 0){
    cutoffLoc <- which(abs(tpr - hlineLocs[1]) == min(abs(tpr - hlineLocs[1])))[1];
    cat("Value closest to TPR of ", hlineLocs[1], " = ", error.cutoff[cutoffLoc],
        " (TPR = ",tpr[cutoffLoc],", FPR = ",
        fpr[cutoffLoc],") [counts TP=",error.res$TP[cutoffLoc], ", FP=",error.res$FP[cutoffLoc],
        ", TN=",error.res$TN[cutoffLoc], ", FN=",error.res$FN[cutoffLoc], ", RR = ",error.res$TP[cutoffLoc]/error.res$FP[cutoffLoc],"]\n",sep="");
  }
  if(batchMode){
    if(batchHeader){
      cat("AUC,Cutoff,TPR,FPR\n");
    }
    cat(round(plotAUC,4),",",error.cutoff[closestPoint],",",tpr[closestPoint],",",fpr[closestPoint],"\n",sep="");
  } else {
    cat("Closest cutoff to TPR 1, FPR 0 = ",error.cutoff[closestPoint],
        " (TPR = ",tpr[closestPoint],", FPR = ",
        fpr[closestPoint],")\n",sep="");
  }
} else {
  plot(0.5,0.5,xlim = c(0,1), ylim = c(0,1), type = "n", xlab = "Cutoff value", ylab = "Rate (as proportion of population size)");
  points(error.res$Cutoff,error.res$TP, type = "l", col = "green");
  points(error.res$Cutoff,error.res$FP, type = "l", col = "red");
  points(error.res$Cutoff,error.res$TN, type = "l", col = "blue");
  points(error.res$Cutoff,error.res$FN, type = "l", col = "grey");
  legend("top", legend = c("TP","FP","TN","FN"), fill = c("green","grey","blue","red"), inset = 0.01, bg = "white");
}
dummy <- dev.off();


#' QR Decomposition Methods
#'
#' QR factorization.
#'
#' @details
#' \eqn{R} is formed by first forming the crossproduct \eqn{X^T X} and taking
#' its Cholesky factorization.  But then \eqn{Q = X R^{-1}}.  Inverting \eqn{R}
#' is handled by an efficient triangular inverse routine.
#'
#' @section Communication:
#' The operation is completely local except for forming the crossproduct, which
#' is an \code{allreduce()} call, quadratic on the number of columns.
#'
#' @param x
#' A shaq.
#' @param R
#' A regular matrix. This argument is optional, in that if it is not supplied
#' explicitly, then it will be computed in the background.  But if have already
#' computed R, supplying it here will improve performance (by avoiding
#' needlessly recomputing it).
#'
#' @return
#' Q (a shaq) or R (a regular matrix).
#'
#' @examples
#' \dontrun{
#' library(kazaam)
#' x = ranshaq(runif, 10, 3)
#'
#' R = qr_R(x)
#' comm.print(R)
#'
#' Q = qr_Q(x, R)
#' Q
#'
#' finalize()
#' }
#'
#' @name qr
#' @rdname qr
NULL

#' @useDynLib kazaam R_trinv
.trinv = function(x)
{
  .Call(R_trinv, x, 'U')
}

#' @rdname qr
#' @export
qr_R = function(x)
{
  check.is.shaq(x)

  cp = cp.shaq(x)
  R = chol(cp)

  R
}

#' @rdname qr
#' @export
qr_Q = function(x, R)
{
  check.is.shaq(x)

  if (missing(R))
    R = qr_R(x)
  else
    check.is.matrix(R)

  Q.local = DATA(x) %*% .trinv(R)

  shaq(Q.local, nrow(x), ncol(x), checks=FALSE)
}


# Goal: Determine whether or not a client attended the consultation

# Remove Scientific Notation

options(scipen=999)

# Work Folder

setwd("C:/Users/Nina/Desktop/Machine Learning- R")

#Required Library

# Library required to import excel files
#install.packages("readxl")

# Warns "R" that uses this library

library(readxl)

# Creation of a function that reads the "xls" file and saved in a database "R"

base<- read_excel("dataset/consulta.xlsx", sheet=1)

# Show the base variables
names(base)

# Performing a descriptive analysis of the data

# For the variable "Sexo"

table(base$Sexo) # Display the absolute frequency

# For the variable "Idade"

summary(base$Idade) # Display, for quantitative variables, the main measures of position

boxplot(base$Idade) # Display the box-plot

# For the variable "Cidade"

table(base$Cidade) # Display the absolute frequencies

# For the variable "Attend"

table(base$Attend) # Display the absolute frequencies
prop.table(table(base$Attend)) # Display the relative frequencies

# Transform a quantitative variable into a qualitative one

base$Attend <- as.factor(base$Attend)

# Logistic Regression Model

# Create the model using GLM (general linear model)
# Binomial family - two possibilities - 0 or 1
#Link = logit uses the logistic function
modelo <-glm(Attend ~
               Sexo
                + Idade
                +Cidade,
                family = binomial (link='logit'), data = base)

summary(modelo) # Display the Model


source("src/EigenMS.R")

for (j in 1:20){

ddata = read.table(paste(c("output/simdata/mb_simulated_data_with_noise_for_sva_",toString(j),".txt"),collapse=""), header=TRUE)
ddata = ddata[,c(2,1,3:74)]
ddata[,1] <- seq.int(nrow(ddata))
m_logInts = ddata[,3:74]

m_prot.info = ddata[,1:2]

grps = as.factor(rep(1:24, times=1, each=3))
m_ints_eig1 = eig_norm1(m=m_logInts,treatment=grps,prot.info=m_prot.info)
m_ints_eig1$h.c
m_ints_norm1 = eig_norm2(rv=m_ints_eig1)

output <- m_ints_norm1$normalized[,2:74]
newcols <- c('#')
for (i in 2:73){
  newcols[i] <- unlist(strsplit(colnames(output)[i], '_'))[1]
}

colnames(output) <- newcols
write.table(output,paste(c("output/simdata/mb_simdata_eigenMS_",toString(j),".txt"),collapse=""),sep='\t', quote = FALSE, row.names=FALSE)

detach(TREAT)
}


library(ape)
library(aphylo)

# Creating the tree ------------------------------------------------------------
# tree <- matrix(c(3, 1, 3, 2), ncol=2,byrow=TRUE)
# tree <- as.phylo(tree)
# X <- c(1, 0)
tree <- matrix(c(5, 1, 5, 2, 1, 3, 1, 4), ncol=2, byrow = TRUE)
# tree <- matrix(c(5, 6, 5, 1, 6, 2, 6, 3, 6, 4), ncol=2, byrow = TRUE)
tree <- as.phylo(tree)
X    <- c(0, 0, 0)
atree <- new_aphylo(X, tree)

# Model parameters
Pi  <- .3
psi <- c(.01, .02)
mu  <- c(.2, .1)
eta <- c(1, 1)

#' Posterior probabilities based on parameter estimates
#' @param atree A tree of class [aphylo]
#' @template parameters
#' @templateVar .psi 1
#' @templateVar .mu 1
#' @templateVar .Pi
#' @export
predict_brute_force <- function(atree, psi, mu, Pi) {

  # Coercing into the true class
  tree <- as.phylo(atree)
  Pi   <- c(1 - Pi, Pi)

  # Generating a states matrix
  states <- do.call(expand.grid, rep(list(c(0,1)), ape::Nnode(tree) + ape::Ntip(tree)))
  colnames(states) <- paste0("node", 1:(ncol(states)))

  # Computing matrix of probabilities --------------------------------------------
  # 2^(ntips + nnodes)
  PSI <- prob_mat(psi)
  MU  <- prob_mat(mu)

  # For
  Pr <- Pi[states[, ape::Ntip(tree) + 1] + 1]
  for (i in 1:nrow(tree$edge)) {
    e <- tree$edge[i,]
    Pr <- Pr *
      MU[cbind(states[, e[1]], states[, e[2]]) + 1]
  }

  # Computing for each possible annotation of the tips
  # 2^Ntip
  Pr <- matrix(rep(Pr, 3), nrow=length(Pr), ncol = 2^ape::Ntip(tree))
  states_tip <- do.call(expand.grid, rep(list(c(0,1)), ape::Ntip(tree)))

  for (i in 1:nrow(states_tip)) {

    for (j in 1:ape::Ntip(tree)) {
      Pr[, i] <- Pr[, i] *
        PSI[cbind(states[, j] + 1, states_tip[i, j] + 1)]
    }

  }

  # Computing posterior probabilities
  posterior <- vector("numeric", ncol(states))
  for (i in 1:ncol(states)) {
    state_col <- which(apply(states_tip, 1, function(x) all(x == atree$tip.annotation)))
    state_rows <- which(states[,i] == 1)

    posterior[i] <- sum(Pr[state_rows, state_col])/sum(Pr[, state_col])
  }

  # Results
  list(
    Pr  = Pr,
    row = states,
    col = states_tip,
    posterior = posterior
  )

}

ans <- predict_brute_force(atree, psi, mu, Pi)

sum(ans$Pr) # This should add up to 1

# Comparing with aphylo --------------------------------------------------------
l <- LogLike(atree, psi, mu, eta, Pi)
X <- as.vector(atree$tip.annotation)
colSums(ans$Pr)[which(apply(ans$col, 1, function(x) all(x == X)))] -
  exp(l$ll)

exp(l$ll) # Jmorr tree 0.286622598, c(0, 0, 0)

# Conditional probability ------------------------------------------------------

i <- 5

# Matching state
state_col <- which(apply(ans$col, 1, function(x) all(x == X)))
state_rows <- which(ans$row[,i] == 1)

# Pr(root = 0 | data)
sprintf(
  "%.10f",
  1 - sum(ans$Pr[state_rows, state_col])/sum(ans$Pr[, state_col]) # 0.9907319671
)

sprintf(
  "%.10f",
  l$Pr[4,1]*(1-Pi)/
    (l$Pr[4,2]*Pi + l$Pr[4,1]*(1-Pi))
)

i_isone <- which(ans$row[,i] == 1L)
i_iszero <- which(ans$row[,i] == 0L)
X_given_xi1 <- sum(ans$Pr[i_isone, state_col])/sum(ans$Pr[i_isone,])
X_given_xi0 <- sum(ans$Pr[i_iszero, state_col])/sum(ans$Pr[i_iszero,])
xi1 <- sum(ans$Pr[i_isone,])

sprintf(
  "%.10f",
  1 - X_given_xi1/(X_given_xi1 + X_given_xi0*((1-xi1)/xi1))
)

# Jmorr tree
#
# Pr(z1=0|X)	0.9907319671
# Pr(z2=0|X)	0.9935955962
# Pr(z3=0|X)	0.9931689347
# Pr(z4=0|X)	0.9939582682
# Pr(z5=0|X)	0.9939582682


# Library
install.packages("dplyr")
install.packages("readr")
install.packages("ggplot2")
install.packages("stringr")
install.packages("tidyr")

library(dplyr)
library(readr)
library(ggplot2)
library(stringr)
library(tidyr)

# Load data
prog_book <- read.csv('https://raw.githubusercontent.com/safesit23/INT214-Statistics/main/datasets/prog_book.csv')

# Explore data
glimpse(prog_book)
View(prog_book)

# Learning function
prog_book %>% select(Book_title,Rating) %>% filter(Rating>4.50) %>% arrange(desc(Rating))

# 1
prog_book %>% select(Book_title,Rating,Price) %>% filter(Price == min(Price))

# 2
prog_book %>% select(Book_title,Type) %>% filter(Type == "ebook")

# 3
prog_book %>% group_by(Type) %>% summarise(avg=mean(Rating))

# 4
prog_book %>% select(Book_title,Reviews,Number_Of_Pages) %>% filter(Reviews == 0,Number_Of_Pages < 200)

# 5
prog_book %>% select(Book_title, Rating) %>% arrange(Rating) %>% head(n = 5)

# 6
str_subset(prog_book$Book_title,"Data")

#graph1
ggplot(prog_book) + aes(x = Type, color = Type, fill = Type) + geom_density(alpha = 0.25) + ggtitle("Number of type of book") + xlab("Type")+ylab("Count")

#graph2
prog_book %>%ggplot(aes(x=Rating,y=Number_Of_Pages)) + geom_point()


## myfrontierPoints is a more robust version of frontierPlot
## that can handle degenerate frontiers
## For example, in the risk neutral case:
##   All assets have the same expected return and
##   The frontier is a single point (the MVP).
##   The upper frontier (efficient part) has one point
##   The lower frontier (inefficient part) is empty
## The empty lower frontier causes an error in frontierPlot (in fPortfolio)
## frontierPlot calls the frontierPoints function (also in fPortfolio)
## So we patch frontierPoints by adding the following lines to return NULL
## in the degenerate case:
##
## if (NROW(ans) == 0){
##     NULL
## }else{
##      ...
##      ans
## }
##
## We use the proto library to make frontierPlot call the patched frontierPoints
## myfrontierPlot <- with(proto(environment(frontierPlot),
##                              frontierPlot = fPortfolio::frontierPlot,
##                              frontierPoints = myfrontierPoints), frontierPlot)

library(proto)

myfrontierPoints <- function (object, frontier = c("both", "lower", "upper"),
                              return = c("mean", "mu"),
                              risk = c("Cov", "Sigma", "CVaR", "VaR"),
                              auto = TRUE) {
  frontier = match.arg(frontier)
  return = match.arg(return)
  risk = match.arg(risk)
  if (auto) {
    Type = getType(object)
    Estimator = getEstimator(object)
    if (Type == "MV")
      risk = "Cov"
    if (Type == "MV" & Estimator != "covEstimator")
      risk = "Sigma"
    if (Type == "QLPM")
      risk = "Sigma"
    if (Type == "CVaR")
      risk = "CVaR"
  }
  if (is.vector(getTargetRisk(object@portfolio))) {
    targetRisk = getTargetRisk(object@portfolio)[risk]
    targetReturn = getTargetReturn(object@portfolio)[return]
  }
  else {
    targetRisk = getTargetRisk(object@portfolio)[, risk]
    targetReturn = getTargetReturn(object@portfolio)[, return]
  }
  ans = cbind(Risk = targetRisk, Return = targetReturn)
  if (frontier == "upper") {
    index = 1:length(ans[, 1])
    test = c(-1, diff(ans[, 1]))
    index = index[test > 0]
    ans = ans[index, ]
  }
  else if (frontier == "lower") {
    index = 1:length(ans[, 1])
    test = c(-1, diff(ans[, 1]))
    index = index[test < 0]
    if (length(index) == 1) {
      ans = matrix(ans[index, ], ncol = 2)
    }
    else {
      ans = ans[index, ]
    }
  }
  if (NROW(ans) == 0){
    NULL
  }else{
    colnames(ans) = c("targetRisk", "targetReturn")
    rownames(ans) = as.character(1:NROW(ans))
    attr(ans, "control") <- c(targetRisk = risk, targetReturn = return,
                              auto = as.character(auto))
    ans
  }
}

myfrontierPlot <- with(proto(environment(frontierPlot),
                             frontierPlot = fPortfolio::frontierPlot,
                             frontierPoints = myfrontierPoints), frontierPlot)


# [Membaca Dataset dengan read.csv](https://academy.dqlab.id/main/livecode/15/84/474)
# Membaca dataset dengan read.csv dan dimasukkan ke variable data_intro
data_intro <- read.csv("https://academy.dqlab.id/dataset/data_intro.csv", sep=";")
data_intro

# [Melihat Tipe Data dengan Str](https://academy.dqlab.id/main/livecode/15/84/475)
# Membaca dataset dengan read.csv dan dimasukkan ke variable data_intro
data_intro <- read.csv("https://academy.dqlab.id/dataset/data_intro.csv", sep=";")
str(data_intro)

# [Merubah Tipe Data Kolom ID.Pelanggan menjadi Character](https://academy.dqlab.id/main/livecode/15/84/476)
# mengubah data menjadi karakter karena tidak dilakukan analisis statistik pada variabel ID Pelanggan dan nama
data_intro$ID.Pelanggan <- as.character(data_intro$ID.Pelanggan)
data_intro$Nama <- as.character(data_intro$Nama)
# melihat apakah sudah berhasil dalam mengubah variabel tersebut
str(data_intro$ID.Pelanggan)
str(data_intro$Nama)

# [Merubah Sejumlah Kolom menjadi Data Kategorik (Factor)](https://academy.dqlab.id/main/livecode/15/84/477)
# Mengubah data menjadi factor untuk membedakan data kualitatif dengan menggunakan functon as.factor
data_intro$Jenis.Kelamin <- as.factor(data_intro$Jenis.Kelamin)
data_intro$Produk <- as.factor(data_intro$Produk)
data_intro$Tingkat.Kepuasan <- as.factor(data_intro$Tingkat.Kepuasan)
# Melihat apakah sudah berhasil dalam mengubah variabel tersebut dengan menggunakan function str
str(data_intro$Jenis.Kelamin)
str(data_intro$Produk)
str(data_intro$Tingkat.Kepuasan)

# [Skala Pengukuran Data](https://academy.dqlab.id/main/livecode/15/84/479)
# melihat data/ pemanggilan data
data_intro
# melihat tipe data
str(data_intro)

# [Estimasi Nilai Statistik Modus](https://academy.dqlab.id/main/livecode/15/84/481)
library(pracma)
## carilah modus untuk kolom Produk pada variable data_intro
Mode(data_intro$Produk)
## carilah modus untuk kolom Tingkat.Kepuasan pada variable data_intro
Mode(data_intro$Tingkat.Kepuasan)

# [Estimasi Nilai Statistik Median](https://academy.dqlab.id/main/livecode/15/84/482)
# carilah median untuk kolom Pendapatan dari variable data_intro
median(data_intro$Pendapatan)
# carilah median untuk  kolom Harga dari variable data_intro
median(data_intro$Harga)
# carilah median untuk kolom Jumlah dari variable data_intro
median(data_intro$Jumlah)
# carilah median untuk  kolom Total dari variable data_intro
median(data_intro$Total)

# [Estimasi Nilai Statistik Rata-Rata]
# carilah mean untuk kolom Pendapatan pada variable data_intro
mean(data_intro$Pendapatan)
# carilah mean untuk kolom Harga pada variable data_intro
mean(data_intro$harga)
# carilah mean untuk kolom Jumlah pada variable data_intro
mean(data_intro$Jumlah)
# carilah mean untuk kolom Total pada variable data_intro
mean(data_intro$Total)

# [Estimasi Nilai Sebaran Data Range](https://academy.dqlab.id/main/livecode/15/84/486)
max(data_intro["Pendapatan"]) - min(data_intro["Pendapatan"])

# [Estimasi Nilai Sebaran Data Varians](https://academy.dqlab.id/main/livecode/15/84/487)
# Carilah varians untuk kolom Pendapatan dari variable data_intro
var(data_intro$Pendapatan)
# [Estimasi Nilai Sebaran Data Simpangan Baku](https://academy.dqlab.id/main/livecode/15/84/488)
sd(data_intro$Pendapatan)

# [Analisis Deskriptif Menggunakan Nilai Statistik](https://academy.dqlab.id/main/livecode/15/85/491)
# carilah summary data dari data_intro
summary(data_intro)

# [Analisis Deskriptif Menggunakan Visualisasi](https://academy.dqlab.id/main/livecode/15/85/492)
# Carilah sebaran data kolom Jenis.Kelamin dari variable data_intro
plot(data_intro$Jenis.Kelamin)
# Carilah sebaran data dari Pendapatan dari variable data_intro
hist(data_intro$Pendapatan)
# Carilah sebaran data dari Produk dari variable data_intro
plot(data_intro$Produk)
# Carilah sebaran data dari Harga dari variable data_intro
hist(data_intro$Harga)
# Carilah sebaran data dari Jumlah dari variable data_intro
hist(data_intro$Jumlah)
# Carilah sebaran data dari Total dari variable data_intro
hist(data_intro$Total)
# Carilah sebaran data dari Tingkat.Kepuasan dari variable data_intro
plot(data_intro$Tingkat.Kepuasan)

# [Scatter Plot](https://academy.dqlab.id/main/livecode/15/85/500)
plot(data_intro$Pendapatan,data_intro$Total)
# [Hubungan Pendapatan dengan Total Belanja dengan cor.test](https://academy.dqlab.id/main/livecode/15/85/501)
# Gunakan cor.test untuk mencari hubungan Pendapatan dengan Total Belanja
cor.test(data_intro$Pendapatan, data_intro$Total)

# [Hubungan Produk dengan Tingkat Kepuasan dengan chisq.test](https://academy.dqlab.id/main/livecode/15/85/503)
table(data_intro$Produk, data_intro$Tingkat.Kepuasan)
# Analisis bagaimana hubungan jenis produk dengan tingkat kepuasan mengunakan uji korelasi
chisq.test(table(data_intro$Produk, data_intro$Tingkat.Kepuasan))

# [Hubungan Jenis Kelamin dengan Total Belanja dengan t.test](https://academy.dqlab.id/main/livecode/15/85/505)
# carilah boxplot antara variabel jenis kelamin dengan total belanja
boxplot(Total~Jenis.Kelamin, data = data_intro)
# Analisis bagaimana hubungan jenis kelamin dengan total belanja mengunakan uji statistik t-test
t.test(Total~Jenis.Kelamin, data = data_intro)

R/Kelas Fundamental/2. Statistics using R for Data Science.r


sal  = read.csv("/Users/buwnaekadesilva/Desktop/Salaries.csv")
sortedSalary = sort(sal$Salary)
shapiro.test(sortedSalary) # Shapiro-Wilk Test
lillie.test(sal$Salary) # Lilliefors-Test
ad.test(sal$Salary) # Anderson-Darling Test


#############
# ARS for the sampling of beta_a0 in GMM and IGMM
############
# TODO: What about this package?
# http://www.inside-r.org/packages/cran/Runuran/docs/ars.new
library(ars)

# function
beta.f_y <-function(y, S, W){

  F <- dim(W)[1]
  R <- dim(S)[3]

  sum_SW <- 0
  for (r in 1:R){
    Sr <- S[,,r]
    Sr <- as.matrix(Sr) # compatibility with one-dimensional case
    sum_SW <- sum_SW + log(det(Sr)*det(W)) - sum(diag(Sr%*%W))
  }

  sum_gamma <- 0
  for (d in 1:F){
    sum_gamma <- sum_gamma + lgamma((exp(y)+d-F)/2)
  }
  r <- y
  r <-  r - R*sum_gamma
  r <-  r - F/(2*(exp(y)-F+1))
  r <-  r - (3/2)*log(exp(y)-F+1)
  r <-  r + ((R*exp(y)*F)/2)*(y - log(2))
  r <-  r + (exp(y)/2)*sum_SW

  return(r)
}

# first derivative function
beta.f_y_prima <- function(y, S, W){

  F <- dim(W)[1]
  R <- dim(S)[3]

  sum_SW <- 0
  for (r in 1:R){
    Sr <- S[,,r]
    Sr <- as.matrix(Sr) # compatibility with one-dimensional case
    sum_SW <- sum_SW + log(det(Sr)*det(W)) - sum(diag(Sr%*%W))
  }

  sum_digamma <- 0
  for (d in 1:F){
    sum_digamma <- sum_digamma + digamma((exp(y)+d-F)/2)
  }
  r <- 1
  r <-  r - R*exp(y)*0.5*sum_digamma
  r <-  r + exp(y)*F/(2*((exp(y)-F+1))^2)
  r <-  r - (3/2)*exp(y)/(exp(y)-F+1) + (R*F*exp(y))/2 +  R*F*exp(y)*(y-log(2))/2
  r <-  r + (exp(y)/2)*sum_SW

  return(r)
}

# Wrapper for ARS function
ars.sample_beta_a0 <- function(S, W, init=4){

  # make it compatible with the one-dimensional case
  # in case we want to use this version for both
  # the multi and the uni-dimensional
  init <- log(init)
  if (is.matrix(W)){
     lb <- TRUE
     xlb <- log(dim(W)[1]-0.9)
     xpoints <- c(max(xlb, init-10), init, init+10)
   }
  # in case of computational issues (W with lots of decimals and too close to 0), truncate W
  y <- tryCatch(ars2.beta(1, beta.f_y, beta.f_y_prima, x=xpoints, lb=lb, xlb=xlb, S=S, W=W),
                error=function(e){
                  print(e);
                  ars2.beta(1, beta.f_y, beta.f_y_prima, x=xpoints, lb=lb, xlb=xlb, S=S, W=signif(W,1))})
  exp(y)
}

###############################################################################
# Hack ARS function so that it returns the ifault codes and not just print them
# so that we can handle it like an exception
###############################################################################

ars2.beta <- function (n = 1, f, fprima, x = c(-4, 1, 4), ns = 100, m = 3,
                  emax = 64, lb = FALSE, ub = FALSE, xlb = 0, xub = 0, ...)
{
  mysample <- rep(0, n)
  iwv <- rep(0, ns + 7)
  rwv <- rep(0, 6 * (ns + 1) + 9)
  hx <- f(x, ...)
  hpx <- fprima(x, ...)
  initial <- .C("initial_", as.integer(ns), as.integer(m),
                as.double(emax), as.double(x), as.double(hx), as.double(hpx),
                as.integer(lb), as.double(xlb), as.integer(ub), as.double(xub),
                ifault = as.integer(0), iwv = as.integer(iwv), rwv = as.double(rwv))
  if (initial$ifault == 0) {
    h <- function(x) f(x, ...)
    hprima <- function(x) fprima(x, ...)
    for (i in 1:n) {
      sample <- .C("sample_", as.integer(initial$iwv),
                   as.double(initial$rwv), h, hprima, new.env(),
                   beta = as.double(0), ifault = as.integer(0))
      if (sample$ifault == 0) {
        if (i < ns) {
          x <- c(x, sample$beta)
          h <- function(x) f(x, ...)
          hprima <- function(x) fprima(x, ...)
        }
        mysample[i] <- sample$beta
      }
      else {
        cat("\nError in sobroutine sample_...")
        cat("\nifault=", sample$ifault, "\n")
        stop(paste("\nError in sobroutine sample_...", sample$ifault))
      }
    }
  }
  else {
    cat("\nError in sobroutine initial_...")
    cat("\nifault=", initial$ifault, "\n")
    cat("\nx:", x)
    cat("\nfprima:", fprima(x,...))
    cat("\nf:", f(x,...))
    stop(paste("\nError in sobroutine initial_...", initial$ifault))
  }
  return(mysample)
}

environment(ars2.beta) <- environment(ars)

# test:
# multidimensional works fine

# W <- diag(2)*26
# S <- array(NA, dim=c(10,2,2))
#for (i in 1:10){
#  S[i,,] <- rWishart(1, 2, solve(2*W))
#}
# sample_beta_a0(S,W)
#
# W <- diag(2)*26
# S <- array(NA, dim=c(10,2,2))
#for (i in 1:10){
#  S[i,,] <- 2*diag(2)*1/26 # exactly the expectancy
#}
# sample_beta_a0(S,W)
#
#

############################################
# Debug with this

# Problematics
# s <- c(0.00589706, 0.00566612,  0.00505162,  0.00458974)
# w <- 202.159996343
#
# s <-  c(0.00495562,  0.00501441,  0.00484268,  0.005048)
# w <-  193.110366286
#
# W <- as.matrix(w)
# S <- array(NA, dim=c(length(s),1,1))
# S[,,] <- s
# x <- seq(-5,5, by=0.5)
#
# sample_beta_a0(s,w)
#
# plot(x, f_y(x, S, W))
# plot(x, f_y_prima(x, S, W))
#
# f_y_prima(c(-10,-4,4,25,100,300), S, W)

######################################################"""
S <- array(NA, dim=c(1, 1, 1))


plot.pca.3d <- function(pca, x = 1, y = 2, z = 3, type = 's', size = 1, scaling = 2,
                        col = 'black', box.col = 'grey', adj = c(0.5, -1),
                        main = NULL, xlab = NULL, ylab = NULL, zlab = NULL,
                        axes.edges = c('x', 'y', 'z-+'), axes.cex = 0.7, axes.lwd = 2,
                        projection = 'z', segment.col = 'black',
                        grid.side = c('z'), grid.col = 'grey',
                        sites.names = TRUE, species.names = TRUE, species.vectors = TRUE,
                        species.col = 'red', species.cex = 0.8, species.adj = c(0.5, 0)){

  # requering rgl and vegan package
  require(rgl)
  require(vegan)

  # options to check
  side.opt <- c('n', paste(c('x', 'y', 'z'), rep(c('', '+', '-'), each = 3), sep = ''))
  edge.opt <- c(side.opt, paste(c('x', 'y', 'z'),
                                rep(c('-+', '+-'), each = 3), sep = ''))

  if(sum(grid.side %in% side.opt) < length(grid.side))
    stop('"grid.side" has invalid value. Accepted values: ', paste(side.opt, ''))

  if(sum(projection %in% side.opt) < length(projection))
    stop('"projection" has invalid value. Accepted values: ', paste(side.opt, ''))

  if(sum(axes.edges %in% edge.opt) < length(axes.edges))
    stop('"axes.edge" has invalid value. Accepted values: ', paste(edge.opt, ''))

  if(!'rda' %in% class(pca))
    stop('"pca" must be "rda" class.')

  if(is.null(main))
    main <- paste('PCA - scaling', scaling)

  rm(site.opt, edge.opt)

  # default: x- y- z-
  idx <- grid.side %in% c('x', 'y', 'z')
  grid.side[idx] <- paste(grid.side[idx], "-", sep = "")

  idx <- projection %in% c('x', 'y', 'z')
  projection[idx] <- paste(projection[idx], "-", sep = "")

  rm(idx)

  # extract scores
  pca.scores <- scores(pca, scaling = scaling, choices = c(x, y, z))

  if(dim(pca.scores$sites)[2] < 3)
    stop('"pca" must have at least three eigenvectors.')

  # open 3d rgl device and plot box
  lim <- range(pca.scores) * 1.05
  plot3d(pca.scores$sites, type = type, axes=FALSE, size = size, col = col,
         main = main, xlab='', ylab='', zlab='',
         xlim = lim, ylim = lim, zlim = lim)
  box3d(col = box.col)

  # plot grite do edge
  grid3d(side = grid.side, col = grid.col)

  if(!'n' %in% axes.edges){
    # plot axes to edge
    axes3d(edges = axes.edges, cex = axes.cex, lwd = axes.lwd, labels = TRUE)

    # plot label to edge
    if(is.null(xlab)) xlab <- colnames(pca.scores$sites)[1]
    if(is.null(ylab)) ylab <- colnames(pca.scores$sites)[2]
    if(is.null(zlab)) zlab <- colnames(pca.scores$sites)[3]

    mtext3d(edge = axes.edges[1], text = xlab, line = 2)
    mtext3d(edge = axes.edges[2], text = ylab, line = 2)
    mtext3d(edge = axes.edges[3], text = zlab, line = 2)
  }

  # plot sites projection
  if(!'n' %in% projection){
    for(i in 1:dim(pca.scores$sites)[1]){
      st <- pca.scores$sites[i, ]
      for(j in projection){
        axsig <- strsplit(j, split = '')[[1]]
        fn <- ifelse(axsig[2] == "+", max, min)

        if(axsig[1] == 'x') fi <- c(fn(lim),
                                    pca.scores$sites[i,2],
                                    pca.scores$sites[i,3])

        if(axsig[1] == 'y') fi <- c(pca.scores$sites[i,1],
                                    fn(lim),
                                    pca.scores$sites[i,3])

        if(axsig[1] == 'z') fi <- c(pca.scores$sites[i,1],
                                    pca.scores$sites[i,2],
                                    fn(lim))

        segments3d(rbind(st, fi), col = ifelse(length(segment.col) > 1,
                                               segment.col[i], segment.col))
      }
    }
    rm(i, j, st, fi, axsig)
  }

  # plot site names
  if(sites.names)
    text3d(pca.scores$sites, texts = rownames(pca.scores$sites), col = col, adj = adj)

  # plot species names
  if(species.names)
    text3d(pca.scores$species, texts = rownames(pca.scores$species),
           col = species.col, cex = species.cex, adj = species.adj)

  # plot species vectors
  if(species.vectors){
    for(i in 1:dim(pca.scores$species)[1]){
      lines3d(rbind(c(0,0,0), pca.scores$species[i,1:3]), col = species.col)
    }
    rm(i)
  }

}