require(expm)
require(survival)

dyn.load("lk_rec.so")
dyn.load("lk_rec_surv.so")
dyn.load("lk_comp_joint.so")
dyn.load("lk_comp_joint_surv.so")
dyn.load("dlk_comp_joint.so")
dyn.load("dlk_comp_joint_surv.so")

est_incomp_joint_HMcontinuous = function(Y,TT,X,W,tv,dev,k,type=c("norm","bino"),btv=NULL,reltol=1e-6,inits=NULL,
                                         verbose=FALSE,LC=FALSE,surv=TRUE,maxit=5000,stderr=FALSE){

# Estimate the joint model with continuous HM chain described in
# "A shared-parameter continuous-time hidden Markov and survival model for longitudinal data
#  with informative drop-out"
# by F.Bartolucci and A.Farcomeni (2018)
#
# INCOMPLETE DATA CASE
#
# INPUT:
#
# Y       = matrix of responses of dimensino n x Tmax (Tmax = maximum number of individual observations)
# TT      = corresponding matrix of observation times
# X       = array of covariates for longitudinal process of dimension n x TT x nX (nX = number of covariates X)
# W       = array of covariates (including itercept) for survival process of dimension n x nW (nW = number of covariates V)
# tv      = vector of surivival times of lenght n
# dev     = vector of indicators of censoring of lenght n
# k       = number of latent states
# type    = type of response variables (norm or bino)
# btv     = list of equally spaced points defining time windows for the likelihood approximation
# reltol  = relative tollerance for checking log-likelihood convergence
# inits   = list of initial values of the parameters
# verbose = to disply partial output
# LC      = to fit the latent class (instead of latent Markov) model
# surv    = if survival time is provided
#
# OUTPUT:
#
# lk      = maximum log-likelihood at convergence
# Q       = estimated infinitesimal transition matrix
# piv     = estimated vector of initial probabilities
# bev     = estiamted vector of regression coefficients of the longitudinal responses
# nu      = estiamted parater in the baseline hazard function
# xiv     = estimated vector of support points for the latent distribution
# phi     = estimated association coeffiecint for the survivial process
# psiv    = estimated vector of
# si2     = estimated variance parameter
# pP      = time-specific posterior probabilities of each state
# Pi      = discrete time transition matrix
# it      = final number of iterations
# tim     = computing time
# bic     = BIC
# Ji      = observed information matrix (optional)
# sev     = overall vector of standard errors (optional)
# selav   = standard errors for vector lambda (optional)
# seLa    = standard errors for matrix Lambda (optional)
# sebev   = standard errors for bev (optional)
# seeta   = standard error for eta (optional)
# sexiv   = standard errors for xiv (optional)
# sephi   = standard error for phi (optional)
# sepsiv  = standard errors for psi (optional)
# sega    = standard error for gamma (optional)

# Preliminaries
	type = match.arg(type)
	censv = 1-dev
	t0 = proc.time()[3]
	npX = dim(X)[3]          # number of covariates on longitudinal process
	if(surv) npW = ncol(W)   # number of covariates on survival process
	n = dim(Y)[1]            # sample size
	jv = rowSums(!is.na(Y))  # number of longitudinal observations
	mjv = max(jv)            # maximum number of longitudinal observations
	if(!surv) tv = apply(TT,1,max,na.rm=TRUE)

# starting values
	Q = matrix(0,k,k)
	if(!is.null(inits)){
		if(LC) Q = matrix(0,k,k) else Q = inits$Q
		piv = inits$piv
		bev = inits$bev
		if(surv){
			nu = inits$nu
			phi = inits$phi
			psiv = inits$psiv
		}else{
			nu = phi = psiv = NULL
		}
		xiv = inits$xiv
		if(type=="bino") si2 = NULL else si2 = inits$si2
	}
	if(is.null(inits)){
		if(!LC){
			Q = matrix(1/(k-1),k,k)
			diag(Q) = -1
		}
		if(type=="norm"){
			jnk = lm(Y[,1]~.,data=data.frame(X[,1,]))
			xiv = jnk$coef[1]+seq(-k,k,length=k)
			bev = jnk$coef[-1]
			res = jnk$residuals
			si2 = var(res)
		}
		if(type=="bino"){
			yv = as.vector(Y)
			XX = matrix(X,n*mjv,npX)
			jnk = glm(yv~XX,family=binomial)
			pred = predict(jnk)
			ppred0 = exp(-pred)/(1+exp(-pred))
			ppred1 = exp(pred)/(1+exp(pred))
			res = yv[!is.na(yv)]*(-pred-log(1-ppred1)/ppred1)+(1-yv[!is.na(yv)])*(-pred+log(1-ppred0)/ppred0)
			si2 = NULL
		}
		out = kmeans(res,centers=k,iter.max=100)
		bev = jnk$coef[-1]
		ind = order(out$centers)
		xiv = jnk$coef[1]+out$centers[ind]
		piv = out$size[ind]/sum(out$size)
		if(surv){
			su = survreg(Surv(tv,ifelse(censv,0,1))~.,data=data.frame(W[,-1]))
			nu = 1/su$scale
			phi = 0
			jnk = su$coef
			jnk[-1] = jnk[-1]*nu
			jnk[1] = exp(jnk[1])
			psiv = -jnk
		}else{
			nu = phi = psiv = NULL
		}
	}

# compute transition matrix
	if(is.null(btv)){
		a = min(c(0.1,tv))
		btv = seq(0,max(tv),a)
	}else{
		a = btv[2]-btv[1]
	}
	M = length(btv)
	if(LC){
		Pi = diag(k)
	}else{
		Pi = diag(k)+a*Q
		Tmp = a*Q
		it = 1
		while(any(abs(Tmp)>0) & it<1000){
			it = it+1
			Tmp = (a/it)*(Tmp%*%Q)
			Pi = Pi+Tmp
		}
	}

# expand matrix of responses and array of covariates
	YM = matrix(0,n,M)
	XM = array(0,c(n,M,npX))
	PM = matrix(0,n,M)
	for(i in 1:n) for(j in 1:jv[i]){
		m = sum(TT[i,j]>=btv)
		YM[i,m] = Y[i,j]
		XM[i,m,] = X[i,j,]
		PM[i,m] = 1
	}

# compute log-likelihood
	if(is.null(si2)) si2f = as.double(0) else si2f = si2
	if(surv){
		out = .Fortran("lk_rec_surv",k=as.integer(k),piv=piv,Pi=Pi,npX=as.integer(npX),bev=bev,
		                nu=nu,xiv=xiv,phi=phi,npW=as.integer(npW),psiv=psiv,si2=si2f,
		                typ=type,n=as.integer(n),XM=XM,W=W,YM=YM,M=as.integer(M),PM=as.integer(PM),
		                btv=btv,dev=as.integer(1-censv),tv=as.double(tv),lk=0,Pp1=array(999,c(k,M,n)),Pp2=matrix(0,k,k))
	}else{
		out = .Fortran("lk_rec",k=as.integer(k),piv=piv,Pi=Pi,npX=as.integer(npX),bev=bev,
		                xiv=xiv,si2=si2f,typ=type,n=as.integer(n),XM=XM,YM=YM,M=as.integer(M),PM=as.integer(PM),
		                btv=btv,tv=as.double(tv),lk=0,Pp1=array(999,c(k,M,n)),Pp2=matrix(0,k,k),ver=as.integer(rep(0,n)))
	}
	lk = out$lk
	it = 0; lko = lk
	if(verbose) print(c(0,lk,phi))
	while(((lk-lko)/abs(lko)>reltol | it==0) & it<maxit){
		it = it+1; lko = lk
# M-step
# update piv and Pi
		piv = rowSums(out$Pp1[,1,])/n
		if(!LC) Pi = (1/rowSums(out$Pp2))*out$Pp2
# update other parameters
		if(surv) par = c(bev,log(nu),xiv,phi,psiv) else par = c(bev,xiv,phi,psiv)
		if(it==1){
			if(surv){
	 			par1 = optim(par,lk_comp_joint_HM2fort,method="Nelder-Mead",piv=piv,Pi=Pi,si2=si2,type=type,
	      		             dev=1-censv,tv=tv,XM=XM,W=W,YM=YM,PM=PM,btv=btv,Pp1=out$Pp1,
		     	             control=list(fnscale=-1))
		   	}else{
	 			par1 = optim(par,lk_comp_joint_HM2fort,method="Nelder-Mead",piv=piv,Pi=Pi,si2=si2,type=type,
	      		             tv=tv,XM=XM,YM=YM,PM=PM,btv=btv,Pp1=out$Pp1,surv=FALSE,
	      		             control=list(fnscale=-1))
		   	}
			par = par1$par
		}else{
			if(surv){
				par2 = optim(par,lk_comp_joint_HM2fort,dlk_comp_joint_HM2fort,method="BFGS",piv=piv,Pi=Pi,si2=si2,
	     		             type=type,dev=1-censv,tv=tv,XM=XM,W=W,YM=YM,PM=PM,btv=btv,Pp1=out$Pp1,
		     	             control=list(fnscale=-1,reltol=10^-12))
			}else{
				par2 = optim(par,lk_comp_joint_HM2fort,dlk_comp_joint_HM2fort,method="BFGS",piv=piv,Pi=Pi,si2=si2,
	     		             type=type,tv=tv,XM=XM,YM=YM,PM=PM,btv=btv,Pp1=out$Pp1,surv=FALSE,
		     	             control=list(fnscale=-1,reltol=10^-12))
			}
			par = par2$par
		}
		bev = par[1:npX]
		if(surv){
			nu = exp(par[npX+1]); xiv = par[(npX+2):(k+npX+1)]
			phi = par[k+npX+2]; psiv = par[(k+npX+3):length(par)]
		}else{
			xiv = par[(npX+1):(k+npX)]
		}
		if(type=="norm"){
			num = 0
			for(i in 1:n) for(m in 1:M) if(PM[i,m]==1){
				muv = xiv+as.vector(XM[i,m,]%*%bev)
				num = num+(YM[i,m]-muv)^2%*%out$Pp1[,m,i]
			}
			si2 = as.vector(num/sum(jv))
			if(is.na(si2)){
				print(si2)
				browser()
			}
		}
# compute log-likelihood
		if(is.null(si2)) si2f = as.double(0) else si2f = si2
		if(surv){
			out = .Fortran("lk_rec_surv",k=as.integer(k),piv=piv,Pi=Pi,npX=as.integer(npX),bev=bev,
		                           nu=nu,xiv=xiv,phi=phi,npW=as.integer(npW),psiv=psiv,si2=si2f,
		                           typ=type,n=as.integer(n),XM=XM,W=W,YM=YM,M=as.integer(M),PM=as.integer(PM),
		                           btv=btv,dev=as.integer(1-censv),tv=as.double(tv),lk=0,Pp1=array(999,c(k,M,n)),Pp2=matrix(0,k,k))
		}else{
			out = .Fortran("lk_rec",k=as.integer(k),piv=piv,Pi=Pi,npX=as.integer(npX),bev=bev,
		                           xiv=xiv,si2=si2f,typ=type,n=as.integer(n),XM=XM,YM=YM,M=as.integer(M),PM=as.integer(PM),
		                           btv=btv,tv=as.double(tv),lk=0,Pp1=array(999,c(k,M,n)),Pp2=matrix(0,k,k))
		}
		lk = out$lk
		if(verbose & it%%100==0) print(c(it,lk,lk-lko,phi,proc.time()[3]-t0))
	}
	if(verbose) print(c(it,lk,lk-lko,phi,proc.time()[3]-t0))

# compute standard errors
	if(stderr){
		lav = log(piv[-1]/piv[1])
		par_tot = lav
		if(!LC) for(u in 1:k) par_tot = c(par_tot,log(Pi[u,-u]/Pi[u,u]))
		if(surv) par_tot = c(par_tot,bev,eta=log(nu),xiv,phi,psiv) else par_tot = c(par_tot,bev,xiv,phi,psiv)
		if(type=="norm") par_tot = c(par_tot,ga=log(si2))
		out = lk_obs(par_tot,YM,XM,W,tv,dev,k,type,btv,M,PM,LC,surv,npX,npW,n)
		dlkn = rep(0,length(par_tot))
		Ji = NULL
		for(j in 1:length(par_tot)){
			par_tot1 = par_tot; par_tot1[j] = par_tot1[j]+10^-6
			out1 = lk_obs(par_tot1,YM,XM,W,tv,dev,k,type,btv,M,PM,LC,surv,npX,npW,n)
			dlkn[j] = (out1$lk-out$lk)*10^6
			Ji = cbind(Ji,(out1$dlk-out$dlk)*10^6)
		}
		# print(c(lk,out$lk))
		# print(round(cbind(dlkn,out$dlk,dlkn-out$dlk),6))
		Ji = -(Ji+t(Ji))/2            # information matrix
		sev = sqrt(abs(diag(solve(Ji))))   # vector of standard errors
		tmp = sev
		selav = tmp[1:(k-1)]; tmp = tmp[-(1:(k-1))]
		if(!LC){
			seLa = NULL
			for(u in 1:k){
				seLa = rbind(seLa,tmp[1:(k-1)])
				tmp = tmp[-(1:(k-1))]
			}
		}
		sebev = tmp[1:npX]; tmp = tmp[-(1:npX)]
		if(surv){
			seeta = tmp[1]; tmp = tmp[-1]
		}
		sexiv = tmp[1:k]; tmp = tmp[-(1:k)]
		sephi = tmp[1]; tmp = tmp[-1]
		sepsiv = tmp[1:npW]; tmp = tmp[-(1:npW)]
		if(type=="norm"){
			sega = tmp
		}else{
			sega = NULL
		}
	}

# final output
	if(!LC) Q = logm(Pi %^% (1/a))
	np = length(par)
	if(!LC) np = np+k^2-1
	if(type=="norm") np = np+1
	bic = -2*lk+log(n)*np
	out = list(lk=lk,Q=Q,piv=piv,bev=bev,nu=nu,xiv=xiv,phi=phi,psiv=psiv,si2=si2,pP=out$Pp1,Pi=Pi,it=it,tim=proc.time()[3]-t0,bic=bic)
	if(stderr){
		out$Ji = Ji; out$sev = sev; out$selav = selav; out$seLa = seLa; out$sebev = sebev; out$seeta = seeta
		out$sexiv = sexiv; out$sephi = sephi; out$sepsiv = sepsiv; out$sega = sega
	}
	return(out)

}
# ---------------------------------------------------------------------------------------------------
lk_comp_joint_HM2fort <- function(par,piv,Pi,si2,type,XM,W,YM,PM,btv,Pp1,dev,tv,surv=TRUE){

# to compute the second and third components of the expect complete log-likelihood

# preliminaries
	k = length(piv)
	npX = dim(XM)[3]
	if(surv) npW = ncol(W)
	bev = par[1:npX]
	if(surv){
		lnu = par[npX+1]; xiv = par[(npX+2):(k+npX+1)]; phi = par[k+npX+2]
		nu = exp(lnu); psiv = par[(k+npX+3):length(par)]
	}else{
		xiv = par[(npX+1):(k+npX)]
	}
	n = nrow(YM)
	M = length(btv)
# call fortran function
	if(is.null(si2)) si2f = as.double(0) else si2f = si2
	if(surv){
		out = .Fortran("lk_comp_joint_surv",bev=bev,lnu=lnu,xiv=xiv,phi=phi,psiv=psiv,k=as.integer(k),piv=piv,Pi=Pi,si2=si2f,
		                   typ=type,n=as.integer(n),M=as.integer(M),npX=as.integer(npX),XM=XM,npW=as.integer(npW),
	    	               W=W,YM=YM,PM=as.integer(PM),btv=btv,Pp1=Pp1,dev=as.integer(dev),tv=as.double(tv),lk=0)
	}else{
		out = .Fortran("lk_comp_joint",bev=bev,xiv=xiv,k=as.integer(k),piv=piv,Pi=Pi,si2=si2f,
		                   typ=type,n=as.integer(n),M=as.integer(M),npX=as.integer(npX),XM=XM,
	    	               YM=YM,PM=as.integer(PM),btv=btv,Pp1=Pp1,tv=as.double(tv),lk=0)
	}
	lk = out$lk
# return output
	return(lk)

}
# ---------------------------------------------------------------------------------------------------
dlk_comp_joint_HM2fort <- function(par,piv,Pi,si2,type,XM,W,YM,PM,jv,btv,Pp1,dev,tv,surv=TRUE){

# to compute the derivative of lk_comp_joint_HM
# preliminaries
	k = length(piv)
	npX = dim(XM)[3]
	if(surv) npW = ncol(W)
	bev = par[1:npX]
	if(surv){
		lnu = par[npX+1]; xiv = par[(npX+2):(k+npX+1)]; phi = par[k+npX+2]
		nu = exp(lnu); psiv = par[(k+npX+3):length(par)]
	}else{
		xiv = par[(npX+1):(k+npX)]
	}
	n = nrow(YM)
	M = length(btv)
# call Fortran
# call fortran function
	if(is.null(si2)) si2f = as.double(0) else si2f = as.double(si2)
	if(surv){
		out = .Fortran("dlk_comp_joint_surv",bev=bev,lnu=lnu,xiv=xiv,phi=phi,psiv=psiv,k=as.integer(k),piv=piv,Pi=Pi,si2=si2f,
		                   typ=type,n=as.integer(n),M=as.integer(M),npX=as.integer(npX),XM=XM,npW=as.integer(npW),
	    	               W=W,YM=YM,PM=as.integer(PM),btv=btv,Pp1=Pp1,dev=as.integer(dev),tv=as.double(tv),
	    	               dlk=rep(0,npX+1+k+1+npW))
	}else{
		out = .Fortran("dlk_comp_joint",bev=bev,xiv=xiv,k=as.integer(k),piv=piv,Pi=Pi,si2=si2f,
		                   typ=type,n=as.integer(n),M=as.integer(M),npX=as.integer(npX),XM=XM,
	    	               YM=YM,PM=as.integer(PM),btv=btv,Pp1=Pp1,tv=as.double(tv),dlk=rep(0,npX+k))
	}
	dlk = out$dlk
# return output
	return(dlk)

}
# ---------------------------------------------------------------------------------------------------
lk_comp_joint_HM2 <- function(par,piv,Pi,si2,type,XM,W,YM,PM,btv,Pp1,dev,tv,surv=TRUE){

# to compute the second and third components of the expect complete log-likelihood

# preliminaries
	k = length(piv)
	npX = dim(XM)[3]
	bev = par[1:npX]
	if(surv){
		lnu = par[npX+1]; xiv = par[(npX+2):(k+npX+1)]; phi = par[k+npX+2]
		nu = exp(lnu); psiv = par[(k+npX+3):length(par)]
	}else{
		xiv = par[(npX+1):(k+npX)]
	}
	n = nrow(YM)
	M = length(btv)
	if(surv){
		btvnu = btv^nu
		dbtvnu = diff(btvnu)
	}
	if(type=="norm") lsi2pi = log(si2)+log(2*pi)
# compute functions
	l2 = 0
	if(surv){
		l3 = 0
		tmp00 = xiv*phi
	}
	if(surv) Wp = W%*%psiv
	for(i in 1:n){
		if(surv){
			tmp0 = tmp00+Wp[i]
			etmp0 = exp(tmp0)
		}
		mi = sum(btv<=tv[i])
		for(m in 1:mi){
			if(PM[i,m]==1){
				muv = xiv+as.vector(XM[i,m,]%*%bev)
				if(type=="norm") l2 = l2-1/2*(lsi2pi+(YM[i,m]-muv)^2/si2)%*%Pp1[,m,i]
				if(type=="bino"){
					muv = exp(muv)/(1+exp(muv))
					l2 = l2+(YM[i,m]*log(muv)+(1-YM[i,m])*log(1-muv))%*%Pp1[,m,i]
				}
			}
		}
		if(surv){
			if(mi>1) for(m in 2:mi) l3 = l3-dbtvnu[m-1]*(etmp0%*%Pp1[,m-1,i])
			l3 = l3+(dev[i]*(lnu+(nu-1)*log(tv[i])+tmp0)-etmp0*(tv[i]^nu-btvnu[mi]))%*%Pp1[,mi,i]
		}
	}
	if(surv) lk = as.vector(l2+l3) else lk = l2
	return(lk)

}
# ---------------------------------------------------------------------------------------------------
dlk_comp_joint_HM2 <- function(par,piv,Pi,si2,type,XM,W,YM,PM,jv,btv,Pp1,dev,tv,surv=TRUE){

# to compute the derivative of lk_comp_joint_HM
# preliminaries
	k = length(piv)
	npX = dim(XM)[3]
	if(surv) npW = ncol(W)
	bev = par[1:npX]
	if(surv){
		lnu = par[npX+1]; xiv = par[(npX+2):(k+npX+1)]; phi = par[k+npX+2]
		nu = exp(lnu); psiv = par[(k+npX+3):length(par)]
	}else{
		xiv = par[(npX+1):(k+npX)]
	}
	n = nrow(YM)
	M = length(btv)
	if(surv){
		btvnu = btv^nu
		dbtvnu = diff(btvnu)
	}
# compute functions
	dl2bev = rep(0,2)
	if(surv) dl3nu = 0
	dl2xiv = dl3xiv = rep(0,k)
	if(surv){
		dl3phi = 0
		dl3psiv = rep(0,npW)
	}
	for(i in 1:n){
		if(surv) tmp0 = exp(xiv*phi+as.vector(W[i,]%*%psiv))
		mi = sum(btv<=tv[i])
		for(m in which(PM[i,1:mi]==1)){
			muv = xiv+as.vector(XM[i,m,]%*%bev)
			if(type=="norm"){
				dl2bev = dl2bev+XM[i,m,]*as.vector(((YM[i,m]-muv)/si2)%*%Pp1[,m,i])
				dl2xiv = dl2xiv+(YM[i,m]-muv)/si2*Pp1[,m,i]
			}
			if(type=="bino"){
				muv = exp(muv)/(1+exp(muv))
				tmp1 = (YM[i,m]-muv)*Pp1[,m,i]
				dl2bev = dl2bev+XM[i,m,]*sum(tmp1)
				dl2xiv = dl2xiv+tmp1
			}
		}
		if(surv){
			if(mi>1) for(m in 2:mi){
				if(btv[m-1]>0) tmp = log(btv[m-1]) else tmp = 0
				dl3nu = dl3nu-(tmp0*(log(btv[m])*btvnu[m]-tmp*btvnu[m-1]))%*%Pp1[,m-1,i]
				dl3xiv = dl3xiv-(tmp0*dbtvnu[m-1])*phi*Pp1[,m-1,i]
				dl3phi = dl3phi-(tmp0*dbtvnu[m-1]*xiv)%*%Pp1[,m-1,i]
				dl3psiv = dl3psiv-W[i,]*as.vector((tmp0*dbtvnu[m-1])%*%Pp1[,m-1,i])
			}
			if(btv[mi]>0) tmp = log(btv[mi]) else tmp = 0
			dl3nu = dl3nu+(dev[i]*(1/nu+log(tv[i]))-tmp0*(log(tv[i])*tv[i]^nu-tmp*btvnu[mi]))%*%Pp1[,mi,i]
			dl3xiv = dl3xiv+(dev[i]*phi-tmp0*(tv[i]^nu-btvnu[mi])*phi)*Pp1[,mi,i]
			dl3phi = dl3phi+(dev[i]*xiv-tmp0*(tv[i]^nu-btvnu[mi])*xiv)%*%Pp1[,mi,i]
			dl3psiv = dl3psiv+W[i,]*as.vector((dev[i]-tmp0*(tv[i]^nu-btvnu[mi]))%*%Pp1[,mi,i])
		}
	}
# output
	if(surv) dlk = c(dl2bev,dl3nu*nu,dl2xiv+dl3xiv,dl3phi,dl3psiv) else dlk = c(dl2bev,dl2xiv)
	return(dlk)

}
# ---------------------------------------------------------------------------------------------------
lk_rec_joint_HM2 <- function(piv,Pi,bev,nu,xiv,phi,psiv,si2,type,XM,W,YM,btv,dev,tv,surv=TRUE){

# preliminaries
	n = nrow(YM)
	k = length(xiv)
	M = length(btv)
	if(type=="norm") si = sqrt(si2)
	if(surv){
		btvnu = btv^nu
		dbtvnu = diff(btvnu)
	}
# recursion for each individual
	lk = 0
	Pp1 = array(NA,c(k,M,n))
	Pp2 = matrix(0,k,k)
	for(i in 1:n){
		mi = sum(btv<=tv[i])
		if(surv) tmp0 = exp(xiv*phi+as.vector(W[i,]%*%psiv))
# FORWARD RECURSION
		Frec = matrix(0,k,mi)
# first time
		muv = xiv+as.vector(XM[i,1,]%*%bev)
		if(type=="norm") frec = piv*dnorm(YM[i,1],muv,si)
		if(type=="bino"){
			muv = exp(muv)/(1+exp(muv))
			frec = piv*(YM[i,1]*muv+(1-YM[i,1])*(1-muv))
		}
		Frec[,1] = frec
# following time occasions
		if(mi>1) for(m in 2:mi){
			if(surv){
				tmp = exp(-tmp0*dbtvnu[m-1])
				frec = as.vector(t(Pi)%*%(frec*tmp))
			}else{
				frec = as.vector(t(Pi)%*%frec)
			}
			if(!is.na(YM[i,m])){
				muv = xiv+as.vector(XM[i,m,]%*%bev)
				if(type=="norm") frec = frec*dnorm(YM[i,m],muv,si)
				if(type=="bino"){
					muv = exp(muv)/(1+exp(muv))
					frec = frec*(YM[i,m]*muv+(1-YM[i,m])*(1-muv))
				}
			}
			Frec[,m] = frec
		}
		if(surv){
			tmp = exp(-tmp0*(tv[i]^nu-btvnu[mi]))
			if(dev[i]==1) tmp = tmp*nu*tv[i]^(nu-1)*tmp0
			frec = as.vector(frec*tmp)
		}
		fi = sum(frec)
# accumulate log-likelihood
		lk = lk+log(fi)

# BACKWARD RECURSION
		Grec = matrix(0,k,mi)
# last time occasion
		if(surv){
			grec = exp(-tmp0*(tv[i]^nu-btvnu[mi]))
			if(dev[i]==1) grec = grec*nu*tv[i]^(nu-1)*tmp0
		}else{
			grec = rep(1,k)
		}
		Grec[,mi] = grec
# previous time occasions
		if(mi>1) for(m in (mi-1):1){
			if(surv) tmp = exp(-tmp0*dbtvnu[m])
			if(!is.na(YM[i,m+1])){
				muv = xiv+as.vector(XM[i,m+1,]%*%bev)
				if(type=="norm") grec = grec*dnorm(YM[i,m+1],muv,si)
				if(type=="bino"){
					muv = exp(muv)/(1+exp(muv))
					grec = grec*(YM[i,m+1]*muv+(1-YM[i,m+1])*(1-muv))
				}
			}
			if(surv) grec = tmp*as.vector(Pi%*%grec) else grec = as.vector(Pi%*%grec)
			Grec[,m] = grec
		}
# Posterior probabilities for the first time occasion
		Pp1[,1:mi,i] = Frec*Grec/fi
# Joint Posterior probabilities for two occasions
		if(mi>1) for(m in 1:(mi-1)){
			if(surv) tmp = exp(-tmp0*dbtvnu[m])
			if(!is.na(YM[i,m+1])){
				muv = xiv+as.vector(XM[i,m+1,]%*%bev)
				if(type=="norm") tmp1 = dnorm(YM[i,m+1],muv,si)
				if(type=="bino"){
					muv = exp(muv)/(1+exp(muv))
					tmp1 = YM[i,m+1]*muv+(1-YM[i,m+1])*(1-muv)
				}
			}else{
				tmp1 = 1
			}
			if(surv){
				Tmp = ((Frec[,m]*tmp)%o%(Grec[,m+1]*tmp1))*Pi/fi
			}else{
				Tmp = (Frec[,m]%o%(Grec[,m+1]*tmp1))*Pi/fi
			}
			Pp2 = Pp2+Tmp
		}
	}
# output
	out = list(lk=lk,Pp1=Pp1,Pp2=Pp2)

}
# ---------------------------------------------------------------------------------------------------
lk_obs <- function(par_tot,YM,XM,W,tv,dev,k,type,btv,M,PM,LC,surv,npX,npW,n)
{

# reconstruct parameters
    G = diag(k)[,-1]
    if(k==2) {G=matrix(G)}
	piv = exp(G%*%par_tot[1:(k-1)]); piv = as.vector(piv/sum(piv))
	par_tot = par_tot[-(1:(k-1))]
	if(!LC){
		Pi = NULL
		for(u in 1:k){
                    G = diag(k)[,-u]
                    if(k==2) {G=matrix(G)}
			tmp = exp(G%*%par_tot[1:(k-1)]); tmp = as.vector(tmp/sum(tmp))
			Pi = rbind(Pi,tmp)
			par_tot = par_tot[-(1:(k-1))]
		}
	}
	bev = par_tot[1:npX]; par_tot = par_tot[-(1:npX)]
	if(surv){
		eta = par_tot[1]; nu = exp(eta); par_tot = par_tot[-1]
	}
	xiv = par_tot[1:k]; par_tot = par_tot[-(1:k)]
	phi = par_tot[1]; par_tot = par_tot[-1]
	psiv = par_tot[1:npW]; par_tot = par_tot[-(1:npW)]
	if(type=="norm"){
		ga = par_tot; si2 = exp(ga)
	}else{
		si2 = NULL
	}

# compute log-likelihood
	if(is.null(si2)) si2f = as.double(0) else si2f = si2
	if(surv){
		out = .Fortran("lk_rec_surv",k=as.integer(k),piv=piv,Pi=Pi,npX=as.integer(npX),bev=bev,
		                nu=nu,xiv=xiv,phi=phi,npW=as.integer(npW),psiv=psiv,si2=si2f,
		                typ=type,n=as.integer(n),XM=XM,W=W,YM=YM,M=as.integer(M),PM=as.integer(PM),
		                btv=btv,dev=as.integer(dev),tv=as.double(tv),lk=0,Pp1=array(999,c(k,M,n)),Pp2=matrix(0,k,k))
	}else{
		out = .Fortran("lk_rec",k=as.integer(k),piv=piv,Pi=Pi,npX=as.integer(npX),bev=bev,
		                xiv=xiv,si2=si2f,typ=type,n=as.integer(n),XM=XM,YM=YM,M=as.integer(M),PM=as.integer(PM),
		                btv=btv,tv=as.double(tv),lk=0,Pp1=array(999,c(k,M,n)),Pp2=matrix(0,k,k),ver=as.integer(rep(0,n)))
	}
	lk = out$lk
# compute posterior probabilities
	Pp1 = out$Pp1; Pp2 = out$Pp2
	Pp1[Pp1==999] = NA
# preliminaries
	if(surv){
		btvnu = btv^nu
		dbtvnu = diff(btvnu)
	}
# compute functions
    G = diag(k)[,-1]
    if(k==2) {G=matrix(G)}
	bnv = rowSums(Pp1[,1,])
	dl1lav = t(G)%*%(bnv-n*piv)
	dl1La = NULL
	for(u in 1:k){
            G = diag(k)[,-u]
            if(k==2) {G=matrix(G)}
		dl1La = c(dl1La,t(G)%*%(Pp2[u,]-sum(Pp2[u,])*Pi[u,]))
	}
	dl2bev = rep(0,2)
	if(surv) dl3nu = 0
	if(type=="norm") dl2ga = 0
	dl2xiv = dl3xiv = rep(0,k)
	if(surv){
		dl3phi = 0
		dl3psiv = rep(0,npW)
	}
	for(i in 1:n){
		if(surv) tmp0 = exp(xiv*phi+as.vector(W[i,]%*%psiv))
		mi = sum(btv<=tv[i])
		for(m in which(PM[i,1:mi]==1)){
			muv = xiv+as.vector(XM[i,m,]%*%bev)
			if(type=="norm"){
				dl2bev = dl2bev+XM[i,m,]*as.vector(((YM[i,m]-muv)/si2)%*%Pp1[,m,i])
				dl2xiv = dl2xiv+(YM[i,m]-muv)/si2*Pp1[,m,i]
				dl2ga = dl2ga-(1-(YM[i,m]-muv)^2/si2)%*%Pp1[,m,i]/2
			}
			if(type=="bino"){
				muv = exp(muv)/(1+exp(muv))
				tmp1 = (YM[i,m]-muv)*Pp1[,m,i]
				dl2bev = dl2bev+XM[i,m,]*sum(tmp1)
				dl2xiv = dl2xiv+tmp1
			}
		}
		if(surv){
			if(mi>1) for(m in 2:mi){
				if(btv[m-1]>0) tmp = log(btv[m-1]) else tmp = 0
				dl3nu = dl3nu-(tmp0*(log(btv[m])*btvnu[m]-tmp*btvnu[m-1]))%*%Pp1[,m-1,i]
				dl3xiv = dl3xiv-(tmp0*dbtvnu[m-1])*phi*Pp1[,m-1,i]
				dl3phi = dl3phi-(tmp0*dbtvnu[m-1]*xiv)%*%Pp1[,m-1,i]
				dl3psiv = dl3psiv-W[i,]*as.vector((tmp0*dbtvnu[m-1])%*%Pp1[,m-1,i])
			}
			if(btv[mi]>0) tmp = log(btv[mi]) else tmp = 0
			dl3nu = dl3nu+(dev[i]*(1/nu+log(tv[i]))-tmp0*(log(tv[i])*tv[i]^nu-tmp*btvnu[mi]))%*%Pp1[,mi,i]
			dl3xiv = dl3xiv+(dev[i]*phi-tmp0*(tv[i]^nu-btvnu[mi])*phi)*Pp1[,mi,i]
			dl3phi = dl3phi+(dev[i]*xiv-tmp0*(tv[i]^nu-btvnu[mi])*xiv)%*%Pp1[,mi,i]
			dl3psiv = dl3psiv+W[i,]*as.vector((dev[i]-tmp0*(tv[i]^nu-btvnu[mi]))%*%Pp1[,mi,i])
		}
	}
	if(surv) dlk = c(dl1lav,dl1La,dl2bev,dl3nu*nu,dl2xiv+dl3xiv,dl3phi,dl3psiv) else dlk = c(dl2bev,dl2xiv)
	if(type=="norm") dlk = c(dlk,dl2ga)
# output
	out = list(lk=lk,dlk=dlk)

}


physics.mass.calculate <- function(gravity, radius) {
    return(gravity * radius^2 / gravity.constant)
}


#### Parte 1 ----
br  <- read.table("~/breast.txt", header=FALSE, stringsAsFactors=FALSE)

dim(br)

# 10000 bytes

# Estimar Volume de Dados correspondente ao limite de memÃ³ria RAM (10000 bytes)
vol_data = 0
size     = 0
cont     = 1
while(size <= 10000){
  br2  <- read.table("~/breast.txt", header=FALSE, stringsAsFactors=FALSE,
                     nrows = cont)
  size = object.size(br2)
  cont = cont + 1
}

vol_data = cont - 2
br3  <- read.table("~/breast.txt", header=FALSE, stringsAsFactors=FALSE,
                   nrows = vol_data)
size = object.size(br3)

# NÃºmero de PartiÃ§Ãµes da Base de Dados
nPar = trunc(nrow(br)/vol_data) + ifelse(nrow(br)%%vol_data>0, 1, 0)

# Carregando dados em partiÃ§Ãµes

media.vec = rep(0,length=ncol(br)-1)

for(k in 1:nPar){
  br4  <- read.table("~/breast.txt", header=FALSE, stringsAsFactors=FALSE,
                     nrows = vol_data, skip = (k-1)*vol_data)
  br4 = as.matrix(br4[,-31])
  media.vec = media.vec + colSums(br4)
  gc()
  print(k)
  print(((k-1)*vol_data+1):(k*vol_data))
  print(object.size(br4))
  print(nrow(br4))

}
mediaPar = media.vec / 569
identical(mediaPar,colMeans(br[,-31]))
abs(mediaPar - colMeans(br[,-31]))

sig2.vec = rep(0,length=ncol(br[1:2])-1)
min.vec  = c()
max.vec  = c()
for(k in 1:nPar){
  br4  <- read.table("~/breast.txt", header=FALSE, stringsAsFactors=FALSE,
                     nrows = vol_data, skip = (k-1)*vol_data)
  br4 = as.matrix(br4[,-31])
  sig2.vec = sig2.vec + colSums(t(t(br4) - mediaPar)^2)
  min.vec  = apply(rbind(min.vec,br4),2,min)
  max.vec  = apply(rbind(max.vec,br4),2,max)
  print(k)
}

S2Par = sig2.vec / (569 - 1)
S2    = apply(br[,-31], 2, var)
identical(S2Par, S2)
abs(S2Par - S2) < 0.0001

#### Parte 2 ----

setwd("C:\\Users\\souza\\OneDrive\\Documentos\\docsis 30")

# Control
setwd("control")

fileNames = dir()
fileNames = fileNames[grep(".txt", fileNames)]

for(k in 1:length(fileNames)){
  Log  = readLines(fileNames[k])
  idFP = grep("Freq\tPower",Log)+1
  Log  = Log[idFP:length(Log)]

  if(k == 1){
    logsplitted = strsplit(Log, split = "\t")
    logarray    = t(simplify2array(logsplitted))
    DATA        = matrix(as.numeric(logarray[,2]), 1, nrow(logarray),
                         dimnames = list(1, logarray[,1]))
    DATA        = as.data.frame(DATA)
  }else{
    logsplitted = strsplit(Log, split = "\t")
    logarray    = t(simplify2array(logsplitted))
    DATA[k,]    = as.numeric(logarray[,2])

  }
}

DATA = data.frame(DATA, CLASS = "CONTROL", stringsAsFactors = FALSE)

setwd("C:\\Users\\souza\\OneDrive\\Documentos\\docsis 30")
# Error
setwd("error")
n = nrow(DATA)
fileNames = dir()
fileNames = fileNames[grep(".txt", fileNames)]

for(k in 1:length(fileNames)){
  Log  = readLines(fileNames[k])
  idFP = grep("Freq\tPower",Log)+1
  Log  = Log[idFP:length(Log)]
  logsplitted = strsplit(Log, split = "\t")
  logarray    = t(simplify2array(logsplitted))
  DATA[n+k,-ncol(DATA)]    = as.numeric(logarray[,2])
  DATA[n+k,ncol(DATA)]    = "ERROR"
}

View(DATA)


context("itakewhile iterator")

test_that("Apply itakewhile to an integer sequence", {
  not_too_large <- function(x) {
    x <= 5
  }
  it <- itakewhile(not_too_large, 1:100)

  expect_equal(nextElem(it), 1)
  expect_equal(nextElem(it), 2)
  expect_equal(nextElem(it), 3)
  expect_equal(nextElem(it), 4)
  expect_equal(nextElem(it), 5)
  expect_error(nextElem(it), "StopIteration")
})

test_that("Apply itakewhile to an integer sequence using anonymous function", {
  it <- itakewhile(function(x) x <= 10, seq(2, 100, by=2))

  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")
})


# Cont. vars
# - Basic data analysis and plots of continuous numerical values

# # LIBRARIES ---------------------------
library(tidyverse)
library(gridExtra)
library(xtable)

# citation("tidyverse")
# citation("gridExtra")

getwd()

# INPUT ---------------------------
#  - Reading data from db and extracting metrics data
prime <- read_csv("../Db.PRIME.csv")
# problems(prime)

# met contains Morph types Ad, Ax, We only
met <- select(prime, Include:Ident, Orig:Mas)
met <- filter(met, Morph == "Ad" | Morph == "Ax" | Morph == "We")

# # (this was to copy somwhere? no idea anymore)
# sumStatLok <- prime %>%
#   group_by(Lokalita) %>%
#   summarise(n = n(), sum(Mas))

# DATA MANIPULATION ---------------------------
# # Subsetting only ADZES & Wedzes
# met <- met %>%
#   filter(Morph == "Ad" | Morph == "We")  %>%
#   filter(RM == "JzH")

# CONTINUE EITHER HERE OR JUMP TO PLOTS!

# Removing rows with NA data in metrics
metLen.Hei <- filter(met, !is.na(Len) | !is.na(Wid) | !is.na(Hei))
metMas <- filter(met, !is.na(Mas))

met <- met %>%
  mutate(CultDat = paste(Cult, Dat, sep = " "))
met$CultDat <- str_replace(met$CultDat, pattern = "(.*) NA", replacement = "\\1")

# Counting relative width (rWid) and relative thickness (rHei), rounding
metLen.Hei$Len <- as.numeric(metLen.Hei$Len)
metLen.Hei$Wid <- as.numeric(metLen.Hei$Wid)
metLen.Hei$Hei <- as.numeric(metLen.Hei$Hei)
metMas$Mas <- as.numeric(metMas$Mas)

metLen.Hei <- metLen.Hei %>%
  mutate(rWid = (Wid / Len) * 100, rHei = (Hei / Wid) * 100)

metLen.Hei$rWid <- round(metLen.Hei$rWid, 2)
metLen.Hei$rHei <- round(metLen.Hei$rHei, 2)

# DESCRIPTIVE STATS ---------------------------
# Komplet
stVse <- metLen.Hei %>%
  summarise(n=n(),
            mean(Len), median(Len), sd(Len), min(Len), max(Len),
            mean(Wid), median(Wid), sd(Wid), min(Wid), max(Wid),
            mean(Hei), median(Hei), sd(Hei), min(Hei), max(Hei)) %>%
  as.data.frame() %>%
  t()

stMas <- metMas %>%
  summarise(n=n(), mean(Mas), median(Mas), sd(Mas), min(Mas), max(Mas)) %>%
  as.data.frame() %>%
  t()

stVse <- rbind(stVse, stMas)
colnames(stVse) <- c("BKI")
stVse <- round(stVse, 2)
stVse <- as.data.frame(stVse) %>%
  xtable(caption = "Popisná statistika, celý soubor")

# print(stVse, file = "../../Text/9Priloha/Tab/stats.txt", booktabs = T, caption.placement = "top")

# Lokality
stLok <- metLen.Hei %>%
  group_by(Lok) %>%
  summarise(n=n(),
            mean(Len), median(Len), sd(Len), min(Len), max(Len),
            mean(Wid), median(Wid), sd(Wid), min(Wid), max(Wid),
            mean(Hei), median(Hei), sd(Hei), min(Hei), max(Hei))
stLok <- cbind(stLok$Lok, round(stLok[,2:17], 2)) %>%
  as.data.frame() %>%
  t()

stLokMas <- metMas %>%
  group_by(Lok) %>%
  summarise(n=n(), mean(Mas), median(Mas), sd(Mas), min(Mas), max(Mas))
stLokMas <- cbind(stLokMas$Lok, round(stLokMas[,2:7], 2)) %>%
  as.data.frame() %>%
  t()

colnames(stLok) <- as.character(stLok[1, ])
stLok <- as.data.frame(stLok[-1, ]) %>%
  xtable(caption = "Popisná statistika -- délka, šířka, výška, seskupeno dle lokalit")
# print(stLok, file = "../../Text/9Priloha/Tab/stLok.txt", booktabs = T, caption.placement = "top")

colnames(stLokMas) <- as.character(stLokMas[1, ])
stLokMas <- as.data.frame(stLokMas[-1, ]) %>%
  xtable(caption = "Popisná statistika -- hmotnost, seskupeno dle lokalit")
# print(stLokMas, file = "../../Text/9Priloha/Tab/stLokMas.txt", booktabs = T, caption.placement = "top")

# Origin
stOrig <- metLen.Hei %>%
  group_by(Orig) %>%
  summarise(n=n(),
            mean(Len), median(Len), sd(Len), min(Len), max(Len),
            mean(Wid), median(Wid), sd(Wid), min(Wid), max(Wid),
            mean(Hei), median(Hei), sd(Hei), min(Hei), max(Hei))
stOrig <- cbind(stOrig$Orig, round(stOrig[,2:17], 2)) %>%
  as.data.frame() %>%
  t()

stOrigMas <- metMas %>%
  group_by(Orig) %>%
  summarise(n=n(), mean(Mas), median(Mas), sd(Mas), min(Mas), max(Mas))
stOrigMas <- cbind(stOrigMas$Orig, round(stOrigMas[,2:7], 2)) %>%
  as.data.frame() %>%
  t()

colnames(stOrig) <- as.character(stOrig[1, ])
stOrig <- as.data.frame(stOrig[-1, ]) %>%
  xtable(caption = "Popisná statistika -- délka, šířka, výška, seskupeno dle kontextu")
# print(stOrig, file = "../../Text/9Priloha/Tab/stOrig.txt", booktabs = T, caption.placement = "top")

colnames(stOrigMas) <- as.character(stOrigMas[1, ])
stOrigMas <- as.data.frame(stOrigMas[-1, ]) %>%
  xtable(caption = "Popisná statistika -- hmotnost, seskupeno dle kontextu")
# print(stOrigMas, file = "../../Text/9Priloha/Tab/stOrigMas.txt", booktabs = T, caption.placement = "top")

# Morph
stMorph <- metLen.Hei %>%
  group_by(Morph) %>%
  summarise(n=n(),
            mean(Len), median(Len), sd(Len), min(Len), max(Len),
            mean(Wid), median(Wid), sd(Wid), min(Wid), max(Wid),
            mean(Hei), median(Hei), sd(Hei), min(Hei), max(Hei))
stMorph <- cbind(stMorph$Morph, round(stMorph[,2:17], 2)) %>%
  as.data.frame() %>%
  t()

stMorphMas <- metMas %>%
  group_by(Morph) %>%
  summarise(n=n(), mean(Mas), median(Mas), sd(Mas), min(Mas), max(Mas))
stMorphMas <- cbind(stMorphMas$Morph, round(stMorphMas[,2:7], 2)) %>%
  as.data.frame() %>%
  t()

colnames(stMorph) <- as.character(stMorph[1, ])
stMorph <- as.data.frame(stMorph[-1, ]) %>%
  xtable(caption = "Popisná statistika -- délka, šířka, výška, seskupeno dle typu")
# print(stMorph, file = "../../Text/9Priloha/Tab/stMorph.txt", booktabs = T, caption.placement = "top")

colnames(stMorphMas) <- as.character(stMorphMas[1, ])
stMorphMas <- as.data.frame(stMorphMas[-1, ]) %>%
  xtable(caption = "Popisná statistika -- hmotnost, seskupeno dle typu")
# print(stMorphMas, file = "../../Text/9Priloha/Tab/stMorphMas.txt", booktabs = T, caption.placement = "top")

# PLOTS ---------------------------
## First some manipulation
met <- as.tibble(met)
met <- met %>%
  mutate(rWid = (Wid / Len) * 100, rHei = (Hei / Wid) * 100)
met$rWid <- round(met$rWid, 2)
met$rHei <- round(met$rHei, 2)

met1 <- filter(met, Orig == "Dep") %>%
  mutate(Gro = Orig)
met2 <- filter(met, Orig == "Bur" | Orig == "Set") %>%
  mutate(Gro = Lok )
met <- rbind(met1, met2)
met <- filter(met, !Lok == "Nit")

rm(list = "met1", "met2")

# Violin plots for L/W/H/M/rW/rH - descriptive ========================
# BW
ViolL <- met %>%
  ggplot(aes(x = Gro, y = Len)) +
  geom_violin(alpha = 0.8, color = "gray30") +
  geom_jitter(position = position_jitter(width = 0.04), pch = 21, col = "gray30", bg = "gray90") +
  theme(legend.position = "none") +
  ylab("Len (mm)") +
  xlab("Lokalita")

ViolW <- met %>%
  ggplot(aes(x = Gro, y = Wid)) +
  geom_violin(alpha = 0.8, color = "gray30") +
  geom_jitter(position = position_jitter(width = 0.04), pch = 21, col = "gray30", bg = "gray90") +
  theme(legend.position = "none") +
  ylab("Wid (mm)") +
  xlab("Lokalita")

ViolH <- met %>%
  ggplot(aes(x = Gro, y = Hei)) +
  geom_violin(alpha = 0.8, color = "gray30") +
  geom_jitter(position = position_jitter(width = 0.04), pch = 21, col = "gray30", bg = "gray90") +
  theme(legend.position = "none") +
  ylab("Hei (mm)") +
  xlab("Lokalita")

ViolM <- met %>%
  ggplot(aes(x = Gro, y = Mas)) +
  geom_violin(alpha = 0.8, color = "gray30") +
  geom_jitter(position = position_jitter(width = 0.04), pch = 21, col = "gray30", bg = "gray90") +
  coord_cartesian(ylim=c(0, 1100)) +
  theme(legend.position = "none") +
  ylab("Mas (g)") +
  xlab("Lokalita")

ViolrW <- met %>%
  ggplot(aes(x = Gro, y = rWid)) +
  geom_violin(alpha = 0.8, color = "gray30") +
  geom_jitter(position = position_jitter(width = 0.04), pch = 21, col = "gray30", bg = "gray90") +
  coord_cartesian(ylim=c(0, 80)) +
  theme(legend.position = "none") +
  ylab("rel. Wid") +
  xlab("Lokalita")

ViolrH <- met %>%
  ggplot(aes(x = Gro, y = rHei)) +
  geom_violin(alpha = 0.8, color = "gray30") +
  geom_jitter(position = position_jitter(width = 0.04), pch = 21, col = "gray30", bg = "gray90") +
  coord_cartesian(ylim=c(0, 200)) +
  theme(legend.position = "none") +
  ylab("rel. Hei") +
  xlab("Lokalita") +
  geom_hline(yintercept = 80, linetype = "dotted") +
  geom_hline(yintercept = 115, linetype = "dotted")
    # Dotted line - border between low, middle and tall shoe-last adzes
    # (acc. to Velímský 1967, 27; Štelcl & Malina ?, 124)

met <- met[-135, ]

pdf(file = "./Obr/nope/viol_dat.pdf")
met %>%
  ggplot(aes(x = Gro, y = rHei)) +
  geom_violin(alpha = 0.8, color = "gray30") +
  geom_jitter(aes(color = met$Dat), position = position_jitter(width = 0.04), pch = 20, bg = "gray90") +
  coord_cartesian(ylim=c(0, 200)) +
  ylab("rel. Hei") +
  xlab("Lokalita") +
  geom_hline(yintercept = 80, linetype = "dotted") +
  geom_hline(yintercept = 115, linetype = "dotted")
dev.off()

pdf(file = "./Obr/nope/viol_CultDat.pdf")
met %>%
  ggplot(aes(x = Gro, y = rHei)) +
  geom_violin(alpha = 0.8, color = "gray30") +
  geom_jitter(aes(color = met$CultDat), position = position_jitter(width = 0.04), pch = 20, bg = "gray90") +
  coord_cartesian(ylim=c(0, 200)) +
  ylab("rel. Hei") +
  xlab("Lokalita") +
  geom_hline(yintercept = 80, linetype = "dotted") +
  geom_hline(yintercept = 115, linetype = "dotted")
dev.off()

# # Export Violin plots
pdf(file = "ViolinPlots.pdf", height = 10, width = 8, pointsize = 18)
  grid.arrange(ViolL, ViolW, ViolH, ViolM, ViolrW, ViolrH)
dev.off()

# rm(list = "ViolL", "ViolW", "ViolH", "ViolM", "ViolrH", "ViolrW")

# # COL
# # Asi zbytečné
# met %>%
#   ggplot(aes(x = Orig, y = Len)) +
#   geom_violin(alpha = 0.5, color = "gray") +
#   geom_jitter(alpha = 0.5, position = position_jitter(width = 0.04),
#               aes(color = Lok)) +
#   theme(legend.position = "none") +
#   ylab("Délka (mm)") +
#   xlab("Lokalita")

# Scatterplots ================================================
# # create separate datasets for Ad a Ax
metAd <- filter(met, met$Morph == "Ad")
metAx <- filter(met, met$Morph == "Ax")
metWed <- filter(met, met$Morph == "We")

metBl <- filter(met, met$OpSeq == "Bl")
metFT <- filter(met, met$OpSeq == "FT")
metWa <- filter(met, met$OpSeq == "Wa")

# # Scatterplot Délka vs Šířka, asi k ničemu
# ggplot() +
#   geom_point(data = metAd, aes(x = Len, y = Wid, color = OpSeq), pch = 16) +
#   geom_point(data = metAx, aes(x = Len, y = Wid, color = OpSeq), pch = 17) +
#   geom_point(data = metWed, aes(x = Len, y = Wid, color = OpSeq), pch = 15) +
#   geom_density2d(data = metFT, aes(x = Len, y = Wid), alpha = 0.3, color = "forestgreen") +
#   geom_density2d(data = metBl, aes(x = Len, y = Wid), alpha = 0.3, color = "red2")
#   coord_cartesian(xlim = c(0, 100), ylim=c(0, 200)) +
#   labs(x = "Len", y = "Wid") +
#   theme(legend.position = "right")

# Scatterplot rel. W vs rel. H - k čemu je to dobré?
# ggplot() +
#   geom_point(data = metAd, aes(x = rWid, y = rHei), pch = 21, show.legend = TRUE) +
#   geom_point(data = metAx, aes(x = rWid, y = rHei), pch = 24, show.legend = TRUE) +
#   geom_point(data = metWed, aes(x = rWid, y = rHei), pch = 22, show.legend = TRUE) +
#   geom_density2d(data = metAd, aes(x = rWid, y = rHei), alpha = 0.6, color = "gray60") +
#   geom_density2d(data = metAx, aes(x = rWid, y = rHei), alpha = 0.4, color = "gray60") +
#   coord_cartesian(xlim = c(0, 100), ylim=c(0, 200)) +
#   labs(x = "rel. Wid", y = "rel. Hei") +
#   theme(legend.position = "right")

# # See Pavlu & Rulf 1991, 314-315
# # - Kopytovité sekery mají apriori nižší hodnoty relativní výšky, protože jsou ploché
# # - rHei < 50 cca, viz graf Pavlů & Rulf 1991
pdf(file = "Scat_Wid_rHei.pdf")
Wid.rHei <- met %>%
  ggplot(aes(x = Wid, y = rHei)) +
  geom_point(aes(shape = Morph, color = OpSeq)) +
  geom_density2d(data = metBl, aes(x = Wid, y = rHei), alpha = 0.2, color = "red2") +
  geom_density2d(data = metFT, aes(x = Wid, y = rHei), alpha = 0.2, color = "forestgreen") +
  geom_hline(yintercept = 50, linetype = "dotted") +
  coord_cartesian(ylim=c(0, 200)) +
  labs(x = "Wid (mm)", y = "rel. Hei") +
  theme(legend.position = c(0.95, 0.95), legend.justification = c("right", "top"),
        legend.box.just = "right",
        legend.margin = margin(6, 6, 6, 6))
dev.off()

pdf(file = "Scat_Wid_rWid.pdf")
Wid.rWid <- met %>%
  ggplot(aes(x = Wid, y = rWid)) +
  geom_point(aes(shape = Morph, color = OpSeq)) +
  geom_density2d(data = metBl, aes(x = Wid, y = rWid), alpha = 0.2, color = "red2") +
  geom_density2d(data = metFT, aes(x = Wid, y = rWid), alpha = 0.2, color = "forestgreen") +
  coord_cartesian(ylim = c(0, 75)) +
  labs(x = "Wid (mm)", y = "rel. Wid") +
  theme(legend.position = c(0.05, 0.95), legend.justification = c("left", "top"),
        legend.box.just = "right",
        legend.margin = margin(6, 6, 6, 6))
dev.off()

pdf(file = "Scat_Wid.pdf", width = 13, height = 7)
  grid.arrange(Wid.rHei, Wid.rWid, ncol = 2)
dev.off()

# Only Adzes --------
# # metAd
AdBl <- filter(metAd, metAd$OpSeq == "Bl")
AdFT <- filter(metAd, metAd$OpSeq == "FT")
AdWa <- filter(metAd, metAd$OpSeq == "Wa")

# metAd %>%
#   ggplot(aes(x = Len, y = Wid)) +
#   geom_point(aes(shape = OpSeq), fill = NA) +
#   scale_shape(solid = FALSE) +
#   stat_smooth(method = "lm")

# metAd %>%
#   ggplot(aes(x = Wid, y = rWid)) +
#   geom_point(aes(shape = OpSeq)) +
#   scale_shape_manual(values=c(23, 4, 9)) +
#   coord_cartesian(ylim = c(0, 55)) +
#   geom_density2d(data = AdBl, aes(x = Wid, y = rWid), alpha = 0.4, color = "red2") +
#   geom_density2d(data = AdFT, aes(x = Wid, y = rWid), alpha = 0.4, color = "forestgreen")

pdf(file = "Scat_Ad_Len_rHei.pdf")
metAd %>%
  ggplot(aes(x = Len, y = rHei)) +
  geom_point(aes(shape = OpSeq, color = OpSeq)) +
  scale_shape_manual(values=c(23, 4, 9)) +
  geom_density2d(data = AdBl, aes(x = Len, y = rHei), alpha = 0.4, color = "red2") +
  geom_density2d(data = AdFT, aes(x = Len, y = rHei), alpha = 0.4, color = "forestgreen") +
  theme(legend.position = c(0.95, 0.05), legend.justification = c("right", "bottom"),
        legend.box.just = "right", legend.margin = margin(6, 6, 6, 6)) +
  labs(caption = "(Ad only)", x = "Len (mm)", y = "rel. Hei")
dev.off()

# # Histogram četnosti rHei (viz Pavlů 1991) ================
# # - asi celkem k ničemu
# metAd %>%
#   ggplot() +
#   geom_histogram(aes(x = Wid), binwidth = 5, alpha = 0.5, col = "black")
#   geom_vline(xintercept = 95, linetype = "dotted") +
#   geom_vline(xintercept = 135, linetype = "dotted") +
#   labs(x = "Relativní výška", y = "Četnost")

# # Violin plots for Adzes only?
ViolAdL <- metAd %>%
  ggplot(aes(x = Gro, y = Len)) +
  geom_violin(alpha = 0.8, color = "gray30") +
  geom_jitter(position = position_jitter(width = 0.04), pch = 21, col = "gray30", bg = "gray90") +
  theme(legend.position = "none") +
  ylab("Len (mm)") +
  xlab("Lokalita")

metAd %>%
  ggplot(aes(x = Gro, y = Wid)) +
  geom_violin(alpha = 0.8, color = "gray30") +
  geom_jitter(aes(fill = metAd$OpSeq), position = position_jitter(width = 0.04), pch = 21) +
  xlab("Lokalita")

ViolAdW <- metAd %>%
  ggplot(aes(x = Gro, y = Wid)) +
  geom_violin(alpha = 0.8, color = "gray30") +
  geom_jitter(position = position_jitter(width = 0.04), pch = 21, col = "gray30", bg = "gray90") +
  theme(legend.position = "none") +
  ylab("Wid (mm)") +
  xlab("Lokalita")

ViolAdH <- metAd %>%
  ggplot(aes(x = Gro, y = Hei)) +
  geom_violin(alpha = 0.8, color = "gray30") +
  geom_jitter(position = position_jitter(width = 0.04), pch = 21, col = "gray30", bg = "gray90") +
  coord_cartesian(ylim = c(15, 60)) +
  theme(legend.position = "none") +
  ylab("Hei (mm)") +
  xlab("Lokalita")

ViolAdM <- metAd %>%
  ggplot(aes(x = Gro, y = Mas)) +
  geom_violin(alpha = 0.8, color = "gray30") +
  geom_jitter(position = position_jitter(width = 0.04), pch = 21, col = "gray30", bg = "gray90") +
  coord_cartesian(ylim=c(0, 1100)) +
  theme(legend.position = "none") +
  ylab("Mas (g)") +
  xlab("Lokalita")

ViolAdrW <- metAd %>%
  ggplot(aes(x = Gro, y = rWid)) +
  geom_violin(alpha = 0.8, color = "gray30") +
  geom_jitter(position = position_jitter(width = 0.04), pch = 21, col = "gray30", bg = "gray90") +
  coord_cartesian(ylim=c(8, 50)) +
  theme(legend.position = "none") +
  ylab("rel. Wid") +
  xlab("Lokalita")

ViolAdrH <- metAd %>%
  ggplot(aes(x = Gro, y = rHei)) +
  geom_violin(alpha = 0.8, color = "gray30") +
  geom_jitter(position = position_jitter(width = 0.04), pch = 21, col = "gray30", bg = "gray90") +
  coord_cartesian(ylim=c(40, 160)) +
  theme(legend.position = "none") +
  ylab("rel. Hei") +
  xlab("Lokalita") +
  geom_hline(yintercept = 80, linetype = "dotted") +
  geom_hline(yintercept = 115, linetype = "dotted")
# Dotted line - border between low, middle and tall shoe-last adzes
# (acc. to Velímský 1967, 27; Štelcl & Malina ?, 124)

# # Export Violin plots
pdf(file = "ViolinPlotsAdzes.pdf", height = 10, width = 8, pointsize = 18)
grid.arrange(ViolAdL, ViolAdW, ViolAdH, ViolAdM, ViolAdrW, ViolAdrH)
dev.off()

rm(list = ls())
graphics.off()


library(ggplot2)
library(grid)
library(gridExtra)

csvData <- read.csv("2014-03-08_gross_rent_as_percentage_of_household_income.csv", stringsAsFactors=FALSE)
csvData$Percentage <- factor(csvData$Percentage, levels=csvData[seq(1,18,2),]$Percentage, ordered=TRUE)
csvData$Number<-as.numeric(csvData$Number)
csvData$Err<-as.numeric(csvData$Err)

cbPalette <- c("#999999", "#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7")

ggplot(data=csvData,
       aes(x = Percentage, y = Number, fill=Universe),
       height=500,
       width=800) +
    geom_bar(stat="identity",
             xlab="2012 Distribution of Gross Rent as Percentage of Household Income",
             color="white") +
    scale_fill_manual(values = c(cbPalette[2],cbPalette[3])) +
    facet_grid(Universe ~ ., scales="free_y") +
    theme(axis.text.x=element_text(angle=60, hjust=1),
          axis.title.x=element_blank(),
          axis.text.y=element_blank(),
          axis.ticks.y=element_blank(),
          axis.title.y=element_blank(),
          legend.position="none")

USNumber=sum(subset(csvData,Universe=="US")$Number);
NYNumber=sum(subset(csvData,Universe=="NEW YORK")$Number);
csvDataUS=subset(csvData,Universe==factor("US"))
csvDataNY=subset(csvData,Universe==factor("NEW YORK"))
csvDataUS$RelativeNumber=(csvDataNY$Number/NYNumber)/(csvDataUS$Number/USNumber)

#ggplot(data=csvDataUS,
#       aes(x = Percentage, y = RelativeNumber, fill="darkgray"),
#       height=500,
#       width=800) +
#    geom_bar(stat="identity",
#             xlab="Distribution of Gross Rent as Percentage of Household Income",
#             color="white") +
#    theme(axis.text.x=element_text(angle=60, hjust=1),
#          axis.title.x=element_blank(),
#          legend.position="none")

ggsave("2014-03-08_gross_rent_as_percentage_of_household_income.png", width=8, height=5)


is.Matrix = function(x)
{
  inherits(x, "dgTMatrix") || inherits(x, "ngTMatrix")
}

# "triplet" form (aij)
mat2mm_dgTMatrix = function(x)
{
  I = x@i
  J = x@j
  val = x@x
  if (is.integer(val))
    valtype = "I"
  else if (is.double(val))
    valtype = "R"
  else
    stop("data should be integer or real")

  matcode = c("M", "C", valtype, "G")

  list(I=I, J=J, val=val, matcode=matcode)
}

mat2mm_ngTMatrix = function(x)
{
  I = x@i
  J = x@j
  val = NULL
  matcode = c("M", "C", "P", "G")

  list(I=I, J=J, val=val, matcode=matcode)
}

mat2mm = function(x)
{
  M = dim(x)[1]
  N = dim(x)[2]
  nz = Matrix::nnzero(x)

  if (inherits(x, "dgTMatrix"))
    mm = mat2mm_dgTMatrix(x)
  else if (inherits(x, "ngTMatrix"))
    mm = mat2mm_ngTMatrix(x)

  Imin = min(mm$I)
  Jmin = min(mm$I)
  indexing = as.integer(min(1L, Imin, Jmin))

  list(M=M, N=N, nz=nz, I=mm$I, J=mm$J, val=mm$val, matcode=mm$matcode, indexing=indexing)
}

mm2mat = function(mm)
{
  symmetric = mm_is_symmetric(mm$matcode)

  indx = mm$indexing
  if (indx == 0L)
  {
    I = mm$I + 1L
    J = mm$J + 1L
  }

  if (mm_is_pattern(mm$matcode))
    Matrix::sparseMatrix(i=I, j=J, symmetric=symmetric)
  else
    Matrix::sparseMatrix(i=I, j=J, x=mm$val, symmetric=symmetric)
}


#' @title zeroInflate or blanking
#' @description incorporates blanking distance by including zeros spaced eqully at the average nearest nieghbour distance, default blanking distance is the nearest neighbour distance of the most isolated point. Called by interpolation.
#' @param xyz = data.frame of points containing X and Y coordinates
#' @param blank.dist = distance at which zeros are inserted into the data set, defaults to the largest nearest neighbour distance i.e. the distance to the most isolated point in the data
#' @param aspr = aspect ratio for for creating square grid
#' @param type = how spaced out the zeros are, 1 = avg. nearest neighbour distance, 2 = blanking distance
#' @param eff = what data is inserted, intended for zeros
#' @param scale = how far beyond the range of the data are points inserted
#' @author Brad Hubley
#' @export

zeroInflate = function(xyz,blank.dist,scale=20,corners=NULL, aspr=1, type=2, eff=0,type.scaler=1){

	require(spatstat)
#    browser()
    pbd=F
    xyz.names = names(xyz)
    names(xyz) = c('X','Y','Z')
    pts = subset(xyz,select=c('X','Y'))
    if(!is.null(corners)){
        xmin = corners$plon[1]
        xmax = corners$plon[2]
        ymin = corners$plat[1]
        ymax = corners$plat[2]
        W = owin(corners$plon,corners$plat)
    }
    else{
        xmin = min(pts$X)
        xmax = max(pts$X)
        ymin = min(pts$Y)
        ymax = max(pts$Y)
        W = owin(c(xmin-scale,xmax+scale),c(ymin-scale,ymax+scale))
    }
    pts.ppp = as.ppp(pts,W)
    if(missing(blank.dist)){
        pbd=T
        blank.dist = max(nndist(pts.ppp))
    }
    if(type==1)dims = c(round((ymax-ymin)/(mean(nndist(pts.ppp))*type.scaler)*aspr),round((xmax-xmin)/(mean(nndist(pts.ppp))*type.scaler)))
    if(type==2)dims = c(round((ymax-ymin)/(blank.dist*type.scaler)*aspr),round((xmax-xmin)/(blank.dist*type.scaler)))
    blank.map = distmap(pts.ppp,dim=dims)
    blank.dat = data.frame(X=sort(rep(blank.map$xcol,blank.map$dim[1])),Y=rep(blank.map$yrow,blank.map$dim[2]),dist=as.vector(blank.map$v))
    blank.dat = subset(blank.dat,dist>blank.dist,c('X','Y'))
    xyz = merge(xyz,data.frame(blank.dat,Z=eff),all=T)
    if(pbd)print(paste("blanking distance",blank.dist))

    names(xyz) = xyz.names
    return(xyz)

}


#######################################################################################
#
# AssignClosestTempPoints(): R function
#
# Abstract:
# This R script assigns the closest of a set of point temparature measurements
# to each of a second set of point density measurements.
# The sp package 'spDistsN1' function is used to calculate Euclidean distances
# between points.
#
#
# Input Files (2): Comma-separated-value (CSV) files containing, respectively,
#                  point temperature and density measurements.
#
# Output File: Comma-separated-value (CSV) file containing the results table:
#              point density measurements and their location, and the location
#              index, closest temparature measurement, and distance to the
#              assigned measurement point.
#
# Notes:  To execute this script: 1) Start R,
#                                 2) Load this script into the workspace,
#                                 3) At R prompt, enter > AssignClosestTempPoints()
#
# Author: Rick Reeves
# Date created: August 2007
# Date revised: July 2010
# National Center for Ecological Analysis and Synthesis (NCEAS),
# University of California, Santa Barbara, CA USA
# http://www.nceas.ucsb.edu/scicomp
#
#######################################################################################
#
AssignClosestTempPoints <- function()
{

# Latest version: Assign closest points from a second point set

   require(sp)

   temperaturePoints <- read.csv("AssignClosestPointsToPoints/temperaturePoints.csv")
   densityPoints <- read.csv("AssignClosestPointsToPoints/densityPoints.csv")

# promote the input lists to SpatialPointsDataFrames

   coordinates(temperaturePoints) <- c("longitude", "latitude")
   coordinates(densityPoints) <- c("longitude", "latitude")

# Remove temparature points with 'invalid' value of -199

   validTempPoints <- temperaturePoints[!temperaturePoints$temperature %in% c(-199),]

#  Define these vectors, used in the loop.

   closestSiteVec <- vector(mode = "numeric",length = nrow(densityPoints))
   minDistVec     <- vector(mode = "numeric",length = nrow(densityPoints))

# Get the vector index of the temperature station closest to each field station.
# Use the spDistsN1 function to compute the distance vector between each
# field station site and all of the temperature stations. Then, find and
# retain the actual temperature, and the index of the closest temperature
# to each transect station.
#
# spDistsN1 usage: spDistsN1(pointList, pointToMatch, longlat)
#
# where:
#         pointList   : List of candidate points.
#         pointToMatch: Single point for which we seek the closest point in pointList.
#         longlat     : TRUE  computes Great Circle distance in km,
#                       FALSE computes Euclidean distance in units of input geographic coordinates
#
# We use Great Circle distance to increase distance calculation accuracy at high latitudes
# See the discussion of distance units in the header portion of this file
#
# minDistVec stores the distance from to the closest temperature station to each density measurement point.
# closestSiteVec stores the index of the closest temperature station to each density measurement point.
#
   for (i in 1 : nrow(densityPoints))
   {
      distVec <- spDistsN1(validTempPoints,densityPoints[i,],longlat = TRUE)
      minDistVec[i] <- min(distVec)
      closestSiteVec[i] <- which.min(distVec)
   }
#
# Create the output file: merge the temperature point list with the transect point list
# into a five-column table by merging the temperature point and transect point lists.
#
   PointAssignTemps <- as(validTempPoints[closestSiteVec,]$temperature,"numeric")
   FinalTable = data.frame(coordinates(densityPoints),densityPoints$density,closestSiteVec,minDistVec,PointAssignTemps)
#
# Update the FinalTable column names
#
   names(FinalTable) <- c("Long","Lat","Density","CloseTempIndex","Distance","Temperature")
#
# And, at the end, write the point assignment file.
#
  message("Write temperature/density assignment table to disk in .csv format")
  write.csv(FinalTable,file="FinalTempAssignments.csv")
}


library(ggplot2)

# CHR, BP, P
d <- read.table("data.txt", header=TRUE)

# chromosome color
col <- c("gray10", "gray60")

# genome-wide threshold line
threshold <- -log10(0.05/nrow(d))

d <- d[order(d$CHR,d$BP),]
d$logp <- -log10(d$P)

chrid <- unique(d$CHR)
d$idx <- rep.int(seq_along(chrid), times=tapply(d$BP,d$CHR,length))
d$pos <- NA

last <- 0
for (i in unique(d$idx)) {
    w <- d$idx == i
    d[w,]$BP <- d[w,]$BP - min(d[w,]$BP) + 1
    if (i == 1) {
        d[w,]$pos <- d[w,]$BP
    } else {
        last <- last + max(d[d$idx==(i-1),]$BP)
        d[w,]$pos <- d[w,]$BP + last
    }
}

x.ticks <- tapply(d$pos, d$idx, function(x) sum(range(x))/2)
y.ticks <- pretty(c(d$logp,threshold))
y.max <- ceiling(max(max(d$logp),threshold))

col <- rep(col, length.out=length(chrid))

p1 <-
ggplot(d, aes(pos,logp)) +
geom_point(size=0.5, aes(color=factor(idx)), show.legend=FALSE) +
geom_hline(yintercept=threshold, color="red") +
scale_x_continuous(breaks=x.ticks, labels=chrid, expand=expand_scale(mult=c(0.01,0.01))) +
scale_y_continuous(breaks=y.ticks, limits=c(0,y.max), expand=expand_scale(mult=c(0,0.01))) +
expand_limits(x=0, y=0) +
scale_color_manual(values=col) +
xlab("Chromosome") +
ylab(expression(-log[10](italic(p)))) +
theme_classic(base_size=10) +
theme(
line = element_line(lineend="square"),
axis.text = element_text(size=rel(0.8), color="black"),
axis.ticks = element_line(color="black")
)

p <- d$P
tmp <- data.frame(
    o = -log10(sort(p,decreasing=FALSE)),
    e = -log10(ppoints(length(p)))
)

p2 <-
ggplot(tmp, aes(e,o)) +
geom_point(size=0.5) +
geom_abline(intercept=0, slope=1, color="red") +
xlab(expression(Expected~~-log[10](italic(p)))) +
ylab(expression(Observed~~-log[10](italic(p)))) +
scale_x_continuous(expand=expand_scale(mult=c(0,0.01))) +
scale_y_continuous(breaks=y.ticks, limits=c(0,y.max), expand=expand_scale(mult=c(0,0.01))) +
theme_classic(base_size=10) +
theme(
line = element_line(lineend="square"),
axis.text = element_text(size=rel(0.8), color="black"),
axis.ticks = element_line(color="black")
)

#ggsave("p1.pdf", p1, width=14, height=5, units="cm")
ggsave("p1.tiff", p1, width=14, height=5, units="cm", compression="lzw")

#ggsave("p2.pdf", p2, width=6, height=5, units="cm")
ggsave("p2.tiff", p2, width=6, height=5, units="cm", compression="lzw")


#----------------------------------------------------------------------------#
#' @title summary mod
#' @description summary mod glm
#' @param mod a glm mod
#' @import stats
#' @export
summary2_glm = function(mod) {
  out1 =
  cbind(exp(cbind(OR = coef(mod),
                  confint.default(mod))),
        P.value = round(coef(summary(mod))[,4],5))
  return(out1)
}


 ZTRSEN Example Program Results

 Matrix A created from Q*T*Q^T
                    1                 2                 3                 4
 1  (-3.9702,-5.0406) (-4.1108, 3.7002) (-0.3403, 1.0098) ( 1.2899,-0.8590)
 2  ( 0.3397,-1.5006) ( 1.5201,-0.4301) ( 1.8797,-5.3804) ( 3.3606, 0.6498)
 3  ( 3.3101,-3.8506) ( 2.4996, 3.4504) ( 0.8802,-1.0802) ( 0.6401,-1.4800)
 4  (-1.0999, 0.8199) ( 1.8103,-1.5905) ( 3.2502, 1.3297) ( 1.5701,-3.4397)

 Condition number estimate of the selected cluster of eigenvalues =   1.02E+00

 Condition number estimate of the specified invariant subspace    =   1.82E-01


#  James Rekow

createFracturedAbdList = function(M = 40, numSubgroups = 1, N = 20, iStrength = 1, univ = 1, sigmaMax = 0.1,
                                  thresholdMult = 10 ^ (-1), maxSteps = 10 ^ 4, tStep = 10 ^ (-2),
                                  intTime = 1, interSmplMult = 0.01, lambda = 0, returnParams = FALSE,
                                  conGraph = NULL){

  #  ARGS: numSubgroups - the number of subgroups into which the cohort will be divided. If this value
  #                       is greater than one then each subgroup is created as a separate cohort before
  #                       being combined and interacted as a single cohort
  #
  #  RETURNs: abdList - list of integrated and interacted (if lambda > 0) abundances

  source("cohortCreator.r")
  source("intraCohortInteraction.r")
  source("partition.r")

  #  create vector with the number of samples in each subgroup
  subgroupSizeVec = partition(n = M, numPartitions = numSubgroups)

  createSubgroup = function(subgroupSize){

    subgroup = cohortCreator(M = subgroupSize, N = N, iStrength = iStrength, univ = univ,
                             sigmaMax = sigmaMax)

    return(subgroup)

  } #  end createSubgroup function

  subgroupList = lapply(as.list(subgroupSizeVec), createSubgroup)
  chrt = unlist(subgroupList, recursive = FALSE)

} #  end createFracturedAbdList function


#' @title calcKristCr
#'
#' @description Calculate the residual resistance coefficient (\code{Cr})
#' (dimensionless) using the Kristensen method with Harvald regressions.
#'
#'@param shipType Ship type (vector of strings, see \code{\link{calcShipType}})
#'@param M Fineness/slenderness coefficient (vector of numericals,
#'dimensionless) (see \code{\link{calcShipM}})
#'@param froudeNum Froude number (vector of numericals, dimensionless) (see
#'\code{\link{calcFroudeNum}})
#'@param actualDraft Actual draft (vector of numericals, m)
#'@param breadth Moulded breadth (vector of numericals, m)
#'@param Cp Prismatic coefficient (vector of numericals, dimensionless) (see
#'\code{\link{calcCp}})
#'@param tankerBulkCarrierGCargoShipTypes Ship types specified in input
#'\code{shipTypes} to be modeled as tankers, bulk carriers and general cargo
#'vessels (vector of strings)
#'
#' @details
#'Note: Uses Guldhammer Residual Resistance Calculation and adjusts for bulbous bow, and
#'breadth/draft ratio.
#'
#' This method this requires ship types to be grouped. Use the
#' \code{tankerBulkCarrierGCargoShipTypes} grouping
#' parameters to provide these ship type groupings. Any ship types not include
#' this grouping will be considered as miscellaneous vessels.
#'
#' Actual draft is typically obtained from sources such as AIS messages or ship
#' records.
#'
#' @return \code{Cr} (vector of numericals, dimensionless)
#'
#' @references
#'Kristensen, H. O. and Lutzen, M. 2013. "Prediction of Resistance and Propulsion
#'Power of Ships."
#'
#'\href{https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}{Kristensen, H. O.
#'"Ship-Desmo-Tool." https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}
#'
#'@seealso \itemize{
#'\item \code{\link{calcShipM}}
#'\item \code{\link{calcFroudeNum}}
#'\item \code{\link{calcCp}}
#'\item \code{\link{calcShipType}}
#'}
#'
#' @family Kristensen Calculations
#' @family Resistance Calculations
#'
#' @examples
#' calcKristCr("bulk.carrier", 5.2, 0.1199268, 12.48, 32.25, 0.81)
#'
#' @export

calcKristCr <- function(shipType, M, froudeNum, actualDraft, breadth, Cp,
                        tankerBulkCarrierGCargoShipTypes=c("tanker","general.cargo","chemical.tanker","liquified.gas.tanker","oil.tanker","other.tanker","bulk.carrier")
){

E<- (
  (1.35-(0.23*M)+0.012*(M^2))+
    (1.5*(froudeNum^1.8))+
    ( 0.0011*(M^9.1)*(froudeNum^(2*M-3.7)))
)*
  (0.98+(2.5/((M-2)^4)))+
  ((M-5)^4)*((froudeNum-0.1)^4)

G<- ((7-0.09*((M)^2))*(((5*Cp)-2.5)^2))/
  ((600*((froudeNum-0.315)^2)+1)^1.5)

H<-exp(
  80*(froudeNum-(0.04+(0.59*Cp))-0.015*(M-5))
)

  #Calculate Cr
  #Source: Kristensen(2016) using Guldhammer(1978) method
  Cr<-((
        (1.35-(0.23*M)+0.012*(M^2))+
        (1.5*(froudeNum^1.8))+
        ( 0.0011*(M^9.1)*(froudeNum^(2*M-3.7)))
        )*
        (0.98+(2.5/((M-2)^4)))+
        ((M-5)^4)*((froudeNum-0.1)^4)+
        (
          ((7-0.09*((M)^2))*(((5*Cp)-2.5)^2))/
          ((600*((froudeNum-0.315)^2)+1)^1.5)
        )+
        exp(
            80*(froudeNum-(0.04+(0.59*Cp))-0.015*(M-5))
            )+
        ( 180*(froudeNum^3.7)*exp((20*Cp)-16))+
        #correction for vessels where B/T!=2.5
        (.16*((breadth/actualDraft)-2.5))
      )/1000

  #Apply Cr Correction for bulbous bow shape according to ship type.
  #Bulbous bows have become more common since these regressions were
  #made, they cut down on a lot of resistance
  Cr<- ifelse( shipType %in%tankerBulkCarrierGCargoShipTypes,

               Cr+ pmax(-0.4, -0.1-1.6*froudeNum)/1000,

               Cr+ pmax(-50,250*froudeNum-90)* (Cr/100)

                )#end ifelse

  return(Cr)

}


library(Cairo)

G1Cells = function( wellPath, G1, DNAChannel=1, zCutoff=2.5 ){
  DNA    = read.table( paste( wellPath, '-', DNAChannel, '.csv',sep='' ), stringsAsFactors=F, header=T, sep=',')
  cvs    = DNA$std_nucleus / DNA$mean_nucleus
  keep   = cvs < G1$CV.max & cvs > G1$CV.min

  logDNA = log( DNA$sum_nucleus )
  keep   = keep & logDNA < G1$mean.1 + zCutoff*G1$sd.1 & logDNA > G1$mean.1 - zCutoff*G1$sd.1

  return( keep )
}

CairoSVG('readoutInformation',width=10,height=5)
par(mfrow=c(2,4))

#### Plot distributions from TI08 to show MI of TGFB3 or BMP4
#### and their readouts.

##### The following file will only exist after this script has been
##### run, followed by the mutual_information_readouts.m script
mutualInfoFile  = 'data/readoutInformation.csv'
#####

data        = read.table('W:/2013_06_wnt_tgfb_crosstalk/TI08/TI08_summaryStats.csv',header=T,sep=',',stringsAsFactors=F)
segRoot     = 'W:/2013_06_wnt_tgfb_crosstalk/plates/140404_TI08/segmentation/NUCLEI_DATA/'
G1          = read.table("W:/2013_06_wnt_tgfb_crosstalk/plates/140404_TI08/segmentation/SKMEL2_G1.csv",header=T,sep=',',stringsAsFactors=F)
experiments = c('TGFB.readouts','BMP.readouts')
incols      = c('blue','darkgreen')
names(incols) = experiments
readouts    = matrix(c('pSmad23','Smad23','pSmad158','Smad1'),nrow=2)
colnames(readouts) = experiments
features    = c('median_nucleus','sum_nucleus')
channel     = '2'
bins        = 15

for( feature in features){
  for( experiment in experiments ){
    for( readout in readouts[,experiment]){
      subdata    = data[data$experiment==experiment &
                        data[,paste('marker',channel,sep='.')]==readout,]
      treatments = unique(subdata$treatment)
      wells = c()
      xlims = c(Inf,-Inf)
      for( treatment in treatments ){
        # Find well with median well-level value
        wells  = c(wells,subdata$well[subdata$treatment==treatment])
      }
      wells = matrix(wells,nrow=3)
      colnames(wells)=treatments

      hists = c()
      xlims = c(Inf,-Inf)
      for( treatment in treatments ){
        allVals = c()
        for( well in wells[,treatment]){
          wellpath    = paste(segRoot,well,sep='')
          singleCells = read.table( paste( wellpath,'-',channel,'.csv',sep='' ),
                                    sep=',', header=T, stringsAsFactors=F )
          dna         = read.table( paste( wellpath,'-1.csv',sep='' ),
                                    sep=',', header=T, stringsAsFactors=F )
          keepers     = G1Cells(wellpath,G1)
          singleCells = singleCells[keepers,paste(feature)]
          dna         = dna[keepers, paste(feature)]
          # Normalize!
          fit         = lm( log2(singleCells) ~ log2(dna) )
          singleCells = 2^(median(log2(singleCells)) + fit$residuals)
          allVals     = c(allVals,singleCells)

        }
        allVals = log2(allVals)
        # Trim the outliers
        allVals = allVals[allVals<(median(allVals)+3*mad(allVals)) &
                          allVals>(median(allVals)-3*mad(allVals))]
        # Write to file for idiot-Matlab
        write.csv(allVals,paste('data/',readout,treatment,feature,'csv',sep='.'),
                  row.names=F)
        hists[[treatment]] = hist(allVals,breaks=bins,plot=F)
        xlims = c(min(xlims[1],hists[[treatment]]$mids),
                  max(xlims[2],hists[[treatment]]$mids))
      }

      # Set up a plot
      plot(NA,NA,ylim=c(0,1),xlim=2^xlims, main=feature,
           xlab=readout,
           ylab='Frequency', yaxt='n')
      cols = c('black',incols[experiment])
      names(cols) = treatments
      for( treatment in treatments ){
        lines( 2^hists[[treatment]]$mids,
               hists[[treatment]]$density/max(hists[[treatment]]$density),
               col=cols[treatment],lwd=2)
      }
      legend('topright',treatments,text.col=cols[treatments],bty='n')
      if( file.exists(mutualInfoFile) ){
        mutualInfo = read.table(mutualInfoFile,header=T,sep=',')
        miMean     = mutualInfo[paste(readout,feature,'meanMI',sep='.')]
        miSd       = mutualInfo[paste(readout,feature,'sdMI',sep='.')]
        legend('right',c(paste(round(miMean,2),'+/-',
                               round(miSd,  2)),
                         paste('n=(',sum(hists[[1]]$counts),',',
                               sum(hists[[2]]$counts),')',sep='')),
               bty='n')}
    }
  }
}
dev.off()


# Create Data
false_positive_perc=c(132,13,313,21)
false_positive_names=c("Unknown","Timeout/OME", "Undefined", "Not Implemented")
labs <- paste(false_positive_names, " (", false_positive_perc, ")", sep="")
pie(false_positive_perc, labels=labs, radius=.5, cex=1.1)


# set up
# packages
library(here)
library(tidyverse)
library(ggthemes)
library(sf)

# data
az_counties <- read_rds("data/tidy/spatial_az_counties.rds")
event_summary <- read_rds("data/tidy/spatial_event_summary.rds")
virtual_participants <- read_rds("data/tidy/spatial_virtual_participants.rds")

glimpse(event_summary)

event_summary %>%
  drop_na(participants_per_event) %>%
  summarize(
    minimum = min(participants_per_event),
    sd = sd(participants_per_event),
    median = median(participants_per_event),
    maximum = max(participants_per_event)
  ) %>%
  knitr::kable()

event_summary %>%
  drop_na(participants_per_event) %>%
  mutate(log_participants = log10(participants_per_event)) %>%
  summarize(
    minimum = min(log_participants),
    sd = sd(log_participants),
    median = median(log_participants),
    maximum = max(log_participants)
  )

ggplot(data = event_summary, mapping = aes(x = participants_per_event)) +
  geom_histogram(bins = 30)

fivenum(event_summary$participants_per_event)

event_summary %>%
  drop_na(participants) %>%
  mutate(log_participants = log10(participants_per_event)) %>%
  ggplot() +
  geom_sf(data = az_counties, fill = "#E2E9EB") +
  geom_sf(mapping = aes(geometry = geometry, fill = log_participants)) +
  geom_sf(data = virtual_participants, color = "#AB0520", alpha = 0.5, size = 3, show.legend = TRUE) +
  scale_fill_distiller(
    palette = "YlGnBu",
    name = "log(Participants)"
  ) +
  theme_void() +
  labs(
    title = "Statewide COE Outreach Events",
    subtitle = "Logarithmic transformation of participants per event"
  )

event_summary %>%
  mutate(fill_value = cut_number(participants, n = 5)) %>%
  ggplot() +
  geom_sf(data = az_counties,
          fill = "#E2E9EB",
          alpha = 0.8) +
  geom_sf(mapping = aes(geometry = geometry,
                        fill = fill_value,
                        color = fill_value),
          alpha = 0.8) +
  geom_sf(data = virtual_participants,
          color = "#AB0520",
          alpha = 0.3,
          size = 3,
          show.legend = FALSE) +
  scale_fill_brewer(
    aesthetics = c("color", "fill"),
    palette = "YlGnBu",
    name = "Participants",
    labels = c("<40", "<80", "<150", "<331", ">=331")
  ) +
  theme_void() +
  labs(
    title = "Statewide COE Outreach Events",
    subtitle = "Participants in Each Zip Code"
  ) +
  theme(
    legend.title = element_text(size = 20),
    legend.text = element_text(size = 18),
    plot.title = element_text(size = 22),
    plot.subtitle = element_text(size = 18)
  )

event_summary %>%
  drop_na(participants) %>%
  # mutate(log_participants = log10(participants_per_event)) %>%
  ggplot() +
  geom_sf(data = az_counties, fill = "#E2E9EB") +
  geom_sf(mapping = aes(geometry = geometry, fill = participants)) +
  geom_sf(data = virtual_participants, color = "#AB0520", alpha = 0.5, size = 3, show.legend = TRUE) +
  ylim(32, 32.5) +
  xlim(-111.5, -110.5) +
  scale_fill_distiller(
    palette = "YlGnBu",
    name = "Participants"
  ) +
  theme_void() +
  labs(
    title = "Statewide COE Outreach Events",
    subtitle = "Tucson and Surrounding Area "
  )

event_summary %>%
  drop_na(participants) %>%
  # mutate(log_participants = log10(participants_per_event)) %>%
  ggplot() +
  geom_sf(data = az_counties, fill = "#E2E9EB") +
  geom_sf(mapping = aes(geometry = geometry, fill = participants)) +
  geom_sf(data = virtual_participants, color = "#AB0520", alpha = 0.5, size = 3, show.legend = TRUE) +
  ylim(33.1, 33.8) +
  xlim(-112.4, -111.4) +
  scale_fill_distiller(
    palette = "YlGnBu",
    name = "Participants"
  ) +
  theme_void() +
  labs(
    title = "Statewide COE Outreach Events",
    subtitle = "Phoenix and Surrounding Area "
  )


#data = pd.read_csv(log_file, delim_whitespace=True)
#data = data[data.Time != 'END'] #removes the end of round lines
#total_deaths = data[(data.CausaMortis == "fluor") | (data.CausaMortis == 'phosph') | (data.CausaMortis == 'nonrad')]

# Average lifetime calculator:
#def avg_lifetime(total_deaths):
#    #total_deaths = data[(data.CausaMortis == "fluor") | (data.CausaMortis == 'phosph') | (data.CausaMortis == 'nonrad')]
#    lifetime = total_deaths['Time'].to_numpy(float)
#    avg_life = np.mean(lifetime)
#    return avg_life
#
## Diffusion Length calculator:
#def ld_calculator(total_deaths):
#    #total_deaths = data[(data.CausaMortis == "fluor") | (data.CausaMortis == 'phosph') | (data.CausaMortis == 'nonrad')]
#    dx = total_deaths['DeltaX'].to_numpy(float)
#    dy = total_deaths['DeltaY'].to_numpy(float)
#    dz = total_deaths['DeltaZ'].to_numpy(float)
#    diffusion_length = np.sqrt(np.mean(dx**2+dy**2+dz**2))
#    return diffusion_length
#
#Ld  = ld_calculator(total_deaths)
#tau = avg_lifetime(total_deaths)
#print("Average lifetime is: ", "{:.2f}".format(tau), 'ps')
#print('Diffusion length is:', "{:.2f}".format(Ld), 'AA')

#avg
#dead

#data

#recria o que eu fazia no bash, preciso mudar a forma e usar o uniq nas colunas status (dead e converted)
#fluor_NPB  = dead[(dead.CausaMortis == "fluor") & (dead.Location == 0.0)]
#nonrad_NPB = dead[(dead.CausaMortis == "nonrad") & (dead.Location == 0.0)]
#ISC_NPB = data[(data.Status == "converted") & (data.CausaMortis == "isc") & (data.Location == 0.0)]
#rISC_NPB = data[(data.Status == "converted") & (data.CausaMortis == "risc") & (data.Location == 0.0)]
#
#print("Fluor NPB:",len(fluor_NPB)) #bash
#print("Nonrad NPB:",len(nonrad_NPB)) #bash
#print("ISC NPB:",len(ISC_NPB)) #bash
#print("rISC NPB:",len(rISC_NPB)) #bash
#print("--------------------------------------")
#
#fluor_DCJTB = dead[(dead.CausaMortis == "fluor") & (dead.Location == 1.0)]
#nonrad_DCJTB = dead[(dead.CausaMortis == "nonrad") & (dead.Location == 1.0)]
#ISC_DCJTB = data[(data.Status == "converted") & (data.CausaMortis == "isc") & (data.Location == 1.0)]
#rISC_DCJTB = data[(data.Status == "converted") & (data.CausaMortis == "risc") & (data.Location == 1.0)]
#print("Fluor DCJTB:",len(fluor_DCJTB)) #bash
#print("Nonrad DCJTB:",len(nonrad_DCJTB)) #bash
#print("ISC DCJTB:",len(ISC_DCJTB)) #bash
#print("rISC DCJTB:",len(rISC_DCJTB)) #bash
#print("--------------------------------------")
#
#TTS_NPB_NPB = data[(data.Status == "converted") & (data.CausaMortis == "tts") & (data.Location == 0.0)]
#TTS_NPB_DCJTB = data[(data.Status == "converted") & (data.CausaMortis == "tts") & (data.Location == 1.0)]
#print("TTS NPB p/ NPB:", len(TTS_NPB_NPB))
#print("TTS NPB p/ DCJTB:", len(TTS_NPB_DCJTB))

Triplets/Round_1/#data = pd.read_csv(log_file, delim_whit.r


x <- c(5,7,8,7,2,2,9,4,11,12,9,6)
y <- c(99,86,87,88,111,103,87,94,78,77,85,86)

plot(x, y)


MODE <- '72hrs'
# save('list.predglm',
#      'list.predxgb',
#      'list.rocglm',
#      'list.rocxgb',
#      'list.xgbparam',
#      'list.glm',
#      'list.xgb',
#      'list.featurenames',
#      'list.labels',
#
#      'list.train.in',
#      'list.test.in',
#      'list.train.out',
#      'list.test.out',
#
#      file=paste('./results/aucs_FEB2018_', MODE,'_data.RData', sep=''))
source('fMeasure.R')
library(pROC)
library(glmnet)
library(xgboost)
source('calcDeciles.R')

load(paste('./results/aucs_FEB2018_', MODE,'_data.RData', sep=''))

list.f.glm <- list()
list.f.xgb <- list()
aucs.glm <- vector()
aucs.xgb <- vector()
for(f in 1:5) {
  list.f.glm[[f]] <- allROC_par(list.predglm[[f]], list.labels[[f]][[2]])[[1]]
  list.f.xgb[[f]] <- allROC_par(list.predxgb[[f]], list.labels[[f]][[2]])[[1]]
  aucs.glm[f] <- list.rocglm[[f]]$auc
  aucs.xgb[f] <- list.rocxgb[[f]]$auc
}

precision.xgb <- vector()
precision.glm <- vector()
recall.xgb <- vector()
recall.glm <- vector()

f.xgb <- vector()
f.glm <- vector()
for(f in 1:5) {
  f.xgb[f] <- list.f.xgb[[f]]$f.score[1]
  f.glm[f] <- list.f.glm[[f]]$f.score[1]

  precision.xgb[f] <- list.f.xgb[[f]]$pr[1]
  precision.glm[f] <- list.f.glm[[f]]$pr[1]

  recall.xgb[f] <- list.f.xgb[[f]]$re[1]
  recall.glm[f] <- list.f.glm[[f]]$re[1]

}

library(SpecsVerification)
#list.labels
#list.predglm
#list.predxgb

rel <- vector()
res <- vector()
unc <- vector()
score <- vector()
labels <- vector()
probs.xgb <- vector()

for(f in 1:5) {
  labels <- c(labels, list.labels[[f]][[2]])
  probs.xgb <- c(probs.xgb, list.predxgb[[f]])
  bd <- BrierDecomp(list.predxgb[[f]], list.labels[[f]][[2]])
  rel[f] <- bd[1,1]
  res[f] <- bd[1,2]
  unc[f] <- bd[1,3]
  score[f] <- rel[f] - res[f] + unc[f]

}

bd.total <- BrierDecomp(probs.xgb, labels)

rel <- c(rel, bd.total[1,1])
res <- c(res, bd.total[1,2])
unc <- c(unc, bd.total[1,3])
score <- c(score, bd.total[1,1] - bd.total[1,2] + bd.total[1,3])

bd.df <- data.frame(rel, res, unc, score)
rownames(bd.df) <- c('fold1', 'fold2', 'fold3', 'fold4', 'fold5', 'total')

source('calcDeciles.R')
for(f in 1:5) {
  df <- calcDeciles(list.predxgb[[f]], list.labels[[f]][[2]]) [[1]]
  write.csv(df, file=paste('./results/calibration_fold_', f,'_', MODE, '.csv', sep=''))
}


rm(list = ls())
library(SuperLearner)
source('utils.r')
source('slfunctions.r')
source('estim.r')

estima <- function(i){
    seed <- task[i, 'seed']
    n <- task[i, 'n']

    set.seed(seed)
    data <- simdata(n)

    Y <- data[, "Y"]
    Z <- data[, substr(names(data), 1, 1) == "Z"]
    L <- data[, "L"]
    A <- data[, "A"]
    W <- data[, substr(names(data), 1, 1) == "W"]

    nuisance <- fitnuisance(data, nfolds = 5)

    nuisance1 <- nuisance2 <- nuisance3 <- nuisance4 <- nuisance5 <- nuisance

    nuisance1$fitg <- mySL(
        Y = A,
        X = W,
        family = stats::binomial(),
        SL.library = c('SL.mean'),
        validRows = nuisance$valSets)
    nuisance2$fite <- mySL(
        Y = A,
        X = data.frame(Z, W),
        family = stats::binomial(),
        SL.library = c('SL.mean'),
        validRows = nuisance$valSets)
    nuisance3$fitm <- mySL(
        Y = Y,
        X = data.frame(Z, A, L, W),
        family = stats::binomial(),
        SL.library = c('SL.mean'),
        validRows = nuisance$valSets)
    nuisance4$fitb <- mySL(
        Y = L,
        X = data.frame(A, W),
        family = stats::binomial(),
        SL.library = c('SL.mean'),
        validRows = nuisance$valSets)
    nuisance5$fitd <- mySL(
        Y = L,
        X = data.frame(Z, A, W),
        family = stats::binomial(),
        SL.library = c('SL.mean'),
        validRows = nuisance$valSets)

    nuisances <- list(nuisance, nuisance1, nuisance2, nuisance3, nuisance4, nuisance5)

    out <- lapply(1:6, function(j) {
        out <- estimators(data, delta = 2, nuisances[[j]], seed = seed,
                          type = j - 1)
        return(out)
        })

    return(Reduce(rbind, out))

}

rep <- 1000
set.seed(48838)
seed <- sample(1e8, rep)
task <- expand.grid(seed = seed, n = cumsum(rep(sqrt(200), 9))^2)
## task <- expand.grid(seed = seed, n = rep(sqrt(200), 4)^2)

funslave <- function(j){

    index <- (1:nrow(task))[(1:nrow(task) - 1) %% 1200 + 1 == j]

    out <- lapply(index, function(k){
        ret <- estima(k)
        return(ret)
    })

    return(out)

}

## n    <- 1e5
## seed <- 29803457
## set.seed(seed)
## data <- simdata(n)

## nuisance <- fitnuisance(data, nfolds = 5)

## z <- Z; a <- A; l <- L; y <- Y; w <- W
## plot(pzaw(z, a, w) / pz(z, l, a, w), b / d)
## abline(0,1)

## plot(gdeltafun(a, w, delta) / gfun(a, w), gdelta / g)
## abline(0,1)

## plot(my(z, l, a, w), m)
## abline(0,1)

## eif10 <- pzaw(z, a, w) / pz(z, l, a, w) * (y - my(z, l, a, w)) +
##     v(l, a, w) - vbar(a, w) + u(z, a, w)

## eif1d <- gdeltafun(a, w, delta) / gfun(a, w) * pzaw(z, a, w) / pz(z, l, a, w) *
##     (y - my(z, l, a, w)) +
##     gdeltafun(a, w, delta) / gfun(a, w) * (v(l, a, w) - vbar(a, w) + u(z, a, w)) +
##     (1 - gdeltafun(a, w, delta) / gfun(a, w)) *
##     (ubar(1, w) * gdeltafun(1, w, delta) + ubar(0, w) * gdeltafun(0, w, delta))

## eif2d <- gdeltafun(a, w, delta) / gfun(a, w) * pzw(z, w) / pz(z, l, a, w) *
##     (y - my(z, l, a, w)) +
##     gdeltafun(a, w, delta) / gfun(a, w) * (s(l, a, w) - sbar(a, w)) +
##     u(z, 1, w) * gdeltafun(1, w, delta) + u(z, 0, w) * gdeltafun(0, w, delta) +
##     gdeltafun(a, w, delta) / gfun(a, w) * (q(a, w) - (q(1, w) * gdeltafun(1, w, delta) +
##                                                       q(0, w) * gdeltafun(0, w, delta)))

## eifde <- eif10 - eif2d
## eifie <- eif2d - eif1d

## plot(eifde, eifD)
## abline(0,1)

## plot(eifie, eifI, col = a+1)
## abline(0,1)

## tmpA <- gdeltafun(a, w, delta) / gfun(a, w) *
##     ((q(a, w) - (q(1, w) * gdeltafun(1, w, delta) + q(0, w) * gdeltafun(0, w, delta))) -
##      (ubar(a, w) - (ubar(1, w) * gdeltafun(1, w, delta) + ubar(0, w) * gdeltafun(0, w, delta))))
## plot(MI * (A - g1), tmp)
## abline(0,1)

## tmpY <- (gdeltafun(a, w, delta) / gfun(a, w) * pzw(z, w) / pz(z, l, a, w) -
##                     gdeltafun(a, w, delta) / gfun(a, w) * pzaw(z, a, w) / pz(z, l, a, w)) *
##                    (y - my(z, l, a, w))
## plot(HI * (Y - m), tmpY)
## abline(0,1)

## tmpZ <- gdeltafun(a, w, delta) / gfun(a, w) *  (u(z, a, w) - ubar(a, w))
## plot(HI * (Y - m), tmpY)
## abline(0,1)

## eifD <- HD * (Y - m) + KD * (L - b1A) + MD * (A - g1) + (uA - ubarA) + de
## eifI <- HI * (Y - m) + KI * (L - b1A) + MI * (A - g1) + J * (uA - ubarA) + ie


cat(sapply(strsplit(readLines(tail(commandArgs(), n=1)), " "), function(s) {
  d <- as.integer(strsplit(s[1], ":")[[1]]) - as.integer(strsplit(s[2], ":")[[1]])
  t <- abs(d[1]*3600 + d[2]*60 + d[3])
  sprintf("%02d:%02d:%02d", as.integer(t/3600), as.integer(t/60) %% 60, t %% 60)
}), sep="\n")


library(assertthat)
library(psych)

source("data_structures.r")
source("sampling.r")

calculate_ate_from_cf_and_write_it_to_file<-function(data_name){
  assert_that(is.character(data_name))

  cf <- read.csv(file=sprintf("../../../data/real_data_raw/%s_cf.csv",data_name),
                     header=TRUE, sep=",")

  ate<- (sum(cf$y1)-sum(cf$y0))/length(cf$y0)

  write(ate,sprintf("../../../data/real_data_raw/%s_ate.txt",data_name) )
  ate
}

extract_covariates_into_data_file<-function(input_file_name,output_file_name){
  assert_that(is.character(input_file_name))
  assert_that(is.character(output_file_name))

  cf <- read.csv(file=sprintf("../../../data/real_data_raw/%s.csv",input_file_name),
                 header=TRUE, sep=",")

  all_covariates<-read.csv(file="../../../data/real_data_raw/covariates.csv",
                           header=TRUE, sep=",")

  cf<-merge(x = cf, y = all_covariates, by = "sample_id", all.x = TRUE)

  cf<-cf[2:length(cf)] #removing sample_id
  cf<-cf[c(2,1,3:length(cf))]#reorder first and second column
  names(cf)[1] <- "Y"
  names(cf)[2] <- "W"
  write.csv(cf,file=sprintf("../../../data/real_data_raw/%s.csv",output_file_name),row.names=FALSE)
}

load_data<-function(data_src,N,equal_share_tr_assignment){

  assert_that(is.null(data_src)||is.character(data_src))
  assert_integer(N)
  assert_that(is.logical(equal_share_tr_assignment))

  if(is.null(data_src)){
    return (load_generated_data(equal_share_tr_assignment,N))
  }
  else{
    data <- read.csv(file=sprintf("../../../data/%s.csv",data_src), header=TRUE, sep=",")
    names(data)[2] <- "W"
    print(paste("tr:",sum(data$W),"all:",length(data$W)))

    if(equal_share_tr_assignment){
      data<-sample_equal_share_data(data,N)
    }
    else{
      indices<-sample(1:length(data$Y),N,replace = FALSE)
      data<-data[indices,]
    }
    return (data_frame_to_Data(data))
  }
}

load_generated_data<-function(equal_share_tr_assignment,N){
  assert_that(is.logical(equal_share_tr_assignment))
  assert_integer(N)

  X1 = runif(N,min = -pi,max = pi)
  X2 = seq(0,0,length.out = N)
  X  = cbind(X1,X2)

  if(equal_share_tr_assignment){
    W = sample_equal_share_generated_assignments(N)
  }
  else{
    W  = rbinom(n=N,size = 1,p=logistic(X1))
  }

  Y  = sin(X1)+ rnorm(n = N, mean = 0,sd = 0.15)

  return (Data(X,W,Y))
}

load_real_ate<-function(data_src){
  assert_that(is.null(data_src)||is.character(data_src))

  if(is.null(data_src)){
    return (0)
  }

  ate<-read.table(file = sprintf("../../../data/%s_ate.txt",data_src))
  return (ate[[1]])
}

read_benchmark_data<-function(bench_data_src){

  assert_that(is.character(bench_data_src))

  data <- read.csv(file=sprintf("../../../benchmark_data/%s.csv",bench_data_src),
                   header=TRUE, sep=",")
  return (data)
}

write_benchmark_data<-function(benchmark_data,bench_data_src){

  assert_that(is.data.frame(benchmark_data))
  assert_that(is.character(bench_data_src))

  data <- write.csv(benchmark_data,file=sprintf("../../../benchmark_data/%s.csv",bench_data_src),
                    row.names=FALSE)
  data
}

create_benchmark_directory<-function(){
  setwd("../../../")
  dir.create("benchmark_data",showWarnings = FALSE)
  dir.create("benchmark_data/benchmark_random_generated_data", showWarnings = FALSE)
  dir.create("benchmark_data/benchmark_real_data_raw", showWarnings = FALSE)
  dir.create("benchmark_data/benchmark_real_data_simulated",showWarnings = FALSE)
  setwd("src/R/src")
}


##Shape=vector
##Rinde=field Shape
##output_plots_to_html
##Minimo =number 0
##Maximo =number 99999
##showplots
##outliers=output vector

sp.na.omit <- function(x, col.name = NULL, margin = 1) {
              if (!inherits(x, "SpatialPointsDataFrame") &
                  !inherits(x, "SpatialPolygonsDataFrame") &
                  !inherits(x, "SpatialLinesDataFrame") )
                stop("MUST BE sp SpatialPointsDataFrame OR SpatialPolygonsDataFrame class object")
              if(!is.null(col.name)) {
                if(is.na(match(col.name, names(x)))) stop(col.name, "does not exist in data")
                return( x[-which(is.na(x@data[,col.name])),] )
              } else {
                na.index <- unique(as.data.frame(which(is.na(x@data), arr.ind = TRUE))[, margin])
                if (margin == 1) {
                  cat("Deleting rows: ", na.index, "\n")
                  return(x[-na.index, ])
                }
                if (margin == 2) {
                  cat("Deleting columns: ", na.index, "\n")
                  return(x[, -na.index])
                }
              }
            }

library(sp)
crs_imagen<-st_crs(Shape)

myshp <- as_Spatial(Shape)
>print("--------------------------------------------------------")
>str(myshp)

Media <- mean(na.omit(myshp@data[,Rinde]))
DE <- sd(na.omit(myshp@data[,Rinde]))
LI <- Media-(2*DE)
LS <- Media+(2*DE)
>print(paste("Media:",Media))
>print(paste("DE:",DE))
>print(paste("LI",LI))
>print(paste("LS",LS))

if (LS > Maximo){LS = Maximo}
if (LI > Minimo){LI = Minimo}

myshp.outlier<-myshp
myshp.outlier[LS<myshp@data[Rinde]|myshp@data[Rinde]<LI] <-NA
myshp.outlier <- subset(sp.na.omit(myshp.outlier[Rinde]))

n<-nrow(myshp@data[Rinde])-nrow(myshp.outlier@data[Rinde])
>print(paste("Se filtraron",n,"puntos"))

output <- sf::st_as_sf(myshp.outlier,crs= crs_imagen)
outliers = output


#!/bin/env Rscript

data = read.table("713d498cc2f06d5e83d03c443691fb18.csv", header=T)
mean(abs(data$Diff));
hist(data$Diff);

angle_diff <- function(a, b){
        diff <- a - b;
        while (diff < -180) { diff = diff + 360; }
        while (diff > 180) { diff = diff - 360; }
        diff
}
data$new <- mapply(angle_diff, data$Clicked, data$Audio)
data$new <- mapply(angle_diff, -data$Clicked, data$Audio) #pro otoceny sluchatka

setwd("rdata");
files = list.files(pattern="*.csv")
for (i in 1:length(files)) data = rbind(data, read.csv(files[i], header=T)$Diff)