require(compiler)
enableJIT(3)
# RDS analysis is done on a variable by variable basis.
# recommended that results are stored in an easy to reference format

# Args( data, estVar, IDvar, rIDvar, options )
# Note that args are data columns
# options should include how to deal with levels > 2

# This estimation method reproduces the "multiplicity" estimate with "data smoothing"
# Calculated by RDS Analysis Tool v6.0.1
#
# New in RDS3 is the ability to generate a multi-factor population composition and tie table
#

multi.composition = function( variables, attVals, RID) {
	# Convert variables table to single categories corresponding to expand.grid(attVals, stringsAsFactors=FALSE)
	# intersect( which(sdf$race[i]==cat_attVals$race), intersect(which(sdf$neighborhood[i]==cat_attVals$neighborhood), which(sdf$aids[i]==cat_attVals$aids)))

	#for each respondent
		#figure out which expand.grid category they belong to:
		#  intersect the results of "which" in a recursive way, but do not use recursion
		#  intersection of all intersections should yield one group
		#  !!! Missing data is not allowed !!! --> non-unique group assignment--return NA?
	cats = expand.grid(attVals, stringsAsFactors=FALSE)
	comp_group = rep(NA, nrow(variables))

	for (i in 1:nrow(variables)) {
		matchTF = rep(TRUE, nrow(cats))
		for (j in 1:ncol(variables) ) {
			matchTF = matchTF & (unlist(cats[j]) == variables[i,j])
		}
		if ( NA %in% matchTF ) {
			comp_group[i] = NA
		}else{
			comp_group[i] = match(TRUE, matchTF)
		}
	}

	multi.comp = rep(0,nrow(cats))
	multi.seeds = rep(0,nrow(cats))
	for (i in 1:nrow(cats) ) {
		multi.comp[i] = length(which(comp_group==i))
		multi.seeds[i] = length( which(comp_group==i & is.na(RID) ))
	}

	results = list(composition=multi.comp, seed.composition=multi.seeds)

}

multi.recruitment = function( variables, ID, RID, attVals) {
	# Return recruitment composition and sample composition. Note that attVals and vars must be in same order.
	# Convert variables table to single categories corresponding to expand.grid(attVals, stringsAsFactors=FALSE)
	# intersect( which(sdf$race[i]==cat_attVals$race), intersect(which(sdf$neighborhood[i]==cat_attVals$neighborhood), which(sdf$aids[i]==cat_attVals$aids)))

	#for each respondent
		#figure out which expand.grid category they belong to:
		#  intersect the results of "which" in a recursive way, but do not use recursion
		#  intersection of all intersections should yield one group
		#  !!! Missing data is not allowed !!! --> non-unique group assignment--return NA?
	cats = expand.grid(attVals, stringsAsFactors=FALSE)
	comp_group = rep(NA, nrow(variables))

	# How many levels of grouping variable?
	groupCount = nrow(cats)

	for (i in 1:nrow(variables)) {
		matchTF = rep(TRUE, groupCount)
		for (j in 1:ncol(variables) ) {
			matchTF = matchTF & (unlist(cats[j]) == variables[i,j])
		}
		if ( NA %in% matchTF ) {
			comp_group[i] = NA
		}else{
			comp_group[i] = match(TRUE, matchTF)
		}
	}

	multi.comp = rep(0,groupCount)
	multi.seeds = rep(0,groupCount)
	for (i in 1:groupCount ) {
		multi.comp[i] = length(which(comp_group==i))
		multi.seeds[i] = length( which(comp_group==i & is.na(RID) ))
	}

	groupNames = 1:groupCount

	#print(comp_group)

	rVar = rep(NA,length(comp_group))
	for (i in 1:length(ID) ) {
		#print(paste(i,': ', RID[which(ID==i)]))
		if (!(is.na(RID[i]))) {
			#rVar[i] = as.character(comp_group[match(RID[i], ID)])
			rVar[i] = comp_group[match(RID[i], ID)]

		}
	}
	rVar = factor(rVar,levels=groupNames)
	comp_group = factor(comp_group, levels=groupNames)
	# Gives raw recruitment

	raw_rec=table(rVar, comp_group)

	results = list(categories = cats, composition=multi.comp, seed.composition=multi.seeds, multi.rec=raw_rec)
}

rds.VH.estimate = function(variable, ID, recruiterID, degree, groups=NULL){
	# How many levels of grouping variable?
	if ( is.null(groups)) {
		u=as.factor(variable)
	} else {
		u=factor(variable, levels=sort(groups))
	}

	groupCount = nlevels(u)
	groupNames = levels(u)
	grpRng = 1:groupCount

	sample.recruits.dist = rep(0, groupCount)
	sample.population.proportion = rep(0, groupCount)

	RDS2.estimate = rep(0, groupCount)

	indexSRU = which(!( is.na(variable)))
	Nu = length(indexSRU) # the n in the equation 9

	indexDU = which(!(is.na(variable)|is.na(ID)|is.na(recruiterID) |is.na(degree) ))
	meanDegreeU = length(indexDU)/sum(1/degree[indexDU], na.rm=TRUE ) # delta_u in the eq 9

	meanDegreeA = rep(0 , groupCount) # used to store the delta_A in eq 9

	for (i in 1:length(groupNames) ) {
		indexSR = which((variable==groupNames[i]))
		sample.recruits.dist[i]=length(indexSR) #n_A in the eq 9

		indexD = which((variable==groupNames[i]) & !( is.na(degree)|is.na(ID)|is.na(recruiterID)|is.na(variable)  ))
		meanDegreeA[i] = (length(indexD))/sum(1/degree[indexD], na.rm=TRUE ) # delta_A in eq9

		sample.population.proportion[i] = sample.recruits.dist[i]/Nu # n_A/n in eq 9

		RDS2.estimate[i] = sample.population.proportion[i] *(meanDegreeU/meanDegreeA[i])

	}
	results = list(RDS.VH.estimate = RDS2.estimate,
			mean.network.size.multiplicity = meanDegreeA,
			sample.population.proportion = sample.population.proportion ,
			meanDegree.ratio = meanDegreeU/meanDegreeA,
			overall.mean.network.size.multiplicity = meanDegreeU
			)
}

rds.estimate = function( variable, ID, recruiterID, degree, method="data.smoothing",
						 group.size = 12, ci_alpha=0, ...)
{
	#Should add some error checking
	# - args should be the same length
	# method should be recognized

	ok.methods = c("data.smoothing", "least.squares")
	if (!(method %in% ok.methods)) {
		stop(paste("*** Unimplemented Method ***"))
	}

	# How many levels of grouping variable?
	u=as.factor(variable)
	groupCount = nlevels(u)
	groupNames = levels(u)

	rVar = rep(NA,length(variable))
	for (i in ID) {
		if (!(is.na(recruiterID[which(ID==i)]))) {
			rVar[which(ID==i)] = as.character(variable[which(ID==recruiterID[which(ID==i)])])
		}
	}
	rVar = factor(rVar,levels=groupNames)

	# Gives raw recruitment
	t=table(rVar, variable)

	# Proportional Recrutiment
	S = prop.table(t,1)

	# Total Recruitment
	#  of Group- RO
	#  by Group- RB
	RO = apply(t,2,sum)
	RB = apply(t,1,sum)

	#Recruitment Proportion - R
	R = RO/sum(t)

	# How many levels of grouping variable?
	#u=unique(as.factor(variable))
	#groupCount = nlevels(u)
	#groupNames = levels(u)

	# Sample Composition
	Cc = rep(0 , groupCount)
	names(Cc) = groupNames
	seeds = rep(0 , groupCount)
	names(seeds) = groupNames

	for (i in 1:length(groupNames) ) {
		Cc[i] = length(which(variable==groupNames[i]))
		seeds[i] = length( which(variable==groupNames[i] & is.na(recruiterID) ))
	}

	C = Cc/sum(Cc)

	S.org = S

	E.hat = rds.mcmc.props( S )
	t.dem.adj = sum( RB) * E.hat * S
	t.data.smoothed = (t.dem.adj + t(t.dem.adj))/2
	if ( method == "data.smoothing" ) {
		# Need to recalculate
		# row sum, column sums, selection prop, equilibria

		# Proportional Recrutiment
		S = prop.table(t.data.smoothed,1)

		# Total Recruitment
		#  of Group- RO
		#  by Group- RB
		#RO = apply(t.data.smoothed,2,sum)
		#RB = apply(t.data.smoothed,1,sum)

		#Recruitment Proportion - R
		R = RO/sum(t.data.smoothed)
	}

	rec = list(sample.recruitment=t, recruitment.dem.adj=t.dem.adj, recruitment.smoothed=t.data.smoothed, proportion.recruitment=S, recruitment.of=RO, recruitment.by=RB,
				recruitment.proportion = R, comp.props=C, composition=Cc, seeds=seeds, groupNames = groupNames, method=method, rVar = rVar)

	#Sample Degree Estimate
	wt=1/degree

	meanDegree = rep(0 , groupCount)
	for (i in 1:length(groupNames) ) {
		index = which((variable==groupNames[i]) & !(is.na(recruiterID)))
		meanDegree[i] = weighted.mean(degree[index],wt[index], na.rm=TRUE )
	}

	# Population Estimates & Equilibrium

	#   Population Estimates
	P.hat = rds.mcmc.props( S, meanDegree, method)

	#P.hat.vector = rep(0,length(variable))
	#for (i in 1:length(groupNames) ) {
	#	P.hat.vector[which(variable==groupNames[i])] = P.hat[i]
	#}

	#Equilibrium
	E.hat = rds.mcmc.props( S )

	#Homophily
	homophily.2002 = rep(0,groupCount)
	for ( i in 1:groupCount ) {
		if ( P.hat[i] <= S[i,i] ) {
			homophily.2002[i] = (P.hat[i] - S[i,i])/(P.hat[i]-1)
			#ah = ()/()
		} else {
			homophily.2002[i] = (S[i,i])/(P.hat[i])-1
		}
	}

	# Store Estimate Variables
	est = list( E.hat.equilibrium=E.hat, P.hat.population.proportion=P.hat,
				multiplicity.mean.degree = meanDegree, Homophily = homophily.2002)

	# Group Sampling Weights
	# 	ratio of pop estimate P and sample proportion composition
	sampling.weights = rep(0,length(variable))

	for (i in 1:length(groupNames) ) {
		sampling.weights[which(variable==groupNames[i])] = P.hat[i]/C[i]
	}

	#Group Dual Weights
	# Recruitment Component
	# Degree Component
	recruitment.component = rep(0 , groupCount)
	names(recruitment.component) = groupNames

	degree.component = rep(0 , groupCount)
	names(degree.component) = groupNames

	for (i in 1:length(groupNames) ) {
		recruitment.component[i] = E.hat[i]/C[i]
		degree.component[i] = P.hat[i]/E.hat[i]
	}

	#Individual Weight Components

	# Imputation Setup
	#   Set Seeds to their group mean
	#   Set missing values to their group means

	degree.imp = degree

	for (i in 1:length(groupNames) ) {
		degree.imp[which(is.na(recruiterID) & variable==groupNames[i] )] = meanDegree[i]
		degree.imp[which(is.na(degree) & variable==groupNames[i] )] = meanDegree[i]

		#People with zero degree are treated as missing
		degree.imp[which( degree <= 0 & variable==groupNames[i] )] = meanDegree[i]

	}

	# Calculate the Constants
	#  Recruitment Components
	RC = rep(0,length(variable))
	for (i in 1:length(groupNames) ) {
		RC[which(variable==groupNames[i])] = recruitment.component[i]
	}

	#  K is an estimate for the overall mean degree for respondents
	K = length(variable)/sum(RC/degree.imp)
	#  DW is the individualized Dual Weight
	dual.weights = RC/degree.imp*K

	est = c(est, list(   imputed.degree = degree.imp,
						 group.sampling.weights = sampling.weights,
						 group.recruitment.component = recruitment.component,
						 group.degree.component = degree.component,
						 weights.dual.component = dual.weights,
						 recruitment.components = RC,
						 K.constant = K,
						 degree.components = K/degree.imp ) )

	# Adjusted Population Estimates
	parts = (length(na.omit(degree)) / group.size)^(.5)

	if (parts < 2) {
		parts = 2
	} else {
		parts = floor(parts)
	}

	breaks = unique(quantile(degree, probs=seq(1/parts,1,1/parts) ,na.rm=TRUE))
	#print(breaks)

	deg.groupNames = 1:length(breaks)
	group = rep(NA,length(variable))
	group[which(degree >= 1)] = 1

	for (i in 1:(parts-1)) {
		group[which(degree > breaks[i])] = i+1

	}

	rGrp = rep(NA,length(degree))
	for (i in ID) {
		if (!is.na(recruiterID[which(ID==i)]) ) {
			rGrp[which(ID==i)] = as.character(group[which(ID==recruiterID[which(ID==i)])])
		}
	}

	rGrp = factor(rGrp,levels=deg.groupNames)

	# Gives raw recruitment
	deg.t=table(rGrp, group)

	# Proportional Recrutiment
	deg.S = prop.table(deg.t,1)

	# Total Recruitment - RO
	deg.RO = apply(deg.t,2,sum)

	#Recruitment Proportion - R
	deg.R = RO/sum(deg.t)

	#Sample Composition - C

	Cg = rep(0 , parts)
	names(Cg) = deg.groupNames
	for (i in 1:parts ) {
		Cg[i] = length(which(group[which(group!=0)]==i))/length(group[which(group!=0)])
	}

	deg.C = rep(0 , length(degree))
	for (i in 1:parts ) {
		deg.C[which(group == i)] = Cg[i]
	}

 	# Degree Adjusted Equilibrium
	deg.E.hat = rds.mcmc.props( deg.S )

 	# Produce Vector of equilibiria values
 	deg.eq = rep(NA,length(degree))
 	for ( i in 1:length(deg.groupNames) ) {
 		deg.eq[which(group == deg.groupNames[i])] = deg.E.hat[i]
 	}

	# Recruitment Component of Degree RCD
	deg.RCD = deg.eq/deg.C
	deg.RCD[which(is.na(recruiterID))] = NA

	# Adjusted Degree
	RCDtoD = deg.RCD/degree
	aggRCDtoD = sapply(groupNames,function(x) sum((RCDtoD)[which(variable==x)],na.rm=TRUE) )
	aggRCD = sapply(groupNames,function(x) sum((deg.RCD)[which(variable==x)],na.rm=TRUE) )

	adj.degree = c(aggRCD/aggRCDtoD)

 	# Degree Adjusted Population Estimates
	adj.P.hat = rds.mcmc.props( S, adj.degree)

	#Homophily
	ahomophily.2002 = rep(0,groupCount)
	for ( i in 1:groupCount ) {
		if ( P.hat[i] <= S[i,i] ) {
			ahomophily.2002[i] = (adj.P.hat[i] - S[i,i])/(adj.P.hat[i]-1)
			#ah = ()/()
		} else {
			ahomophily.2002[i] = (S[i,i]/adj.P.hat[i])-1
		}
	}

	#Bootstrap CI
  if (ci.alpha > 0) {
    simple_bs_values(S, degree_weights_lists, mean_degs, trials=100 )

  }

	adj = list( degree.partition.count=parts, adj.degree=adj.degree,
				adj.E.hat=deg.E.hat, adj.P.hat = adj.P.hat, adj.Homophily = ahomophily.2002 )
	results = c( rec, est, adj )
}

read.rds = function(file, calc_wave=TRUE, ... )
{
# Reads a file formatted for RDS Analysis Tool v5.6
# and returns an R data.frame
#
# Does some checking and issues errors when errors might be present in data file
#   ** Does not check missing value is correct, but does substitute NA.
#   ** Does not check that number of coupons is correct.
#   -- Issues warnings if the recruiter for a respondent with a recruitment
#      coupon cannot be found, but treats these cases as seeds.
#
# Adds a data column and computes Recruiter's ID
#
	header = scan(file, skip = 1, n = 3, quiet=TRUE)
	if (length(header) != 3) {
		stop("Error in Header: Wrong number of items.")
	} else {
		DF = read.delim( file, skip = 1, header=TRUE, na.strings=as.character(header[3]), ...)
	}

	if( nrow(DF) != header[1] ) { stop("Error in Header: Number of cases mis-match.") }

	names(DF)[1:3] = c("ID", "Degree", "recCouponID")
	names(DF)[4:(3+header[2])] = paste("C", 1:header[2], sep="")

	DF$RID = rep(NA, nrow(DF))
	for (i in 1:nrow(DF) )
	{
		index = which(DF[,4:(3+header[2])]==DF$recCouponID[i]) %% nrow(DF)
		if( !is.na(DF$recCouponID[i]) && length(index) == 0 ) {
			warning(paste("Respondent ID ", DF$ID[i],": Recruiter for non-seed not found, will be treated as seed"))
		}
		if ( length(index) > 0 && index > 0) {
			DF$RID[i] = DF$ID[index]
		}
	}
	#Set degree 0 to missing to avoid calculation errors
	DF$Degree[which(DF$Degree==0)] = NA
	if (calc_wave) {
		DF$wave = rds.waves(DF$ID, DF$RID)
	}

	DF
}

rds.waves = function(ID, recruiterID)
{
	wave=rep(0,length(ID))

	nextWaveIndex = which(is.na(recruiterID))

	currentWaveCount = 1
	currentWaveIndex = unlist(sapply(nextWaveIndex, function(x) which(recruiterID==ID[x])))

	while (length(currentWaveIndex) > 0) {
		wave[currentWaveIndex] = currentWaveCount
		nextWaveIndex = unlist(sapply(currentWaveIndex, function(x) which(recruiterID==ID[x])))
		currentWaveCount = currentWaveCount+1
		currentWaveIndex = nextWaveIndex
	}
	wave
}

rds.seed_chain = function(ID, recruiterID)
{
	chain=rep(0,length(ID))
	chain_ID = seq(1,sum(is.na(recruiterID)) )

	nextWaveIndex = which(is.na(recruiterID))
	chain[nextWaveIndex] = chain_ID

	currentWaveCount = 1

	currentWaveIndex = lapply(nextWaveIndex, function(x) which(recruiterID %in% ID[x]))
	while (sum(unlist(lapply(currentWaveIndex,length))) > 0) {
		for (i in chain_ID ) {
			chain[currentWaveIndex[[i]]] = i
		}
		currentWaveIndex = lapply(currentWaveIndex, function(x) which(recruiterID %in% ID[x]))
	}
	chain
}

rds.wave.est = function( pTab, tol=.001, printWaves=FALSE)
{
	# Variables to hold calculations
	if (is.null(dimnames(pTab)[[1]])) {
		 dimnames(pTab)[1] = list(1:nrow(pTab))
		 dimnames(pTab)[2] = list(1:nrow(pTab))
	}

	groupNames = dimnames(pTab)[[1]]
	len = length(groupNames)

	#Set up starting distributions
	starts = matrix(0,len,len)
	diag(starts) = 1

	notDone = TRUE

	waveCount = 0
	currentDists = starts
	while(notDone) {
		if (printWaves) {
			print(waveCount)
			print(currentDists)
		}
		currentDists = currentDists %*% pTab
		deviations = apply(currentDists,2,function(x) max(x) - min(x))
		notDone =  any( deviations > tol)
		waveCount = waveCount+1
		if (waveCount > 1000) {
			waveCount = 10000
			notDone = FALSE
		}
	}

	waveCount
}

rds.mcmc.props = function( S, weights=NULL, method="data.smoothing")
{
	# Variables to hold calculations
	if (is.null(dimnames(S)[[1]])) {
		 dimnames(S)[1] = list(1:nrow(S))
		 dimnames(S)[2] = list(1:nrow(S))
	}

	groupNames = dimnames(S)[[1]]
	len = length(groupNames)

	#print(len)

 	#Generic Weighted MCMC Estimate
	if (len==2) {
		# Weighted Estimates of Equilibrium Proportions
		# P[A] = S[BA]*D[B]/ ( Sba*Db + Sab*Da )
		if (is.null(weights) ) { weights=rep(1,nrow(S)) }
		P.hat = rep(0 , len)
		for (i in 1:len ) {
			a = i
			b = 3 - i

			P.hat[i] = S[groupNames[b],groupNames[a]]*weights[b] /
			(S[groupNames[b],groupNames[a]]*weights[b] + S[groupNames[a],groupNames[b]]*weights[a])

		}

	} else { # (groupCount > 2)
		P.hat = rep(NA , len)
		if (method=="data.smoothing") {
			if( is.null(weights) ) {
				#print(t(S))
				#print(diag(1,len,len))
				coe = t(S) - diag(1,len,len)
				coe[len,] = rep(1, len )
				b = c(rep(0,len-1),1)
			} else {
				coe = matrix(rep(0,len^2),nrow=len)
				coe[1:len] = c( weights[1] * S[1,] )
				diag(coe) = c(-1*weights*S[,1])
				coe[1,] = rep(1,len)
				b = c(1,rep(0,len-1))
			}
			try((P.hat = solve( coe , b )))
		}
		if (method=="least.squares") {
			stop("*** Unimplemented Method ***")
		}

	}
	names(P.hat) = groupNames
	P.hat[which(P.hat<=0)]=0
	#P.hat[which(is.na(P.hat))]=0
	P.hat
}

rec.table = function( row.var , column.var, dim.Names, group.Names )
{
	len = length(group.Names)
	res = diag(0, len, len)
	for (i in 1:len ) {
		res[i,] = tabulate( na.omit(column.var[which(row.var==i)]), len)

	}

	res = as.table(res, dnn=c(as.charater(row.var)))
	dimnames(res) = list(group.Names,group.Names)
	names(dimnames(res)) = dim.Names
	res

}

# Generate a bootstrapped CI for estimate (no variance in transition probs)
simple_bs_values = function(S, degree_weights_lists, mean_degs, trials=100 ) {
	bs_results = matrix(nrow=trials, ncol=ncol(S))
	sample_size = length(unlist(degree_weights_lists))
	overall_mean = mean(mean_degs)

	state_count = nrow(S)
	#print(bs_results)
	#print(sample_size)
	#print(bs_mean_deg)

	for (j in 1:trials) {
		#Bootstrap a sample composition and transition probs
		bs_sample = generate_state_seq(seq_len=sample_size, probs=S)

		rec = matrix(0, state_count, state_count)

		for (i in 2:length(bs_sample)) {
			rec[bs_sample[i-1], bs_sample[i]] = rec[bs_sample[i-1], bs_sample[i]]+1
		}

		bs.props = prop.table(rec, 1)
		bs.cnum  = as.vector(table( factor(bs_sample, levels=c(1:state_count) ) ))
		#print(bs.cnum)

		#Bootstrap a degree for each group, based on the bootstrapped sample composition

		bs_mean_deg = rep(0,)
		for (i in 1:length(bs_mean_deg)){
			if (bs.cnum[i]>=1) {
				bs_mean_deg[i] = bs.cnum[i] / sum( sample(degree_weights_lists[[i]], size=bs.cnum[i], replace=TRUE) )
			} else {
				bs_mean_deg[i] = overall_mean
			}
		}

		bs_results[j,] = unlist(rds.mcmc.props(bs.props, bs_mean_deg))
	}
	#print(bs_results)
	#bs_ci = as.vector(apply( bs_results, 2, quantile, c(one_tail_alpha, 1-one_tail_alpha), na.rm=TRUE))
	return(bs_results)
}

agg_bs_values = function(bs_values_cbind, site_weights, one_tail_alpha=.025 ){
	bs_results = apply(bs_values, 1, weighted.mean, site_weights)
	bs_ci = quantile(bs_results, c(one_tail_alpha, 1-one_tail_alpha), na.rm=TRUE)
	return(bs_ci)
}

agg_bs_values_approx = function(bs_values_cbind, site_weights, one_tail_alpha=.025 ){
	bs_results = apply(bs_values, 1, weighted.mean, site_weights)
	bs_ci = quantile(bs_results, c(one_tail_alpha, 1-one_tail_alpha), na.rm=TRUE)
	return(bs_ci)
}

generate_state_seq = function( seq_len = 10, states = c(1, 2), probs = matrix(NA, 2, 2), initial_state_pos=NA ) {
	ret_seq = rep(0, seq_len)
	rand_list = runif(seq_len)
	if (is.na(initial_state_pos)) { ret_seq[1]=sample.int(nrow(probs), 1) }
	else { ret_seq[1] = initial_state_pos }
	cum_prob = t(apply(probs, 1, cumsum))
	cum_prob[,nrow(cum_prob)] = 1  #Set the last column to 1 to avoid rounding errors
	for (i in 2:seq_len){
		 ret_seq[i] = 1+sum(cum_prob[ret_seq[i-1],] <= rand_list[i] )
	}
	# Could add code to replace the state_index with the state code (as.factor)
	return(ret_seq)
}

rds.bootstrap_fast = function(o_variable, ID, recruiterID, degree, method="data.smoothing",
						 group.size = 12, groups=NULL, minXrec=.00001, est.only=FALSE, trials=1000, one_tail_alpha=.025, ...)
{
	print("Warning: This function produces narrow CI compared to RDSAT")
	# This function may exhibit unexpected behavior when ID is not of mode "numeric"
	# Levels of var should be coded 1,2,3,..
	# Fix it with code below:
	if (is.null(groups)) {
		variable = factor(o_variable)
		levels(variable) = 1:nlevels(variable)
	} else {
		variable = factor(o_variable)
		groups = 1:length(groups)
		levels(variable) = groups
	}
	# Generate Point Estimate for Variable
	actual = rds.set_groups_estimate(variable, ID, recruiterID, degree, method=method, group.size=group.size,
									 groups=groups, minXrec=minXrec)
	ID = actual$ID
	recruiterID = actual$RID

	# Generate degree_weights list of lists
	# Rec of i by j
	# j recruted i
	degree_weights = vector(mode="list", length=length(actual$groupNames))
	for (i in 1:length(actual$groupNames)) {
		group_by_group = vector(mode="list", length=length(actual$groupNames))
		for ( j in 1:length( actual$groupNames ) ) {
			temp_list_value <- actual$imputed.degree[which(   (actual$rVar==actual$groupNames[j])
					   				        	  			& (variable==actual$groupNames[i])  )]
			group_by_group[j] = list(temp_list_value^-1)
		}
		degree_weights[i] <- list(group_by_group)
	}
	S_bs = prop.table(actual$sample.recruitment+minXrec, 1)
	print(S_bs)

	sample_size = length(actual$ID)
	overall_mean = mean(actual$mean.degree)
	overall_mean_inv = overall_mean^-1

	bs_results = matrix(nrow=trials, ncol=ncol(S_bs))
	state_count = nrow(S_bs)
	#bs_sample = generate_state_seq(seq_len=sample_size*trials, probs=S_bs)
	#start_index = seq(from=1, to=sample_size*trials, by=sample_size )

	for (t_num in 1:trials) {
		#Bootstrap a sample composition and transition probs
		bs_sample = generate_state_seq(seq_len=sample_size, probs=S_bs)
		#bs_sample_degree = array(NA, sample_size)
		#bs_sample_degree[1] = sample(unlist(degree_weights[[ bs_sample_states[1] ]]), 1)
		rec = matrix(0, state_count, state_count)
		for (i in 1:(sample_size-1) ) {
			rec[ bs_sample[i], bs_sample[i+1]] = rec[ bs_sample[i], bs_sample[i+1]]+1
			#bs_sample_degree[i] = sample(unlist(degree_weights[[ bs_sample_states[i] ]][[ bs_sample_states[i-1] ]]), 1)
		}
		# rec might look like:
		#         [,1] [,2] [,3]
		#	[1,]   87   37   18
		#	[2,]   39   44    7
		#	[3,]   17    8    6

		bs.props = prop.table(rec+.00001, 1)
		bs.cnum  = as.vector(table( factor(bs_sample, levels=c(1:state_count) ) ))

		#Bootstrap a degree for each group, based on the bootstrapped sample composition

		bs_mean_deg_mat = matrix(0, state_count, state_count)
		for (i in 1:ncol(rec)){
			for (j in 1:nrow(rec)) {
				if (rec[i,j]>=1) {
					if (length(degree_weights[[i]][[j]]) > 1) {
						bs_mean_deg_mat[i,j] = sum( sample(unlist(degree_weights[[i]][[j]]), size=rec[j,i], replace=TRUE) )
					}
					else if (length(degree_weights[[i]][[j]]) == 1) {
						bs_mean_deg_mat[i,j] = sum( rep(unlist(degree_weights[[i]][[j]]), rec[j,i]) )
					}
					else {
						bs_mean_deg_mat[i,j] = overall_mean_inv
					}
				}
			}
		}
		bs_mean_deg = bs.cnum / apply(bs_mean_deg_mat, 1, sum)

		E.hat = rds.mcmc.props( bs.props )
		t.dem.adj = sum(rec) * E.hat * bs.props
		t.data.smoothed = (t.dem.adj + t(t.dem.adj))/2
		bs_prop_DS = prop.table(t.data.smoothed+.0001, 1)

		bs_results[t_num,] = unlist(rds.mcmc.props(bs_prop_DS, bs_mean_deg))
		#print(bs_results[t_num,])
	}
	#print(bs_results)
	#bs_ci = as.vector(apply( bs_results, 2, quantile, c(one_tail_alpha, 1-one_tail_alpha), na.rm=TRUE))
	return(bs_results)
	#return(bs_ci)
}

rds.bootstrap_slow = function(o_variable, ID, recruiterID, degree, method="data.smoothing",
						 group.size = 12, groups=NULL, minXrec=.0001, est.only=FALSE, trials=1000, one_tail_alpha=.025, ...)
{
	# This function may exhibit unexpected behavior when ID is not of mode "numeric"
	# Levels of var should be coded 1,2,3,..
	# Fix it with code below:
	if (is.null(groups)) {
		variable = factor(o_variable)
		levels(variable) = 1:nlevels(variable)
	} else {
		variable = factor(o_variable)
		groups = 1:length(groups)
		levels(variable) = groups
	}
	# Generate Point Estimate for Variable
	actual = rds.set_groups_estimate(variable, ID, recruiterID, degree, method=method, group.size=group.size,
									 groups=groups, minXrec=minXrec)
	ID = actual$ID
	recruiterID = actual$RID

	# Generate degree_weights list of lists
	# Rec of i by j
	# j recruted i
	degree_weights = vector(mode="list", length=length(actual$groupNames))
	for (i in 1:length(actual$groupNames)) {
		group_by_group = vector(mode="list", length=length(actual$groupNames))
		for ( j in 1:length( actual$groupNames ) ) {
			temp_list_value <- actual$imputed.degree[which(   (actual$rVar==actual$groupNames[j])
					   				        	  			& (variable==actual$groupNames[i])  )]
			group_by_group[j] = list(temp_list_value)
		}
		degree_weights[i] <- list(group_by_group)
	}
	S_bs = prop.table(actual$sample.recruitment+minXrec, 1)

	sample_size = length(actual$ID)
	overall_mean = mean(actual$mean.degree)

	sample_degrees = function(x,y) {
		sample(unlist(degree_weights[[ x ]][[ y ]]), 1)
	}

	bs_results = matrix(nrow=trials, ncol=ncol(S_bs))
	state_count = nrow(S_bs)
	bs_sample_states = generate_state_seq(seq_len=sample_size*trials, probs=S_bs)
	bs_sample_degree = 	mapply( sample_degrees, head(bs_sample_states,-1) , tail(bs_sample_states,-1) )
	start_index = seq(from=1, to=sample_size*trials, by=sample_size )

	for (t_num in 1:trials) {
		#Bootstrap a sample composition and transition probs
		#bs_sample_states = generate_state_seq(seq_len=sample_size, probs=S_bs)
		#bs_sample_degree = array(NA, sample_size)
		#bs_sample_degree[1] = sample(unlist(degree_weights[[ bs_sample_states[1] ]]), 1)
		#rec = matrix(0, state_count, state_count)
		#for (i in 1:(sample_size-1) ) {
		#	rec[ bs_sample[start_index[t_num]], bs_sample[start_index[t_num]+i] ] = rec[ bs_sample[start_index[t_num]], bs_sample[start_index[t_num]+i] ]+1
		#	#bs_sample_degree[i] = sample(unlist(degree_weights[[ bs_sample_states[i] ]][[ bs_sample_states[i-1] ]]), 1)
		#}
		# rec might look like:
		#         [,1] [,2] [,3]
		#	[1,]   87   37   18
		#	[2,]   39   44    7
		#	[3,]   17    8    6

		#bs.props = prop.table(rec, 1)
		#bs.cnum  = as.vector(table( factor(bs_sample, levels=c(1:state_count) ) ))

		bs_results[t_num,] = rds.set_groups_estimate(bs_sample_states[start_index[t_num]:(start_index[t_num]+sample_size-1)], 1:sample_size,
													 c(NA,1:(sample_size-1)), bs_sample_degree[start_index[t_num]:(start_index[t_num]+sample_size-1)],
													 est.only=TRUE)$adj.P.hat
	}
	#print(bs_results)
	bs_ci = as.vector(apply( bs_results, 2, quantile, c(one_tail_alpha, 1-one_tail_alpha), na.rm=TRUE))
	#return(bs_results)
	return(bs_ci)
}

rds.bootstrap = function( variable, ID, recruiterID, degree, method="data.smoothing",
						 group.size = 12, groups=NULL, trials=1000, ...)
{
	# This function may exhibit unexpected behavior when ID is not of mode "numeric"
	# Levels of var should be coded 1,2,3,..
	recruiterID = apply(as.array(recruiterID),1,function(x) match(x,ID))
	ID = 1:length(ID)

	# Generate Point Estimate for Variable
	actual = rds.set_groups_estimate(variable, ID, recruiterID, degree, method, group.size, groups=groups )

	# Generate lists of people according to recruiter's variable
	index=list()
	seeds=list()
	for (i in 1:length(actual$groupNames) ) {
		index[i] = list(ID[which((actual$rVar==actual$groupNames[i]) & !is.na(variable) )])
		seeds[i] = list(ID[which((variable==actual$groupNames[i]) & is.na(actual$rVar) )])
	}

	seeds=(unlist(seeds))
	seedCount = length(seeds)

	# Generate list to hold the results
	results = list()
	results$P.hat = matrix(nrow=trials,ncol=length(actual$groupNames))
	results$adj.P.hat = matrix(nrow=trials,ncol=length(actual$groupNames))

	#data = as.data.frame(cbind(variable, ID, recruiterID, degree))
	#names(data) = c("variable", "ID", "recruiterID", "degree")
	recruitable = unlist(index)
	size = length(recruitable)

	bs.size = length(seeds)+size
	lcm.size = seedCount*ceiling(bs.size/seedCount)  ##Why?

	# Set up variables for resample
	re.ID  = seq(1,bs.size)
	re.var = vector("character",bs.size)
	re.RID = c(rep(NA,seedCount), seq(1,bs.size-seedCount))
	re.degree = vector("numeric", bs.size )

	re.RID[1:seedCount] = NA
	curVar = as.vector(variable[seeds])
	curWave= as.vector(seeds)

	# Need to take sample from all seeds simlultaneously.
	#  - determine how to terminate when enough seeds are added
	#
	#

	# Generate samples, calculate and record the estimates
	for ( i in 1:trials) {
		re.samp = matrix(vector("numeric", length=lcm.size),nrow=seedCount)
		re.seeds = sample(seeds)
		re.samp[1:seedCount] = re.seeds
		curVar = variable[re.seeds]

		re.var[1:seedCount]=curVar

		# select sample from seed
		for ( j in 2:(lcm.size/seedCount)) {
			#print(re.samp)
			curWave = (sapply(curVar, function(x) sample(index[[x]],1)))
			re.samp[,j] = curWave
			curVar = variable[curWave]

		}
		re.samp.vec = as.vector(re.samp)[1:bs.size]
		re.var = variable[re.samp.vec]
		re.degree = degree[re.samp.vec]

		# create data.frame

		#rd = as.data.frame(cbind(re.ID,re.var,re.RID,re.degree))
		foo = rds.set_groups_estimate(re.var, re.ID, re.RID, re.degree, method, group.size, groups=groups, est.only=TRUE)
		results$P.hat[i,] = foo$P.hat
		results$adj.P.hat[i,] = foo$adj.P.hat

		#print(i)
	}
	results.ci = lapply(results, function(x) apply(x,2,"quantile", seq(0,1,.025)[c(1:3,39:41)], na.rm=TRUE ) )
	c( results.ci, list( trials=trials, na.P.hat=sum(is.na(results$P.hat[,1])),
						 na.adj.P.hat=sum(is.na(results$adj.P.hat[,1]))
					   )
	)
}

rds.estimate.fast = function( variable, ID, recruiterID, degree, method="data.smoothing",
						 group.size = 12, minXrec=0, est.only=FALSE, ...)
{
	#ID == index for this version
	# ID = 1:length(ID)
	# RID = apply(as.array(recruiterID),1,function(x) match(x,ID))

	#Should add some error checking
	# - args should be the same length
	# method should be recognized

	ok.methods = c("data.smoothing", "least.squares")
	if (!(method %in% ok.methods)) {
		stop(paste("*** Unimplemented Method ***"))
	}
	dataLen = length(ID)
	dataRng = 1:dataLen

	# How many levels of grouping variable?

	u=as.factor(variable)
	groupCount = nlevels(u)
	groupNames = levels(u)
	grpRng = 1:groupCount

	rVar = factor(apply(as.array(recruiterID),1, function(x) variable[x]),levels=groupNames)

	# Gives raw recruitment
	t=table(rVar, variable)

	# Proportional Recrutiment
	S = prop.table(t,1)
	S[which(S<=0)]=minXrec
	S[which(is.na(S))]=minXrec

	# Total Recruitment
	#  of Group- RO
	#  by Group- RB
	RO = apply(t,2,sum)
	RB = apply(t,1,sum)

	#Recruitment Proportion - R
	R = RO/sum(t)

	# Sample Composition & Sample Degree Estimates
	Cc = rep(0 , groupCount)
	names(Cc) = groupNames

	seeds = rep(0 , groupCount)
	names(seeds) = groupNames

	meanDegree = rep(0 , groupCount)
	names(meanDegree) = groupNames
	wt=1/degree

	seed = is.na(recruiterID)

	for (i in grpRng ) {
		inGroupi = (variable==groupNames[i])
		Cc[i] = sum(inGroupi,na.rm=TRUE)
		seeds[i] = sum( (inGroupi & seed) )

		indexGroupi = which(( inGroupi & !(seed) ))
		meanDegree[i] = weighted.mean(degree[indexGroupi],wt[indexGroupi], na.rm=TRUE )

	}

	C = Cc/sum(Cc)

	E.hat = rds.mcmc.props( S )
	t.dem.adj = sum( RB) * E.hat * S
	t.data.smoothed = (t.dem.adj + t(t.dem.adj))/2
	if ( method == "data.smoothing" ) {
		# Need to recalculate
		# row sum, column sums, selection prop, equilibria

		# Proportional Recrutiment
		S = prop.table(t.data.smoothed,1)
		S[which(S<=0)]=minXrec
		S[which(is.na(S))]=minXrec
		S = prop.table(S,margin=1)

		# Total Recruitment
		#  of Group- RO
		#  by Group- RB
		#RO = apply(t.data.smoothed,2,sum)
		#RB = apply(t.data.smoothed,1,sum)

		#Recruitment Proportion - R
		R = RO/sum(t.data.smoothed)

		#Equilibrium
		E.hat = rds.mcmc.props( S )
	}

	if (!(est.only)) {
		rec = list(sample.recruitment=t, recruitment.dem.adj=t.dem.adj, recruitment.smoothed=t.data.smoothed, proportion.recruitment=S, recruitment.of=RO, recruitment.by=RB,
				recruitment.proportion = R, comp.props=C, composition=Cc, seeds=seeds, groupNames = groupNames, method=method, rVar = rVar)
	}

	# Population Estimates & Equilibrium

	#   Population Estimates
	P.hat = rds.mcmc.props( S, meanDegree, method)

	# Store Estimate Variables
	est = list( E.hat.equilibrium=E.hat, P.hat.population.proportion=P.hat,
				multiplicity.mean.degree = meanDegree)

	#Homophily
	if (FALSE) {
	for ( i in grpRng ) {
		if ( P.hat[i] <= S[i,i] ) {
			homophily.2002 = (P.hat[i] - S[i,i])/(P.hat[i]-1)
			#ah = ()/()

		} else {
			homophily.2002 = (S[i,i])/(P.hat[i])-1

		}
	}
	}

	# Group Sampling Weights
	# 	ratio of pop estimate P and sample proportion composition
	sampling.weights = rep(0,groupCount)
	names(sampling.weights) = groupNames
	#--Group Dual Weights
	#----Recruitment Component
	recruitment.component = rep(0 , groupCount)
	names(recruitment.component) = groupNames

	#----Degree Component
	degree.component = rep(0 , groupCount)
	names(degree.component) = groupNames

	for (i in grpRng ) {
		sampling.weights[i] = P.hat[i]/C[i]
		recruitment.component[i] = E.hat[i]/C[i]
		degree.component[i] = P.hat[i]/E.hat[i]
	}

	#Individual Weight Components

	# Imputation Setup
	#   Set Seeds to their group mean
	#   Set missing values to their group means

	# Calculate the Constants
	#  Recruitment Components
	RC = rep(0,dataLen)
	degree.imp = degree

	for (i in grpRng ) {
		inGroup = (variable==groupNames[i])
		degree.imp[which( seed & inGroup )] = meanDegree[i]
		degree.imp[which( is.na(degree) & inGroup )] = meanDegree[i]
		#  People with zero degree are treated as missing data
		degree.imp[which( degree <= 0 & inGroup )] = meanDegree[i]

		RC[which(inGroup)] = recruitment.component[i]
	}

	#  K is an estimate for the overall mean degree for respondents
	K = dataLen/sum(RC/degree.imp)
	#  DW is the individualized Dual Weight
	dual.weights = RC/degree.imp*K

	if (!(est.only)) {
		est = c(est, list(   imputed.degree = degree.imp,
						 group.sampling.weights = sampling.weights,
						 group.recruitment.component = recruitment.component,
						 group.degree.component = degree.component,
						 weights.dual.component = dual.weights,
						 recruitment.components = RC,
						 K.constant = K,
						 degree.components = K/degree.imp ) )
	}

	# Adjusted Population Estimates
	parts = (length(na.omit(degree)) / group.size)^(.5)

	if (parts < 2) {
		parts = 2
	} else {
		parts = floor(parts)
	}

	breaks = quantile(degree, probs=seq(1/parts,1,1/parts) ,na.rm=TRUE)
	#print(breaks)

	deg.groupNames = 1:length(breaks)

	group = factor(apply(as.array(degree), 1, function(x) c(NA,1)[as.numeric(x >= 1)+1]),levels=deg.groupNames)

	for (i in 1:(parts-1)) {
		group[which(degree > breaks[i])] = i+1
	}

	rGrp = factor(apply(as.array(recruiterID), 1, function(x) group[x]),levels=deg.groupNames)

	# Gives raw recruitment
	deg.t=table(rGrp, group)

	# Proportional Recrutiment
	deg.S = prop.table(deg.t,1)
	deg.S[which(deg.S<=0)]=minXrec
	deg.S[which(is.na(deg.S))]=minXrec

	# Total Recruitment - RO
	deg.RO = apply(deg.t,2,sum)

	#Recruitment Proportion - R
	deg.R = deg.RO/sum(deg.t)

	#Sample Composition and Degree

	Cg = rep(0 , parts)
	names(Cg) = deg.groupNames

	deg.C = rep(0 , dataLen)

	for (i in 1:parts ) {
		Cg[i] = sum(group==i, na.rm=TRUE)
		deg.C[which(group == i)] = Cg[i]

	}
	Cg = Cg/sum(Cg)

 	# Degree Adjusted Equilibrium
	deg.E.hat = rds.mcmc.props( deg.S )

 	# Produce Vector of equilibiria values
 	deg.eq = rep(NA,length(degree))
 	for ( i in deg.groupNames) {
 		deg.eq[which(group == deg.groupNames[i])] = deg.E.hat[i]
 	}

	# Recruitment Component of Degree RCD
	deg.RCD = deg.eq/deg.C
	deg.RCD[which(seed)] = NA

	# Adjusted Degree
	RCDtoD = deg.RCD/degree
	aggRCDtoD = sapply(groupNames,function(x) sum((RCDtoD)[which(variable==x)],na.rm=TRUE) )
	aggRCD = sapply(groupNames,function(x) sum((deg.RCD)[which(variable==x)],na.rm=TRUE) )

	adj.degree = c(aggRCD/aggRCDtoD)

 	# Degree Adjusted Population Estimates
	adj.P.hat = rds.mcmc.props( S, adj.degree)

	if (!(est.only)) {
		adj = list( degree.partition.count=parts, adj.degree=adj.degree,
				adj.E.hat=deg.E.hat, adj.P.hat = adj.P.hat )
	}
	if (est.only) {
		results = list(P.hat.population.proportion=P.hat, adj.P.hat = adj.P.hat)
	} else {
		results = c( rec, est, adj )
	}
	results
}

rds.set_groups_recruitment = function( variable, ID, recruiterID, degree, method="data.smoothing", use.weighted.degree=TRUE,
						 group.size = 12, groups=NULL, minXrec=.0001, estVH = FALSE, est.only=FALSE, ...)
{

	# This function allow the user to specify the groups present in the population.
	# As a result, this leads to the possibility of null values in the matricies when
	# expected groups are not present. As a convienience to the user, recruitment is
	# given a lower bound and groups with missing mean degree are assigned the mean degree
	# for all groups.

	#Should add some error checking
	# - args should be the same length
	# method should be recognized

	ok.methods = c("data.smoothing", "least.squares")
	if (!(method %in% ok.methods)) {
		stop(paste("*** Unimplemented Method ***"))
	}

	# How many levels of grouping variable?

	if ( is.null(groups)) {
		u=as.factor(variable)
	} else {
		u=factor(variable, levels=sort(groups))
	}

	groupCount = nlevels(u)
	groupNames = levels(u)
	grpRng = 1:groupCount

	recruiterID = apply(as.array(recruiterID),1,function(x) match(x,ID))
	ID = 1:length(ID)

	dataLen = length(ID)
	dataRng = 1:dataLen

	rVar = factor(apply(as.array(recruiterID),1, function(x) variable[x]),levels=groupNames)

	# Gives raw recruitment
	T=table(rVar, u)

	# Proportional Recrutiment
	S = prop.table(T,1)
	S[which(S<=0)]=minXrec
	S[which(is.na(S))]=minXrec

	waves.req = rds.wave.est(S)
	waves.max = max(rds.waves(ID, recruiterID) )

	# Total Recruitment
	#  of Group- RO
	#  by Group- RB
	RO = apply(T,2,sum)
	RB = apply(T,1,sum)

	#Recruitment Proportion - R
	R = RO/sum(T)

	# Sample Composition & Sample Degree Estimates
	Cc = rep(0 , groupCount)
	names(Cc) = groupNames

	seeds = rep(0 , groupCount)
	names(seeds) = groupNames

	meanDegree = rep(0 , groupCount)
	names(meanDegree) = groupNames

	if (use.weighted.degree) {
		wt=1/degree
	} else {
		wt=rep(1,length(degree))
	}

	seed = is.na(recruiterID)

	for (i in grpRng ) {
		inGroupi = (variable==groupNames[i])
		Cc[i] = sum(inGroupi,na.rm=TRUE)
		seeds[i] = sum( (inGroupi & seed) )

		indexGroupi = which(( inGroupi & !(seed) ))
		meanDegree[i] = weighted.mean(degree[indexGroupi],wt[indexGroupi], na.rm=TRUE )

	}
	meanDegree[which(is.na(meanDegree))]=mean(meanDegree, na.rm=TRUE)

	C = Cc/sum(Cc)

		S.raw = S
	S.raw[which(S.raw <= minXrec)]=0

	E.hat = rds.mcmc.props( S )
	t.dem.adj = sum( RB) * E.hat * S
	t.data.smoothed = (t.dem.adj + t(t.dem.adj))/2
	if ( method == "data.smoothing" ) {
		# Need to recalculate
		# row sum, column sums, selection prop, equilibria

		# Proportional Recrutiment
		S = prop.table(t.data.smoothed,1)
		S[which(S<=0)]=minXrec
		S[which(is.na(S))]=minXrec
		S = prop.table(S,margin=1)

		# Total Recruitment
		#  of Group- RO
		#  by Group- RB
		#RO = apply(t.data.smoothed,2,sum)
		#RB = apply(t.data.smoothed,1,sum)

		#Recruitment Proportion - R
		R = RO/sum(t.data.smoothed)

		#Equilibrium
		E.hat = rds.mcmc.props( S )
	}

	rec = list(ID=ID, RID=recruiterID, sample.recruitment=T, recruitment.dem.adj=t.dem.adj, recruitment.smoothed=t.data.smoothed, proportion.recruitment=S, S.raw=S.raw, recruitment.of=RO, recruitment.by=RB,
				recruitment.proportion = R, comp.props=C, composition=Cc, seeds=seeds, mean.degree=meanDegree, groupNames = groupNames, method=method, rVar = rVar, waves.req = waves.req, waves.max=waves.max)
	return(c(rec))
}

rds.set_groups_estimate = function( variable, ID, recruiterID, degree, method="data.smoothing", use.weighted.degree=TRUE, group.size = 12, groups=NULL, minXrec=.0001, estVH = FALSE, est.only=FALSE, ...)
{

	# This function allow the user to specify the groups present in the population.
	# As a result, this leads to the possibility of null values in the matricies when
	# expected groups are not present. As a convienience to the user, recruitment is
	# given a lower bound and groups with missing mean degree are assigned the mean degree
	# for all groups.

	#print(paste("Est received:", group.size))
	#Should add some error checking
	# - args should be the same length
	# method should be recognized

	ok.methods = c("data.smoothing", "least.squares")
	if (!(method %in% ok.methods)) {
		stop(paste("*** Unimplemented Method ***"))
	}

	# How many levels of grouping variable?

	if ( is.null(groups)) {
		u=as.factor(variable)
	} else {
		u=factor(variable, levels=sort(groups))
	}

	groupCount = nlevels(u)
	groupNames = levels(u)
	grpRng = 1:groupCount

	recruiterID = apply(as.array(recruiterID),1,function(x) match(x,ID))
	ID = 1:length(ID)

	dataLen = length(ID)
	dataRng = 1:dataLen

	rVar = factor(apply(as.array(recruiterID),1, function(x) variable[x]),levels=groupNames)

	# Gives raw recruitment
	T=table(rVar, u)

	# Proportional Recrutiment
	S = prop.table(T,1)
	S[which(S<=0)]=minXrec
	S[which(is.na(S))]=minXrec

	waves.req = rds.wave.est(S)
	waves.byseed = rds.waves(ID, recruiterID)
	waves.max = max( waves.byseed )

	# Total Recruitment
	#  of Group- RO
	#  by Group- RB
	RO = apply(T,2,sum)
	RB = apply(T,1,sum)

	#Recruitment Proportion - R
	R = RO/sum(T)

	# Sample Composition & Sample Degree Estimates
	Cc = rep(0 , groupCount)
	names(Cc) = groupNames

	seeds = rep(0 , groupCount)
	names(seeds) = groupNames

	meanDegree = rep(0 , groupCount)
	names(meanDegree) = groupNames

	if (use.weighted.degree) {
		wt=1/degree
	} else {
		wt=rep(1,length(degree))
	}

	seed = is.na(recruiterID)

	for (i in grpRng ) {
		inGroupi = (variable==groupNames[i])
		Cc[i] = sum(inGroupi,na.rm=TRUE)
		seeds[i] = sum( (inGroupi & seed) )

		indexGroupi = which(( inGroupi & !(seed) ))
		meanDegree[i] = weighted.mean(degree[indexGroupi],wt[indexGroupi], na.rm=TRUE )

	}
	meanDegree[which(is.na(meanDegree))]=mean(meanDegree, na.rm=TRUE)

	C = Cc/sum(Cc)

	#browser()
	S.raw = S
	S.raw[which(S.raw <= minXrec)]=0

	E.hat = rds.mcmc.props( S )
	t.dem.adj = sum( RB) * E.hat * S
	t.data.smoothed = (t.dem.adj + t(t.dem.adj))/2
	if ( method == "data.smoothing" ) {
		# Need to recalculate
		# row sum, column sums, selection prop, equilibria

		# Proportional Recrutiment
		S = prop.table(t.data.smoothed,1)
		S[which(S<=0)]=minXrec
		S[which(is.na(S))]=minXrec
		S = prop.table(S,margin=1)

		# Total Recruitment
		#  of Group- RO
		#  by Group- RB
		#RO = apply(t.data.smoothed,2,sum)
		#RB = apply(t.data.smoothed,1,sum)

		#Recruitment Proportion - R
		R = RO/sum(t.data.smoothed)

		#Equilibrium
		E.hat = rds.mcmc.props( S )
	}

	if (!(est.only)) {
		rec = list(ID=ID, RID=recruiterID, sample.recruitment=T, recruitment.dem.adj=t.dem.adj, recruitment.smoothed=t.data.smoothed, proportion.recruitment=S, S.raw=S.raw, recruitment.of=RO, recruitment.by=RB,
				recruitment.proportion = R, comp.props=C, composition=Cc, seeds=seeds, mean.degree=meanDegree, groupNames = groupNames, method=method, rVar = rVar, waves.req = waves.req, waves.max=waves.max, waves.bychain=waves.byseed)
	}

	# Population Estimates & Equilibrium

	#   Population Estimates
	P.hat = rds.mcmc.props( S, meanDegree, method)

	#Homophily
	homophily.2002 = rep(0,groupCount)
	for ( i in grpRng ) {
		if ( !( is.na(P.hat[i]) | is.na(S[i,i]) ) ) {
			if ( P.hat[i] <= S[i,i] ) {
				homophily.2002[i] = (P.hat[i] - S[i,i])/(P.hat[i]-1)
				#ah = ()/()
			} else {
				homophily.2002[i] = (S[i,i])/(P.hat[i])-1
			}
			if (S.raw[i,i] == sum(S.raw[,i])) {
				homophily.2002[i] = NA
			}
		}
	}

	# Store Estimate Variables
	if (estVH) {
		est.VH = rds.VH.estimate( variable, ID, recruiterID, degree, groups )

		est = list( E.hat.equilibrium=E.hat, P.hat.population.proportion=P.hat,
					VH.P.hat = est.VH$RDS.VH.estimate,
				    multiplicity.mean.degree = meanDegree, Homophily = homophily.2002)
	} else {
		est = list( E.hat.equilibrium=E.hat, P.hat.population.proportion=P.hat,
				multiplicity.mean.degree = meanDegree, Homophily = homophily.2002)
	}

	# Group Sampling Weights
	# 	ratio of pop estimate P and sample proportion composition
	sampling.weights = rep(0,groupCount)
	names(sampling.weights) = groupNames
	#--Group Dual Weights
	#----Recruitment Component
	recruitment.component = rep(0 , groupCount)
	names(recruitment.component) = groupNames

	#----Degree Component
	degree.component = rep(0 , groupCount)
	names(degree.component) = groupNames

	for (i in grpRng ) {
		sampling.weights[i] = P.hat[i]/C[i]
		recruitment.component[i] = E.hat[i]/C[i]
		degree.component[i] = P.hat[i]/E.hat[i]
	}

	#Individual Weight Components

	# Imputation Setup
	#   Set Seeds to their group mean
	#   Set missing values to their group means

	# Calculate the Constants
	#  Recruitment Components
	RC = rep(0,dataLen)
	degree.imp = degree

	for (i in grpRng ) {
		inGroup = (variable==groupNames[i])
		degree.imp[which( seed & inGroup )] = meanDegree[i]
		degree.imp[which( is.na(degree) & inGroup )] = meanDegree[i]
		#  People with zero degree are treated as missing data
		degree.imp[which( degree <= 0 & inGroup )] = meanDegree[i]

		RC[which(inGroup)] = recruitment.component[i]
	}

	#  K is an estimate for the overall mean degree for respondents
	K = dataLen/sum(RC/degree.imp)
	#  DW is the individualized Dual Weight
	dual.weights = RC/degree.imp*K

	if (!(est.only)) {
		est = c(est, list(   imputed.degree = degree.imp,
						 group.sampling.weights = sampling.weights,
						 group.recruitment.component = recruitment.component,
						 group.degree.component = degree.component,
						 weights.dual.component = dual.weights,
						 recruitment.components = RC,
						 K.constant = K,
						 degree.components = K/degree.imp ) )
	}

	# Adjusted Population Estimates
	parts = (length(na.omit(degree)) / group.size)^(.5)
	if (parts < 2) {
		parts = 2
	} else {
		parts = floor(parts)
	}

	breaks = quantile(degree, probs=seq(1/parts,1,1/parts) ,na.rm=TRUE)
	#print(breaks)

	deg.groupNames = 1:length(breaks)

	group = factor(apply(as.array(degree), 1, function(x) c(NA,1)[as.numeric(x >= 1)+1]),levels=deg.groupNames)

	for (i in 1:(parts-1)) {
		group[which(degree > breaks[i])] = i+1
	}

	rGrp = factor(apply(as.array(recruiterID), 1, function(x) group[x]),levels=deg.groupNames)

	# Gives raw recruitment
	deg.t=table(rGrp, group)

	# Proportional Recrutiment
	deg.S = prop.table(deg.t,1)
	deg.S[which(deg.S<=0)]=minXrec
	deg.S[which(is.na(deg.S))]=minXrec

	# Total Recruitment - RO
	deg.RO = apply(deg.t,2,sum)

	#Recruitment Proportion - R
	deg.R = deg.RO/sum(deg.t)

	#Sample Composition and Degree

	Cg = rep(0 , parts)
	names(Cg) = deg.groupNames

	deg.C = rep(0 , dataLen)

	for (i in 1:parts ) {
		Cg[i] = sum(group==i, na.rm=TRUE)
		deg.C[which(group == i)] = Cg[i]

	}
	Cg = Cg/sum(Cg)

 	# Degree Adjusted Equilibrium
	deg.E.hat = rds.mcmc.props( deg.S )

 	# Produce Vector of equilibiria values
 	deg.eq = rep(NA,length(degree))
 	for ( i in deg.groupNames) {
 		deg.eq[which(group == deg.groupNames[i])] = deg.E.hat[i]
 	}

	# Recruitment Component of Degree RCD
	deg.RCD = deg.eq/deg.C
	deg.RCD[which(seed)] = NA

	# Adjusted Degree
	RCDtoD = deg.RCD/degree
	aggRCDtoD = sapply(groupNames,function(x) sum((RCDtoD)[which(variable==x)],na.rm=TRUE) )
	aggRCD = sapply(groupNames,function(x) sum((deg.RCD)[which(variable==x)],na.rm=TRUE) )

	adj.degree = c(aggRCD/aggRCDtoD)

	adj.degree[which(is.na(adj.degree))]=mean(adj.degree, na.rm=TRUE)

 	# Degree Adjusted Population Estimates
	adj.P.hat = rds.mcmc.props( S, adj.degree)

	# Adjusted Homophily
	ahomophily.2002 = rep(0,groupCount)
	for ( i in grpRng ) {
		if ( !(is.na(P.hat[i]) | is.na(S[i,i])) ) {

			if ( P.hat[i] <= S[i,i] ) {
				ahomophily.2002[i] = (adj.P.hat[i] - S[i,i])/(adj.P.hat[i]-1)
				#ah = ()/()
			} else {
				ahomophily.2002[i] = (S[i,i]/adj.P.hat[i])-1
			}
			if (S.raw[i,i] == sum(S.raw[,i])) {
				homophily.2002[i] = NA
			}
		}
	}

	if (!(est.only)) {
		adj = list( degree.partition.count=parts, adj.degree=adj.degree,
				adj.E.hat=deg.E.hat, adj.P.hat = adj.P.hat, adj.Homophily = ahomophily.2002 )
	}
	if (est.only) {
		results = list(P.hat.population.proportion=P.hat, adj.P.hat = adj.P.hat)
	} else {
		results = c( rec, est, adj )
	}
	results
}

rds.set_groups_bootstrap = function( variable, ID, recruiterID, degree, method="data.smoothing",
						 group.size = 12, groups=NULL, minXrec=.0001, est.only=FALSE,
             trials=1000, ci.alpha=.025, ...)
{
	# This function may exhibit unexpected behavior when ID is not of mode "numeric"
	# Levels of var should be coded 1,2,3,..
	if (is.null(groups)) {
		variable = factor(variable)
		levels(variable) = 1:nlevels(variable)
	} else {
		variable = factor(variable)
		groups = 1:length(groups)
		levels(variable) = groups
	}
	# Generate Point Estimate for Variable
	actual = rds.set_groups_estimate(variable, ID, recruiterID, degree, method=method, group.size=group.size,
									 groups=groups, minXrec=minXrec)
	ID = actual$ID
	recruiterID = actual$RID

	srsVar = sapply(actual$P.hat, function(x) x*(1-x)/length(ID) )
	srsVar.adj = sapply(actual$adj.P.hat, function(x) x*(1-x)/length(ID) )

	# Generate lists of people according to recruiter's variable
	index=list()
	seeds=list()
	for (i in 1:length(actual$groupNames) ) {
		index[i] = list(ID[which((actual$rVar==actual$groupNames[i]) & !is.na(variable) )])
		seeds[i] = list(ID[which((variable==actual$groupNames[i]) & is.na(actual$rVar) )])
		if (length(index[[i]]) < 1 ) { index[i] = list(ID[which(!is.na(variable))]) }
	}

	seeds=(unlist(seeds))
	seedCount = length(seeds)

	# Generate list to hold the results
	results = list()
	results$P.hat = matrix(nrow=trials,ncol=length(actual$groupNames))
	results$adj.P.hat = matrix(nrow=trials,ncol=length(actual$groupNames))

	#data = as.data.frame(cbind(variable, ID, recruiterID, degree))
	#names(data) = c("variable", "ID", "recruiterID", "degree")
	recruitable = unlist(index)
	size = length(recruitable)

	bs.size = length(seeds)+size
	lcm.size = seedCount*ceiling(bs.size/seedCount)  ##Why?

	# Set up variables for resample
	re.ID  = seq(1,bs.size)
	re.var = vector("character",bs.size)
	re.RID = c(rep(NA,seedCount), seq(1,bs.size-seedCount))
	re.degree = vector("numeric", bs.size )

	re.RID[1:seedCount] = NA
	curVar = as.vector(variable[seeds])
	curWave= as.vector(seeds)

	# Need to take sample from all seeds simlultaneously.
	#  - determine how to terminate when enough seeds are added
	#
	#

	# Generate samples, calculate and record the estimates
	for ( i in 1:trials) {
		re.samp = matrix(vector("numeric", length=lcm.size),nrow=seedCount)
		re.seeds = sample(seeds)
		re.samp[1:seedCount] = re.seeds
		curVar = variable[re.seeds]

		re.var[1:seedCount]=curVar

		# select sample from seed
		for ( j in 2:(lcm.size/seedCount)) {
			#print(re.samp)
			#print(index)
			#print(curWave)
			#print(curVar)

			curWave = (sapply(curVar, function(x) sample(index[[x]],1)))
			re.samp[,j] = curWave
			curVar = variable[curWave]

		}
		re.samp.vec = as.vector(re.samp)[1:bs.size]
		re.var = variable[re.samp.vec]
		re.degree = degree[re.samp.vec]

		# create data.frame

		#rd = as.data.frame(cbind(re.ID,re.var,re.RID,re.degree))
		foo = rds.set_groups_estimate(re.var, re.ID, re.RID, re.degree, method=method, group.size=group.size,
									 groups=groups, minXrec=minXrec, est.only=TRUE)
		results$P.hat[i,] = foo$P.hat
		results$adj.P.hat[i,] = foo$adj.P.hat

		#print(i)
	}
	results.ci = lapply(results, function(x) apply(x,2,"quantile", c(ci.alpha,1-ci.alpha), na.rm=TRUE ))
	results.var = lapply(results, function(x) apply(x,2,"var",na.rm=TRUE) )
	DE=list()
	DE$P.hat = results.var$P.hat/srsVar
	DE$adj.P.hat = results.var$adj.P.hat/srsVar.adj
	c( ci = results.ci, rds.var = results.var, DE = DE,
						list( trials=trials, na.P.hat=sum(is.na(results$P.hat[,1])),
						 na.adj.P.hat=sum(is.na(results$adj.P.hat[,1]))
					   )
	)
}

# Homophily Measures
# need to create and load an edgelist
# also need data loaded and indexed correctly
#
# from = apply(as.array(edges$from),1,function(x) match(x,fb$id))
# to = apply(as.array(edges$to),1,function(x) match(x,fb$id))
#
# Prints to terminal

#/////////////////////////////////////////////////////////////////////////////////////////////
#/////////////////////////////////////////////////////////////////////////////////////////////
#/////////////////////////////////////////////////////////////////////////////////////////////
#/////////////////////////////////////////////////////////////////////////////////////////////

if( FALSE ) {

rdsData = read.table("/Users/cjc73/Documents/Education/Cornell/Research/RDS/Datasets/rdsData.txt",header=TRUE)
rdsDataB = read.table("/Users/cjc73/Documents/Education/Cornell/Research/RDS/Datasets/rdsDataB.txt",header=TRUE)
jazz = read.rds("/Users/cjc73/Documents/Education/Cornell/Research/RDS/Datasets/nyjazzFinal.txt")

rdsData = as.data.frame(rdsData)

source("/Users/cjc73/Documents/Education/Cornell/Research/RDS/socMet2007/RDS.R")

source("/Users/cjc73/Documents/RDS/RDS.R")

# Homophily Measures
#
# Standard Homophily
#  if Px <= Sxx :  (Px_hat - Sxx)/( Px_hat - 1)
#  if Px > Sxx : (Sxx/Px) - 1
#

rDeg = rep(NA, length(jazz$ID))

for ( i in (1:length(jazz$ID)) ) {
	rDeg[i] = length(which(jazz$RID==jazz$ID[i]))
}

rcDeg = rep(NA, length(jazz$ID))
for ( i in (1:length(jazz$ID)) ) {
	rcDeg[i] = rDeg[match(jazz$RID[i], jazz$ID)]
}

length(which(jazz$RID==1))

urDeg = rep(NA, length(rdsData$ID))
for ( i in (1:length(rdsData$ID)) ) {
	urDeg[i] = length(which(rdsData$RID==rdsData$ID[i]))
}

urcDeg = rep(NA, length(rdsData$ID))
for ( i in (1:length(rdsData$ID)) ) {
	urcDeg[i] = urDeg[match(rdsData$RID[i], rdsData$ID)]
}

}


#!/usr/bin/env Rscript
# Author: Robert D
# 2/15/22
# Creates the requested file containing ip addresses

base <- "192.168.2."
output_file_name <- "Ec554_IPs.txt"

output_file = file(output_file_name, open = "wt")

for (i in 0:254) { # 0-254 inclusive
  writeLines(paste(base, i, sep=""), output_file)
}

close(output_file)

sprintf("Output file created: %s", output_file_name)


context("ifilter iterator")

test_that("Apply ifilter to an integer sequence", {
  is_even <- function(x) {
    x %% 2 == 0
  }
  it <- ifilter(is_even, 1:10)

  expect_equal(nextElem(it), 2)
  expect_equal(nextElem(it), 4)
  expect_equal(nextElem(it), 6)
  expect_equal(nextElem(it), 8)
  expect_equal(nextElem(it), 10)
  expect_error(nextElem(it), "StopIteration")
})

test_that("Apply ifilter to an integer sequence using anonymous function", {
  it <- ifilter(function(x) x %% 2 == 1, 1:10)

  expect_equal(nextElem(it), 1)
  expect_equal(nextElem(it), 3)
  expect_equal(nextElem(it), 5)
  expect_equal(nextElem(it), 7)
  expect_equal(nextElem(it), 9)
  expect_error(nextElem(it), "StopIteration")
})

test_that("Apply ifilter to a character vector", {
  is_vowel <- function(x) {
    x %in% c('a', 'e', 'i', 'o', 'u')
  }
  it <- ifilter(is_vowel, letters)

  expect_equal(nextElem(it), 'a')
  expect_equal(nextElem(it), 'e')
  expect_equal(nextElem(it), 'i')
  expect_equal(nextElem(it), 'o')
  expect_equal(nextElem(it), 'u')
  expect_error(nextElem(it), "StopIteration")
})


#Title: estimate_normalization_factor
#Auther: Naoto Imamachi
#ver: 1.0.0
#Date: 2015-10-07

###Estimate_normalization_factor_function###
BridgeRNormalizationFactors <- function(InputFile, group, hour, InforColumn = 4, YMin = -2, YMax = 2, MakeFig = T, figname = "BridgeR_3_Normalizaion_factor", nfname = "BridgeR_3_Normalizaion_factor"){
    ###Calc_normalization_factor###
    group_number <- length(group)
    time_points <- length(hour)
    input_file <- fread(InputFile, header=T)

    for(a in 1:group_number){
        ###Information&exp_data column###
        infor_st <- 1 + (a - 1)*(time_points + InforColumn)
        infor_ed <- (InforColumn)*a + (a - 1)*time_points
        exp_st <- infor_ed + 1
        exp_ed <- infor_ed + time_points

        hour_label <- NULL
        for(x in hour){
            label <- x
            if(x < 10){
                label <- paste("0",x,sep="")
            }
            hour_label <- append(hour_label, paste("T", label, "_", a, sep=""))
        }

        quantile_99_data <- NULL
        quantile_95_data <- NULL
        for(x in exp_st:exp_ed){
            each_time_exp <- input_file[[x]]
            each_time_quantile_99 <- quantile(each_time_exp, prob=0.99, na.rm=T) #99th_percentile
            each_time_quantile_95 <- quantile(each_time_exp, prob=0.975, na.rm=T) #95th_percentile
            quantile_99_data <- append(quantile_99_data, each_time_quantile_99)
            quantile_95_data <- append(quantile_95_data, each_time_quantile_95)
        }

        output_filename <- paste(nfname, "_",group[a],".txt", sep="")
        cat('Percentile',hour_label, sep="\t", file=output_filename)
        cat("\n", file=output_filename, append=T)
        cat('99%_percentale',quantile_99_data, sep="\t", file=output_filename, append=T)
        cat("\n", file=output_filename, append=T)
        cat('97.5%_percentale',quantile_95_data, sep="\t", file=output_filename, append=T)
        cat("\n", file=output_filename, append=T)

        if(MakeFig == TRUE){
            quantile_99_data <- log10(as.vector(quantile_99_data)) #
            quantile_95_data <- log10(as.vector(quantile_95_data)) #
            plot_data_quantile_99 <- data.frame(hour,quantile_99_data)
            plot_data_quantile_95 <- data.frame(hour,quantile_95_data)

            ###Plot_stable_genes_exp###
            figfile <- paste(figname,"_",group[a],".png", sep="")

            gene_number <- length(input_file[[1]])
            exp_data <- as.matrix(input_file[,exp_st:exp_ed, with=F])
            exp_data <- t(exp_data) #Inverse
            exp_data <- factor(exp_data)
            exp_data <- as.numeric(as.character(exp_data))
            exp_data <- log10(exp_data) #
            time_data <- as.numeric(rep(hour,gene_number))
            class_data <- NULL
            for (x in 1:gene_number){
                class_data <- append(class_data, rep(x, time_points))
            }
            plot_data <- data.frame(class_data,time_data,exp_data)
            #plot_data <- plot_data[1:6000,] ##test

            png(filename=figfile,width = 1200, height = 1200)

            p.scatter <- ggplot()
            p.scatter <- p.scatter + geom_line(data=plot_data,
                                           mapping=aes(x=time_data, y=exp_data, group=class_data),
                                           colour="black",
                                           size=0.02,
                                           alpha=0.05)
            p.scatter <- p.scatter + geom_line(data=plot_data_quantile_99,
                                           mapping=aes(x=hour, y=quantile_99_data),
                                           colour="red",
                                           size=0.5,
                                           alpha=1)
            p.scatter <- p.scatter + geom_line(data=plot_data_quantile_95,
                                           mapping=aes(x=hour, y=quantile_95_data),
                                           colour="blue",
                                           size=0.5,
                                           alpha=1)
            p.scatter <- p.scatter + xlim(0,max(plot_data$time_data)) + ylim(YMin, YMax)
            p.scatter <- p.scatter + ggtitle("All genes distribution")
            p.scatter <- p.scatter + xlab("Time course")
            p.scatter <- p.scatter + ylab("Relative RPKM (Time0 = 1)")
            plot(p.scatter)

            dev.off() #close_fig
            plot.new()
        }
    }
}


#' RT
#'
#' Computes the value of Required Recovery Time following scheme adopted in ISO 11079. Valid under 10 Celsius degree.
#'
#' @param t numeric    Air temperature in degC.
#' @param rh numeric   Relative humidity in percentage.
#' @param wind numeric Windspeed in meter per second.
#' @param trad numeric Mean radiant temperature in degC.
#' @param M numeric    Metabolic work in Watt per mq of the subject.
#' @param W   numeric  Mechanical work rate in Watt per mq of the subject.
#' @param clo numeric  Available basic clothing insulation in clo.
#' @param p  numeric   Air permeability of clothing ensemble lt on meters per second.
#' @param w  numeric   Walking speed in meters per second.
#' @return  Required Recovery Time
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @author  Ingvar Holmer. R adaptation Istituto di Bioeconomia Firenze Italy  Alfonso Crisci \email{a.crisci@@ibe.cnr.it}
#' @keywords Recovery Time.
#' @references ISO 11079, 2007-12-15, ERGONOMICS OF THE THERMAL ENVIRONMENT - DETERMINATION AND INTERPRETATION OF COLD STRESS WHEN USING REQUIRED CLOTHING INSULATION (IREQ) AND LOCAL COOLING EFFECTS.
#'
#' @export
#'
#'
#'
#'

RT=function(t,rh,wind,trad,M,W,clo,p,w) {
                         ct$assign("t", as.array(t))
                         ct$assign("rh", as.array(rh))
                         ct$assign("v", as.array(wind))
                         ct$assign("Tr", as.array(trad))
                         ct$assign("M", as.array(M))
                         ct$assign("W", as.array(W))
                         ct$assign("Icl", as.array(clo))
                         ct$assign("p", as.array(p))
                         ct$assign("w", as.array(w))
                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=RT(Ta[i],rh[i],v[i],Tr[i],M[i],W[i],Icl[i],p[i],w[i])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


nbp2 <- 7
data2 <- "mask"

# maskdir <- paste0(parentdir, "/motif_counts/", nbp2, "bp_", bink, "k_singletons_", data2)
# maskbinfile <- paste0(datadir, "/full_motif_counts_", bin_scheme, ".txt")
maskdir <- paste0(parentdir, "/motif_counts/", nbp2, "-mers/mask")
p1 <- "motifs_mask.txt"
maskbins <- get_bins(maskdir, p1)

# maskbins <- read.table(maskbinfile, header=T, stringsAsFactors=F, check.names=F)
maskmct <- get_mct(maskbins)

cbp <- 5
i <- 3
masktmp <- full_data$sites %>%
	filter(MASK==0) %>%
	mutate(SEQA=substr(Motif, cbp-i, cbp+i),
		SEQB=substr(Motif, cbp*3-i, cbp*3+i),
		Motif=paste0(SEQA, "(", SEQB, ")"))

maskaggseq <- get_aggseq(masktmp, maskmct)
rm(masktmp)

maskgpdat <- maskaggseq %>%
  mutate(Type=gsub("cpg_", "", Category2)) %>%
  dplyr::select(Type, Motif,
		nERVs_mask=nERVs, nMotifs_mask=nMotifs,
		ERV_rel_rate_mask=rel_prop)

maskgpdat <- merge(ratelist[[4]], maskgpdat, by=c("Type", "Motif"))

test_mask <- maskgpdat %>%
	filter(nERVs >= 10 & nERVs_mask >= 10) %>%
  # mutate(pval=prop.test())
  group_by(Type, Motif) %>%
  do(tidy(prop.test(c(.$nERVs, .$nERVs_mask), c(.$nMotifs, .$nMotifs_mask)))) %>%
	dplyr::select(Type, Motif, estimate1, estimate2, statistic, p.value)

test_mask <- merge(test_mask, maskgpdat, by=c("Type", "Motif"))

sig_mask <- test_mask %>%
  filter(p.value<0.05/nrow(test_mask)) %>%
  mutate(prop=estimate1/estimate2,
    gt10=ifelse(abs(log(prop))>log(1.2), TRUE, FALSE)) %>%
	filter(gt10==TRUE) %>%
	arrange(desc(prop))

# sig_mask %>%
# 	group_by(gt10) %>%
#   summarise(n=n())


#' Full ShellChron workflow wrapped in a single function
#'
#' Takes starting parameters and names of input files
#' and directory and runs through all the steps of the
#' ShellChron model. Function includes options for plotting
#' and exporting raw data, which are parsed into underlying
#' formulae.
#' @param path String containing the path to the directory
#' that contains the input data.
#' @param file_name Name of the file that contains d18O data
#' @param transfer_function String containing the name of the
#' transfer function. Defaults to Kim and O'Neil, 1997.
#' @param t_int Time interval (in days; default = 1)
#' @param T_per Period of SST sinusoid (in days;
#' default = 365)
#' @param d18Ow Either a single value (constant d18Ow)
#'  or a vector of length equal to the period in SST data
#' (365 days by default) containing information about
#' seasonality in d18Ow. Defaults to constant d18Ow of
#' 0 permille VSMOW (the modern mean ocean value)
#' @param t_maxtemp Timing of the warmest day of the year
#' (in julian day; default = 182.5, or May 26th halfway
#' through the year)
#' @param SCEUApar Parameters for SCEUA optimization (iniflg, ngs, maxn, kstop
#' pcento, peps) For details, refer to Duan et al. (1992) in references
#' @param sinfit Apply sinusoidal fitting to guess initial parameters for SCEUA
#' optimization? \code{TRUE/FALSE}
#' @param MC Number of Monte Carlo simulations to apply for
#' error propagation. Default = 1000
#' @param plot Should an overview of the results of modeling
#' be plotted? \code{TRUE/FALSE}
#' @param plot_export Should the overview plot be exported as
#' a PDF file? \code{TRUE/FALSE}
#' @param export_raw Export tables containing all raw model
#' results before being merged into tidy tables? \code{TRUE/FALSE}
#' @param export_path Path where result files are exported
#' @return CSV tables of model results in the current working
#' directory, optional plots in PDF format and list object of
#' model results for further processing in the R workspace.
#' @references function dependencies: data_import, run_model, cumulative_day,
#' export_results
#' @importFrom grDevices dev.new dev.off pdf
#' @importFrom graphics lines points
#' @importFrom stats D approx lm loess pf qt rnorm sd spectrum ts weighted.mean
#'     window
#' @importFrom utils capture.output head read.csv tail write.csv
#' @examples
#' # find attached dummy data
#' \donttest{example <- wrap_function(path = getwd(),
#'     file_name = system.file("extdata", "Virtual_shell.csv",
#'     package = "ShellChron"),
#'     transfer_function = "KimONeil97",
#'     t_int = 1,
#'     T_per = 365,
#'     d18Ow = 0,
#'     t_maxtemp = 182.5,
#'     SCEUApar = c(1, 25, 10000, 5, 0.01, 0.01),
#'     sinfit = TRUE,
#'     MC = 1000,
#'     plot = FALSE,
#'     plot_export = FALSE,
#'     export_raw = FALSE,
#'     export_path = tempdir())} # Run function
#' @export
wrap_function <- function(path = getwd(), # Wrapping function for the entire model package
    file_name, # Give file name (don't forget to add the extention, should be in CSV format)
    transfer_function = "KimONeil97", # Set transfer function of the record, default is Kim and O'Neil 1997.
    t_int = 1, # Set time interval in days
    T_per = 365, # Set annual time period in days (default = 365)
    d18Ow = 0, # Set d18Ow value or vector (default = constant year-round at 0 VSMOW). Alternative options are either one value (assumed constant year-round) or a vector with length T_per / t_int and interval t_int specifying d18Ow evolution through one year.
    t_maxtemp = 182.5, # Define the day of the year at which temperature is heighest. Default = Assume that the day of maximum temperature is helfway through the year
    SCEUApar = c(1, 25, 10000, 5, 0.01, 0.01), # Set parameters for SCEUA optimization (iniflg, ngs, maxn, kstop, pcento, peps)
    sinfit = TRUE, # Apply sinusoidal fitting to guess initial parameters for SCEUA optimization? (TRUE/FALSE)
    MC = 1000, # Number of MC simulations to include measurement error into error analysis. Default = 1000 (if MC = 0, error on D and d18O measurements not considered)
    plot = TRUE, # Should intermediate plots be given to track progress? WARNING: plotting makes the script much slower, especially for long datasets.
    plot_export = TRUE, # Should a plot of the results be saved as PDF?
    export_raw = FALSE, # Should the results of all individual model runs be exported as CSV files?
    export_path = getwd() # Path where result files are exported
    ){

    oldwd <- getwd()
    on.exit(setwd(oldwd))

    # STEP 1: Import data
    setwd(path)
    importlist <- data_import(file_name)
    if(length(importlist) != 2){ # Catch errors in the input data
        return("ERROR: Input data does not match the default input data format")
    }
    dat <- importlist[[1]]
    dynwindow <- importlist[[2]]
    G_per <- T_per # Period of growth rate sinusoid should equal that of the temperature sinusoid (which is given)

    # STEP 2: Run the model
    resultlist <- run_model(dat, dynwindow, transfer_function, d18Ow, T_per, G_per, t_int, t_maxtemp, SCEUApar, sinfit, MC, plot = TRUE)
    resultarray <- resultlist[[1]]
    parmat <- resultlist[[2]]

    # STEP 3: Align model results to cumulative timescale
    print("Calculating cumulative day of the year results...")
    suppressWarnings(resultarray[, , 3] <- cumulative_day(resultarray, TRUE, TRUE, export_path)) # Calculate cumulative day of the year for all model runs and replace matrix in result array

    # STEP 4: Order and export results and statistics
    export_results(export_path, dat, resultarray, parmat, MC, dynwindow, plot, plot_export, export_raw) # Export results of model
    return(resultlist)
}


{{rimport}}('__init__.r', 'plot.r')

infile  = {{i.infile | R}}
outfile = {{o.outfile | R}}
outdir  = {{o.outdir | R}}
inopts  = {{args.inopts | R}}
params  = {{args.params | R}}
devpars = {{args.devpars | R}}
ggs     = {{args.ggs | R}}

indata = read.table.inopts(infile, inopts)

params$returnAUC = T
plotfile = file.path(outdir, '{{i.infile | fn}}.roc.png')
aucs = plot.roc(indata, plotfile, stacked = F, params = params, ggs = ggs, devpars = devpars)
aucs = t(as.data.frame(aucs))
write.table(pretty.numbers2(aucs, . = '%.3f'), outfile, sep = "\t", quote = F, col.names = F, row.names = T)


#!/usr/bin/env Rscript
# For https://github.com/berkeley-dsep-infra/datahub/issues/2556
# For https://github.com/berkeley-dsep-infra/datahub/issues/2524
# For https://github.com/berkeley-dsep-infra/datahub/issues/2748
# Fall 2021
print("Installing packages for PH 252")

source("/tmp/class-libs.R")

class_name = "PH 252"

class_libs = c(
  "foreign", "0.8-81",
  "blm", "2013.2.4.4"
)

devtools::install_github('cran/epi', ref='06efd3f', upgrade_dependencies=FALSE, quiet=FALSE)
devtools::install_github('kaz-yos/tableone', ref='7cfcd71', upgrade_dependencies=FALSE, quiet=FALSE)

class_libs_install_version(class_name, class_libs)

print("Done installing packages for PH 252")


#' Populate Date Columns
#'
#' Creates various date columns for WRTDS study.
#'
#' @param rawData vector with dateTime
#' @return DateFrame dataframe
#' @export
#' @examples
#' dateTime <- c('1984-02-28 13:56',
#'               '1984-03-01 00:00',
#'               '1986-03-01 00:00',
#'               '1986-10-15 00:00')
#'
#' expandedDateDF <- populateDateColumns(dateTime)
#' expandedDateDF
#'
#' dateTime <- c('1984-02-28',
#'               '1984-03-01',
#'               '1986-03-01',
#'               '1986-10-15')
#' expandedDateDF <- populateDateColumns(dateTime)
#' expandedDateDF
populateDateColumns <- function(rawData){  # rawData is a vector of dates
  DateFrame <- as.data.frame(matrix(ncol=1,nrow=length(rawData)))
  colnames(DateFrame) <- c('Date')
  DateFrame$Date <- rawData
  dateTime <- as.POSIXlt(rawData)
  DateFrame$Julian <- as.numeric(julian(dateTime,origin=as.Date("1850-01-01")))
  DateFrame$Month <- dateTime$mon + 1
  DateFrame$Day <- dateTime$yday + 1
  year <- dateTime$year + 1900
  hour <- dateTime$hour
  minute <- dateTime$min

  if (sum(hour) == 0 & sum(minute) == 0){
    dateTime$hour <- rep(12,length(dateTime))
  }

  leapOffset <- ifelse((year%%4 == 0) & ((year%%100 != 0) | (year%%400 == 0)), 0,1)

  DateFrame$Day[DateFrame$Day > 59] <- DateFrame$Day[DateFrame$Day > 59] + leapOffset[DateFrame$Day > 59]

  DateFrame$DecYear <- decimalDate(dateTime)
  DateFrame$MonthSeq <- ((year-1850)*12)+DateFrame$Month
  DateFrame$waterYear <- as.integer(DateFrame$DecYear)
  DateFrame$waterYear[DateFrame$Month %in% c(10:12)] <- DateFrame$waterYear[DateFrame$Month %in% c(10:12)]+1

  return (DateFrame)

}

#' decimalDate
#'
#' Create a decimal date or date/time from a vector.
#'
#' @export
#' @param rawData vector of dates or dateTimes.
#' @examples
#' dateTime <- c('1984-02-28 13:56',
#'               '1984-03-01 00:00',
#'               '1986-03-01 00:00',
#'               '1986-10-15 00:00')
#' decimalDate(dateTime)
#'
#' dateTime <- c('1984-02-28',
#'               '1984-03-01',
#'               '1986-03-01',
#'               '1986-10-15')
#' decimalDate(dateTime)
decimalDate <- function(rawData){

  dateTime <- as.POSIXlt(rawData)
  year <- dateTime$year + 1900

  startYear <- as.POSIXct(paste0(year,"-01-01 00:00"))
  endYear <- as.POSIXct(paste0(year+1,"-01-01 00:00"))

  DecYear <- year + as.numeric(difftime(dateTime, startYear, units = "secs"))/as.numeric(difftime(endYear, startYear, units = "secs"))
  return(DecYear)
}


#  James Rekow

conChrtDensDiffPlotObj = function(M = 80, N = 20, iStrength = 1, univ = 1, sigmaMax = 0.1,
                                 thresholdMult = 10 ^ (-1), maxSteps = 10 ^ 4, tStep = 10 ^ (-2),
                                 intTime = 1, interSmplMult = 0.01, lambda = 10 ^ (-1),
                                 conGraph = NULL, graphType = "gnp", meanDegree = 4,
                                 synthM = floor(M / 4), numSynthChrt = 10, dispPlots = FALSE,
                                 numSample = 100, maxIters = 100){

  #  ARGS: conGraph - supplied connectivity graph
  #        graphMethod - method to use to create conGraph if one is not supplied
  #        graphArgs - arguments to pass to the graphMethod
  #        synthM - number of samples in each synthetic cohort
  #        numSynthChrt - number of synthetic cohorts (there will be this many of both the
  #                       interacting and non-interacting cohorts)
  #        dispPlots - if TRUE, a plot of the interacting samples in conGraph and a plot
  #                    of the density difference will be displayed. If FALSE, the ggplot
  #                    object corresponding to the density difference plot will be returned,
  #                    but nothing will be displayed.
  #
  #  RETURNS: a ggplot object displaying the difference between the 2D density of the aggregate OD NS
  #           points of the interacting synthetic cohorts and the non-interacting synthetic cohorts.

  #  import libraries and functions
  library(igraph)
  library(snow)
  source("conGraphCreator.r")
  source("abdListCreator.r")
  source("DOCProcedure.r")
  source("conSynthChrtCreator.r")
  source("DOCNSSelector.r")
  source("plotDensDiff.r")

  ##  check that all of the information supplied to create conGraph is valid and consistent

  #  check which conGraph related inputs have been supplied
  suppliedGraph = !is.null(conGraph)

  #  if conGraph was supplied, check that it is valid
  if(suppliedGraph){

    #  warn user that extraneous parameters will be ignored if conGraph is already given
    if(suppliedMethod || suppliedArgs){
      warning("conGraph was supplied, so graphMethods and graphArgs will be ignored.")
    } #  end if

    #  check that conGraph is undirected
    if(is.directed(conGraph)){
      stop("conGraph must be undirected.")
    } #  end if

    #  check that conGraph has the appropriate number of vertices
    if(length(V(conGraph)) != M){
      stop("conGraph must have M vertices.")
    } #  end if

  } #  end if suppliedGraph

  #  if conGraph is not supplied, create conGraph using graphType and meanDegree
  if(!suppliedGraph){

    conGraph = conGraphCreator(graphType = graphType, meanDegree = meanDegree, v = M)

  } #  end if !suppliedGraph

  #  create abundance list after interacting cohort using the connectivity given in conGraph
  abdList = abdListCreator(M = M, N = N, iStrength = iStrength, univ = univ, sigmaMax = sigmaMax,
                           thresholdMult = thresholdMult, maxSteps = maxSteps, tStep = tStep,
                           intTime = intTime, interSmplMult = interSmplMult, lambda = lambda,
                           returnParams = FALSE, conGraph = conGraph)

  #  create a synthetic cohort from abdList and return the points in the NS region of the OD
  #  plane
  #  create a data frame of the aggregate OD NS region points from numSynthChrt number of
  #  synthetic cohorts
  produceSynthDOCNSDF = function(int){

    #  create synthetic cohort
    synthChrtList = conSynthChrtCreator(synthM = synthM, conGraph = conGraph, abdList = abdList,
                                        int = int, numSample = numSample, maxIters = maxIters,
                                        numSynthChrt = numSynthChrt)

    #  function to create a DOC for a synthetic cohort and remove points in the DOC that are outside
    #  the NS region
    produceNSPoints = function(synthChrt) DOCNSSelector(DOCProcedure(synthChrt))

    #  create a list of DOCNS's by applying produceNSPoints to the list of synthetic cohorts
    docList = lapply(synthChrtList, produceNSPoints)

    #  create vectors of aggregate overlap and dissimilarity values (e.g. combine overlap values from
    #  each synthetic cohorts NS region into a single vector, similarly for dissimilarity values)
    aggOver = unlist(lapply(docList, "[[", 1))
    aggDiss = unlist(lapply(docList, "[[", 2))

    #  create a DOCNS data frame using the aggregate overlap and dissimilarity vectors
    DOCNSDF = data.frame(x = aggOver, y = aggDiss)

    return(DOCNSDF)

  } #  end produceSynthDOCNS function

  #  produce a list of the aggregate data frames containing the OD NS points from the
  #  non-interacting and interacting synthetic cohorts
  docDFList = lapply(list(FALSE, TRUE), produceSynthDOCNSDF)

  #  create ggplot object corresponding to density difference plot between the aggregate
  #  OD NS points
  p = plotDensDiff(docDFList[[1]], docDFList[[2]])

  #  if dispPlots is TRUE, plot conGraph and the density difference plot
  if(dispPlots){
    #  fix the subgraph display to only display interacting vertices. Might have to do
    #  this manually
    dispGraph = delete_vertices(conGraph, (1:M)[-unique(ends(conGraph, E(conGraph)))])
    conGraphLayout = layout_with_fr(dispGraph)
    plot(dispGraph, vertex.size = 10, vertex.color = "orangered", vertex.label = NA,
         edge.color = "orangered", layout = conGraphLayout)

    dev.new()
    plot(p)

  } #  end if dispPlots

  return(p)

} #  end conChrtDensDiffPlotObj function


########----- Network Gadus morhua ------########
####
library(magrittr)
library(webshot)
library(htmlwidgets)
library(DiagrammeR)
library(igraph)

library(showtext)
showtext.auto()
xx <- font.files()
font.add(family = 'Triforce', regular = 'Triforce.ttf')
font.add(family = 'regText', regular = 'Alegreya-Regular.otf')
# font.add(family = 'Hylia', regular = 'HyliaSerifBeta-Regular.otf')
font.add(family = 'HylianSymbols', regular = 'HylianSymbols.ttf')

subweb2 <- plotMean[subnet,subnet]
# # Eliminer associations < 0.4
# for (i in 1:nrow(subweb)) {
#   for (j in 1:ncol(subweb)) {
#     if (subweb2[i,j] > -.4 & subweb2[i,j] < .4) subweb2[i,j] = 0
#   }
# }
subweb2 <- subweb2[which(subweb > 0)] # sélectionner uniquement les liens relevés pour la figure 1

# vec_colfont <- rep("white",nsp)
# vec_colfont[-id] <- "black"
# sp_nm <- "cracreflé"
netw2 <-  graph_from_adjacency_matrix(t(subweb2))

arrowWidth <- (abs(subweb2)/min(abs(subweb2)))/50

# Colour <- colorRampPalette(c("blue", "white", "red"))(200)
rbPal <- colorRampPalette(c('red','white', 'blue')) # color palette
cols <- rbPal(50)[as.numeric(cut(subweb2, breaks = 50))]

##

# png(paste0("./fig/cracreflé2.png"), width=7, height=9, units="in", res=300)
  layout(matrix(c(1,2), 2, 1), height=c(.8,.2))
  par(bg="transparent", mar=rep(0.4,4), fg="black", family = 'regText')
  plot(netw,
    vertex.color = vec_col,
    vertex.frame.color = "transparent",
    vertex.label.color = "black",
    vertex.label = vec_names,
    vertex.size = vec_size,
    # edge.width = 1+3*log(links$weight/min(links$weight)),
    edge.arrow.size = 0,
    edge.width = arrowWidth,
    edge.color = cols
    # edge.color = factor(links$from, levels=levels(as.factor(nodes$id)))
    )
  plot0()
  legend("center", bty="n", legend=sort(unique(grptax)), cex=1.2, pch=21, ncol=2,
  pt.bg=pal, col=pal, pt.cex=2.4)
    # layout = coords)
# dev.off()

## Legend
nms <- colnames(subweb)[-id]
leg_txt <- ""
for (i in 1:length(nms)){
  leg_txt %<>% paste0(i, "-", nms[i], "; ")
}
nms <- colnames(subweb)[id]
for (i in 1:length(nms)){
  leg_txt %<>% paste0(c("PB", "CO", "HH")[i], "-", nms[i], "; ")
}


#!/usr/bin/env Rscript
source("common.r")

checkWaveParams <- function(parameters) {
    checkWave <- 0
    if (!(parameters$parameters$wThresholdDirection == "above" | parameters$parameters$wThresholdDirection == "below")) {
        write("Error: threshold direction should either be above or below",stderr())
    } else if (!(parameters$parameters$pThresholdDirection == "above" | parameters$parameters$pThresholdDirection == "below")) {
        write("Error: pThreshold direction should either be above or below",stderr())
    } else if (!(parameters$parameters$tThresholdDirection == "above" | parameters$parameters$tThresholdDirection == "below")) {
        write("Error: tThreshold direction should either be above or below",stderr())
    } else if (parameters$parameters$wThreshold>1 | parameters$parameters$wThreshold < 0) {
        write("Error: wThreshold should lie within 0 and 1",stderr())
    } else if (parameters$parameters$pThreshold < 1 ) {
        write("Error: pThreshold should be greater than 1",stderr())
    } else if (parameters$parameters$tThreshold < 1 ) {
        write("Error: tThreshold should be greater than 1",stderr())
    } else if (parameters$parameters$ampThreshold>1 | parameters$parameters$ampThreshold < 0) {
        write("Error: ampThreshold should lie within 0 and 1",stderr())
    } else if (parameters$parameters$accThreshold>1 | parameters$parameters$accThreshold < 0) {
        write("Error: accThreshold should lie within 0 and 1",stderr())
    } else if (parameters$parameters$minLength < 0) {
        write("Error: minLength should be greater than 0",stderr())
    } else if (parameters$parameters$accPortion1>1 | parameters$parameters$accPortion1 < 0) {
        write("Error: accPortion1 should lie within 0 and 1",stderr())
    } else if (parameters$parameters$accPortion2>1 | parameters$parameters$accPortion2 < 0) {
        write("Error: accPortion2 should lie within 0 and 1",stderr())
    } else if (parameters$parameters$accPortion3>1 | parameters$parameters$accPortion3 < 0) {
        write("Error: accPortion3 should lie within 0 and 1",stderr())
    } else if (parameters$parameters$strictness>1 | parameters$parameters$strictness < 0) {
        write("Error: strictness should lie within 0 and 1",stderr())
    } else {
        checkWave <- 1
    }
    return (checkWave)
}

findWave <- function(panel,parameters){
    # panel <- as.numeric(as.character(panel))
    write("Calculating entropy",stderr())

    panel$`acceleration:z`<- as.numeric(as.character(panel$`acceleration:z`))
    panel$`rotationrate:x`<- as.numeric(as.character(panel$`rotationrate:x`))
    panel$`magneticfield:x`<- as.numeric(as.character(panel$`magneticfield:x`))
    panel$`gps:speed`<- as.numeric(as.character(panel$`gps:speed`))

    parameters$strictness <- 1-parameters$strictness
    parameters$wThreshold <- parameters$wThreshold - (parameters$strictness/5)
    parameters$accPortion1 <- parameters$accPortion1 - (parameters$strictness/5)
    parameters$accPortion2 <- parameters$accPortion2 - (parameters$strictness/10)

    wEntropy <- findSpecEntropy(panel$`acceleration:z`,
                                parameters$windowSize,
                                parameters$overlapStep,
                                1)

    tEntropy <- findSpecEntropy(panel$`magneticfield:x`,
                                parameters$windowSize,
                                parameters$overlapStep,
                                1)

    pEntropy <- findSpecEntropy(panel$`rotationrate:x`,
                                parameters$windowSize,
                                parameters$overlapStep,
                                1)

    write("Calculating event labels",stderr())
    wave <- getEvent(           panel$`acceleration:z`,
                                wEntropy$Entropy,
                                parameters$wThresholdDirection,
                                parameters$wThreshold,
                                parameters$windowSize)
    paddle <- getEvent(         panel$`rotationrate:x`,
                                pEntropy$Entropy,
                                parameters$pThresholdDirection,
                                parameters$pThreshold,
                                parameters$windowSize)
    tailSlide <- getEvent(      panel$`magneticfield:x`,
                                tEntropy$Entropy,
                                parameters$tThresholdDirection,
                                parameters$tThreshold,
                                parameters$windowSize)

    waveNtap <- removeTaps(     wave,
                                panel$`gps:speed`,
                                panel$`acceleration:z`,
                                parameters$maxAcc,
                                parameters$maxAcc2,
                                parameters$speedThresh,
                                parameters$accPortion1,
                                parameters$accPortion2,
                                parameters$accPortion3)

    write("Calculating the time stamps of the wave labels",stderr())
    wOutLabels <- outputLabels( waveNtap$wave,
                                parameters$windowSize,
                                panel$time,
                                parameters$wMergeThreshold)
    pOutLabels <- outputLabels( paddle,
                                parameters$windowSize,
                                panel$time,
                                parameters$pMergeThreshold)
    tOutLabels <- outputLabels( tailSlide,
                                parameters$windowSize,
                                panel$time,
                                parameters$tMergeThreshold)

    write("Converting results to JSON", stderr())

    results <- list()
    if ( wOutLabels$startTime == 0 && wOutLabels$endTime == 0 ) {
        results <- vector()
    } else {
        for (i in 1:length(wOutLabels$startTime)) {
            for ( j in 1:length(pOutLabels$endTime) ) {
                if ((pOutLabels$startTime[j]<wOutLabels$startTime[i])
                                && (pOutLabels$endTime[j]>wOutLabels$startTime[i])
                                && (pOutLabels$endTime[j]<wOutLabels$endTime[i])) {
                    wOutLabels$startTime[i]<-pOutLabels$endTime[j]
                }
            }

            for ( k in 1:length(tOutLabels$startTime) ) {
                if ((tOutLabels$startTime[k]<wOutLabels$endTime[i])
                                && (tOutLabels$startTime[k]>wOutLabels$startTime[i])
                                && (tOutLabels$endTime[k]>wOutLabels$endTime[i])) {
                    wOutLabels$endTime[i]<-tOutLabels$startTime[k]
                }
            }

            labelList<-list(
                startTime=unbox(wOutLabels$startTime[i]),
                endTime=unbox(wOutLabels$endTime[i]),
                type=unbox(parameters$eventType))
            results <- append(results, list(labelList)) # Convert to list objects
        }
    }

    return (results)
}

# wave filter to remove the false positives
removeTaps <- function(wave,gpsSpeed,accZ,maxAcc,maxAcc2,speedThresh,accPortion1,accPortion2,accPortion3) {

    gpsSpeed[which(is.na(gpsSpeed))]<-0
    transList <- findTransition(wave)
    wStartTimes <- transList$wStartTimes
    wEndTimes <- transList$wEndTimes

    # New variable
    waveNew<-wave

    # Filtering
    for (i in 1:length(wStartTimes)) {

        maxAccZ<-max(accZ[wStartTimes[i]:wEndTimes[i]])
        maxSpeed<-max(gpsSpeed[wStartTimes[i]:wEndTimes[i]])

        speedAbvThresh<-0
        accAbvThresh2<-0

        if (maxAccZ>maxAcc) {
            accAbvThresh <- (length(which(accZ[wStartTimes[i]:wEndTimes[i]]>(maxAcc)))
                                                    /(wEndTimes[i]-wStartTimes[i]))
            accAbvThresh2 <- (length(which(accZ[wStartTimes[i]:wEndTimes[i]]>(maxAcc2)))
                                                    /(wEndTimes[i]-wStartTimes[i]))

            if (maxSpeed>(speedThresh)*max(gpsSpeed)) {
                speedAbvThresh<-length(
                    which(gpsSpeed[wStartTimes[i]:wEndTimes[i]]>
                            (speedThresh*max(gpsSpeed))))
            } else {
                speedAbvThresh <- -1
            }

        } else {
            accAbvThresh<-0
        }

        if (accAbvThresh > accPortion1 ) {
            waveNew[wStartTimes[i]:wEndTimes[i]]<-1
        } else if ( accAbvThresh > accPortion2 & speedAbvThresh > 1) {
            waveNew[wStartTimes[i]:wEndTimes[i]]<-1
        } else if ( speedAbvThresh==-1 & accAbvThresh2> accPortion2 ) {
            waveNew[wStartTimes[i]:wEndTimes[i]]<-1
        } else {
            waveNew[wStartTimes[i]:wEndTimes[i]]<-0
        }
    }

    # speed<-gpsSpeed
    # speed[which(speed<ampThreshold*max(speed))]<-0

    # tap<-rep(0,length(wave))

    # tap[which(wave==1 & (accZ<accThreshold | speed==0))]<-1
    # tap[which(accZ>accThreshold && tap==1)]<-0
    # wave[which(tap==1)]<-0
    # wave[which(wave==1 & speed==0)]<-0

    waveNtap<-list(wave=waveNew)#,tap=tap)
    return(waveNtap)
}


#!/usr/local/bin/env Rscript --vanilla
args <- commandArgs(TRUE)
if (is.null(args[1])) {
  stop("No expression matrix provided!")
}

if (is.null(args[2])) {
  stop("No signature matrix provided!")
}

# CIBERSORT R script v1.04 (last updated 10-24-2016)
# Note: Signature matrix construction is not currently available; use java version for full functionality.
# Author: Aaron M. Newman, Stanford University (amnewman@stanford.edu)
# Requirements:
#       R v3.0 or later. (dependencies below might not work properly with earlier versions)
#       install.packages('e1071')
#       install.pacakges('parallel')
#       install.packages('preprocessCore')
#       if preprocessCore is not available in the repositories you have selected, run the following:
#           source("http://bioconductor.org/biocLite.R")
#           biocLite("preprocessCore")
# Windows users using the R GUI may need to Run as Administrator to install or update packages.
# This script uses 3 parallel processes.  Since Windows does not support forking, this script will run
# single-threaded in Windows.
#
# Usage:
#       Navigate to directory containing R script
#
#   In R:
#       source('CIBERSORT.R')
#       results <- CIBERSORT('sig_matrix_file.txt','mixture_file.txt', perm, QN, absolute, abs_method)
#
#       Options:
#       i)   perm = No. permutations; set to >=100 to calculate p-values (default = 0)
#       ii)  QN = Quantile normalization of input mixture (default = TRUE)
#       iii) absolute = Run CIBERSORT in absolute mode (default = FALSE)
#               - note that cell subsets will be scaled by their absolute levels and will not be
#                 represented as fractions (to derive the default output, normalize absolute
#                 levels such that they sum to 1 for each mixture sample)
#               - the sum of all cell subsets in each mixture sample will be added to the ouput
#                 ('Absolute score'). If LM22 is used, this score will capture total immune content.
#       iv)  abs_method = if absolute is set to TRUE, choose method: 'no.sumto1' or 'sig.score'
#               - sig.score = for each mixture sample, define S as the median expression
#                 level of all genes in the signature matrix divided by the median expression
#                 level of all genes in the mixture. Multiple cell subset fractions by S.
#               - no.sumto1 = remove sum to 1 constraint
#
# Input: signature matrix and mixture file, formatted as specified at http://cibersort.stanford.edu/tutorial.php
# Output: matrix object containing all results and tabular data written to disk 'CIBERSORT-Results.txt'
# License: http://cibersort.stanford.edu/CIBERSORT_License.txt

#dependencies
library(e1071)
library(parallel)
library(preprocessCore)

#Core algorithm
CoreAlg <- function(X, y, absolute, abs_method){

  #try different values of nu
  svn_itor <- 3

  res <- function(i){
    if(i==1){nus <- 0.25}
    if(i==2){nus <- 0.5}
    if(i==3){nus <- 0.75}
    model<-svm(X,y,type="nu-regression",kernel="linear",nu=nus,scale=F)
    model
  }

  if(Sys.info()['sysname'] == 'Windows') out <- mclapply(1:svn_itor, res, mc.cores=1) else
    out <- mclapply(1:svn_itor, res, mc.cores=svn_itor)

  nusvm <- rep(0,svn_itor)
  corrv <- rep(0,svn_itor)

  #do cibersort
  t <- 1
  while(t <= svn_itor) {
    weights = t(out[[t]]$coefs) %*% out[[t]]$SV
    weights[which(weights<0)]<-0
    w<-weights/sum(weights)
    u <- sweep(X,MARGIN=2,w,'*')
    k <- apply(u, 1, sum)
    nusvm[t] <- sqrt((mean((k - y)^2)))
    corrv[t] <- cor(k, y)
    t <- t + 1
  }

  #pick best model
  rmses <- nusvm
  mn <- which.min(rmses)
  model <- out[[mn]]

  #get and normalize coefficients
  q <- t(model$coefs) %*% model$SV
  q[which(q<0)]<-0
  if(!absolute || abs_method == 'sig.score') w <- (q/sum(q)) #relative space (returns fractions)
  if(absolute && abs_method == 'no.sumto1') w <- q #absolute space (returns scores)

  mix_rmse <- rmses[mn]
  mix_r <- corrv[mn]

  newList <- list("w" = w, "mix_rmse" = mix_rmse, "mix_r" = mix_r)

}

#do permutations
doPerm <- function(perm, X, Y, absolute, abs_method){
  itor <- 1
  Ylist <- as.list(data.matrix(Y))
  dist <- matrix()

  while(itor <= perm){
    #print(itor)

    #random mixture
    yr <- as.numeric(Ylist[sample(length(Ylist),dim(X)[1])])

    #standardize mixture
    yr <- (yr - mean(yr)) / sd(yr)

    #run CIBERSORT core algorithm
    result <- CoreAlg(X, yr, absolute, abs_method)

    mix_r <- result$mix_r

    #store correlation
    if(itor == 1) {dist <- mix_r}
    else {dist <- rbind(dist, mix_r)}

    itor <- itor + 1
  }
  newList <- list("dist" = dist)
}

#main function
CIBERSORT <- function(sig_matrix, mixture_file, perm=0, QN=FALSE, absolute=FALSE, abs_method='sig.score'){

  if(absolute && abs_method != 'no.sumto1' && abs_method != 'sig.score') stop("abs_method must be set to either 'sig.score' or 'no.sumto1'")

  #read in data
  #X <- read.table(sig_matrix,header=T,sep="\t",row.names=1,check.names=F)
  X <- read.csv(sig_matrix, sep = "\t", row.names = 1,check.names=F)
  #Y <- read.table(mixture_file, header=T, sep="\t",check.names=F)
  Y <- read.csv(mixture_file, sep = "\t",check.names=F)
  #to prevent crashing on duplicated gene symbols, add unique numbers to identical names
  dups <- dim(Y)[1] - length(unique(Y[,1]))
  if(dups > 0) {
    warning(paste(dups," duplicated gene symbol(s) found in mixture file!",sep=""))
    rownames(Y) <- make.names(Y[,1], unique=TRUE)
  }else {rownames(Y) <- Y[,1]}
  Y <- Y[,-1]

  X <- data.matrix(X)
  Y <- data.matrix(Y)

  #order
  X <- X[order(rownames(X)),]
  Y <- Y[order(rownames(Y)),]

  P <- perm #number of permutations

  #anti-log if max < 50 in mixture file
  if (max(Y, na.rm = TRUE) < 50) {
    Y <- 2^Y
    Y[is.na(Y)] <- 0.0
  }

  #quantile normalization of mixture file
  if(QN == TRUE){
    tmpc <- colnames(Y)
    tmpr <- rownames(Y)
    Y <- normalize.quantiles(Y)
    colnames(Y) <- tmpc
    rownames(Y) <- tmpr
  }

  #store original mixtures
  Yorig <- Y
  Ymedian <- max(median(Yorig),1)

  #intersect genes
  Xgns <- row.names(X)
  Ygns <- row.names(Y)
  YintX <- Ygns %in% Xgns
  Y <- Y[YintX,]
  XintY <- Xgns %in% row.names(Y)
  X <- X[XintY,]

  #standardize sig matrix
  X <- (X - mean(X)) / sd(as.vector(X))

  #empirical null distribution of correlation coefficients
  if(P > 0) {nulldist <- sort(doPerm(P, X, Y, absolute, abs_method)$dist)}

  header <- c('Mixture',colnames(X),"P-value","Correlation","RMSE")
  if(absolute) header <- c(header, paste('Absolute score (',abs_method,')',sep=""))

  output <- matrix()
  itor <- 1
  mixtures <- dim(Y)[2]
  pval <- 9999

  #iterate through mixtures
  while(itor <= mixtures){

    y <- Y[,itor]

    #standardize mixture
    y <- (y - mean(y)) / sd(y)

    #run SVR core algorithm
    result <- CoreAlg(X, y, absolute, abs_method)

    #get results
    w <- result$w
    mix_r <- result$mix_r
    mix_rmse <- result$mix_rmse

    if(absolute && abs_method == 'sig.score') {
      w <- w * median(Y[,itor]) / Ymedian
    }

    #calculate p-value
    if(P > 0) {pval <- 1 - (which.min(abs(nulldist - mix_r)) / length(nulldist))}

    #print output
    out <- c(colnames(Y)[itor],w,pval,mix_r,mix_rmse)
    if(absolute) out <- c(out, sum(w))
    if(itor == 1) {output <- out}
    else {output <- rbind(output, out)}

    itor <- itor + 1

  }

  #save results
  #write.table(rbind(header,output), file="CIBERSORT-Results.txt", sep="\t", row.names=F, col.names=F, quote=F)

  #return matrix object containing all results
  obj <- rbind(header,output)
  obj <- obj[,-1]
  obj <- obj[-1,]
  obj <- matrix(as.numeric(unlist(obj)),nrow=nrow(obj))
  rownames(obj) <- colnames(Y)
  if(!absolute){colnames(obj) <- c(colnames(X),"P-value","Correlation","RMSE")}
  else{colnames(obj) <- c(colnames(X),"P-value","Correlation","RMSE",paste('Absolute score (',abs_method,')',sep=""))}
  obj[, 1:(dim(X)[2])]
}

tryCatch(
    expr = {
        cs <- CIBERSORT(args[2], args[1])
        write.table(t(cs), file="deconvoluted.tsv", quote = FALSE, col.names = NA, sep = "\t")
    },
    error = function(e){
      # (Optional)
      # Do this if an error is caught...
      print(e)
      X <- read.csv(args[2], sep = "\t", row.names = 1)
      Y <- read.csv(args[1], sep = "\t")
      cs <- matrix(0, nrow = length(colnames(Y)) - 1, ncol = length(colnames(X)), dimnames = list(colnames(Y)[2:length(colnames(Y))], colnames(X)))
      write.table(t(cs), file="deconvoluted.tsv", quote = FALSE, col.names = NA, sep = "\t")
    }
)