# Function to fit continous heavy tail functions
# Mostly using poweRlaw package
#
fit_con_heavy_tail <- function (data_set,xmins,options.output)
{
	n <- length(unique(data_set))
	n_models <- 4
	n_sets <- 1 # delete set 3
	# List of models
	model_list = list(list(model=vector("list", length=0),
						   						GOF=vector("list", length=0),
												 xmin_estimation=vector("list", length=0),
												 uncert_estimation=vector("list", length=0),
												 k=0,
												 LL=0,
												 n=n,
												 AICc=0,
												 delta_AICc=0,
												 AICc_weight=0,
						   model_name=character(0),
						   model_set=character(0)))
	fit_ht <- rep(model_list,n_models*n_sets)
	dim(fit_ht) <- c(n_models,n_sets)
	# Two sets: power law with and without cut-off
	# Declare models
	for (i_set in 1:(n_sets)){
		# Continuous power law
		fit_ht[[1,i_set]]$model <- conpl$new(data_set)
		fit_ht[[1,i_set]]$k <- 1
		# Continuous log-normal
		fit_ht[[2,i_set]]$model <- conlnorm$new(data_set)
		fit_ht[[2,i_set]]$k <- 2
		# Continuous exponential
		fit_ht[[3,i_set]]$model <- conexp$new(data_set)
		fit_ht[[3,i_set]]$k <- 1
		# power law with exponential cutoff
		fit_ht[[4,i_set]]$model <- ""
		fit_ht[[4,i_set]]$k <- 2
	}

	# Set xmin for set 1
	#fit_ht[[1,1]]$model$xmin <- 9

	# Estimate Xmin with complete data_set for power law model
	fit_ht[[1,1]]$xmin_estimation <- estimate_xmin(fit_ht[[1,1]]$model,
		xmins = xmins,
		pars = NULL,
		xmax = max(data_set))

	fit_ht[[1,1]]$model$setXmin(fit_ht[[1,1]]$xmin_estimation)

	model_names <- c("Power", "LogNorm","Exp","PowerExp")
	labels_set <- c("Estimated Xmin")

	AICc_weight <- matrix( nrow = n_models, ncol = n_sets,
							dimnames = list(model_names,labels_set))

	delta_AICc <- AICc_weight
	GOF <- delta_AICc
	if(n>8) {
		for (i_set in 1:n_sets){
		aic_min=Inf
		norm_aic_weight=0
		for (i in 1:(n_models)){
			# Set cut-off (x_min)
			fit_ht[[i,i_set]]$model$xmin <- fit_ht[[1,i_set]]$model$xmin

			# Correct n with xmin
			fit_ht[[i,i_set]]$n <-length(data_set[data_set>=fit_ht[[1,i_set]]$model$xmin])

			# Fit models
			#
			if(i!=n_models){
				fit_ht[[i,i_set]]$model$setPars(estimate_pars(fit_ht[[i,i_set]]$model))
				#
				# Get Loglikelihood
				fit_ht[[i,i_set]]$LL <- dist_ll(fit_ht[[i,i_set]]$model)
			} else {
				# Fit Power Exponential (not poweRlaw package)
				#
				fit_ht[[i,i_set]]$model<- powerexp.fit(data_set,fit_ht[[1,i_set]]$model$xmin)
				#
				# Get Loglikelihood
				fit_ht[[i,i_set]]$LL <- fit_ht[[i,i_set]]$model$loglike
			}
			LL <- fit_ht[[i,i_set]]$LL
			k <- fit_ht[[i,i_set]]$k
			# Compute AICc
			#
			fit_ht[[i,i_set]]$AICc <- (2*k-2*LL)+2*k*(k+1)/(n-k-1)
			aic_min <- min(aic_min,fit_ht[[i,i_set]]$AICc)
			if (i==1 & options.output$GOF){
				#
				# Goodness of fit via boostrap
				#
				# xmins is fixed at estimated value
				fit_ht[[i,i_set]]$GOF <- bootstrap_p(fit_ht[[i,i_set]]$model,
											 xmins=fit_ht[[i,i_set]]$model$xmin,
											 pars = NULL,
											 xmax = max(data_set),
											 no_of_sims = 1000,
											 threads = parallel::detectCores())
				#
				# Uncertainty in parms estimation via bootstrap
				#
				# Range of xmins to make bootstrap
				l_xmin <- round(fit_ht[[i,i_set]]$model$xmin * 0.8)
				u_xmin <- round(fit_ht[[i,i_set]]$model$xmin * 1.2)

				fit_ht[[i,i_set]]$uncert_estimation <- bootstrap(fit_ht[[i,i_set]]$model,
											 xmins=l_xmin:u_xmin,
											 pars = NULL,
											 xmax = max(data_set),
											 no_of_sims = 1000,
											 threads = parallel::detectCores())
			}
			fit_ht[[i,i_set]]$model_set <- labels_set[i_set]
			fit_ht[[i,i_set]]$model_name <- model_names[i]
		}

		for (i in 1:n_models){
			delta_AICc[i,i_set] <- fit_ht[[i,i_set]]$AICc - aic_min
			fit_ht[[i,i_set]]$delta_AICc <- delta_AICc[i,i_set]
			norm_aic_weight <- norm_aic_weight + exp(-0.5*fit_ht[[i,i_set]]$delta_AICc)
		}
		# Akaike weigths
		for (i in 1:n_models){
			AICc_weight[i,i_set]  <- exp(-0.5*fit_ht[[i,i_set]]$delta_AICc)/norm_aic_weight
			fit_ht[[i,i_set]]$AICc_weight <- AICc_weight[i,i_set]
		}
		# Plots
		if (options.output$ploting){
			#setwd(options.output$resultsDir)
			fnam <-paste0(strsplit(options.output$data_set_name[i_im],".tif"),"_",labels_set[i_set], ".png")
			png(filename=fnam, res=300,units = "mm", height=200, width=200,bg="white")

			po <-plot(fit_ht[[1,i_set]]$model,xlab="Area",ylab="CCDF",main=labels_set[i_set])
			for (i in 1:n_models){
				if(i!=n_models) {
					lines(fit_ht[[i,i_set]]$model, col=i+1)
				} else {
					est1 <- fit_ht[[i,i_set]]$model
					x <- sort(unique(data_set))
					x <- x[x>=est1$xmin]
					shift <- max(po[po$x>=est1$xmin,]$y)
					y <- ppowerexp(x,est1$xmin,est1$exponent,est1$rate,lower.tail=F)*shift
					lines(x,y,col=i+1)
				}
			}

			legend("topright",model_names,bty="n",col=seq(2,5),lty=c(1,1,1,1),cex=0.5)
			dev.off()
		}
	}
	}
	return(list(fitted_models=fit_ht,delta_AICc=delta_AICc,AICc_weight=AICc_weight))
}

# Function to extract a data frame from output generated by fit_con_heavy_tail
#
#
extract_fit_ht <-function(e)
{
	ee <- e$model
	gg <- e$GOF
	uu <- e$uncert_estimation
	bootXmin <-list(quantile(uu$bootstraps[,2],probs=c(0.025,0.25,0.5,0.75,0.975),na.rm=T))
	bootPar1 <-list(quantile(uu$bootstraps[,3],probs=c(0.025,0.25,0.5,0.75,0.975),na.rm=T))

	if(grepl("con",class(ee),fixed = T))
	{
# 		if(class(ee)=="conlnorm") {
# 			pa<-ee$getPars()
# 			if(length(pa)!=2) stop("conlnorm must have 2 parameters")
# 		} else {
# 			pa<-double(2)
# 			pa[1]<- ee$getPars()
# 			pa[2]<- 0
# 		}
		data_frame(model_name=e$model_name,model_set=e$model_set,
				   par1=ifelse(is.null(ee$pars[1]),NA,ee$pars[1]),
				   par2=ifelse(is.null(ee$pars[2]),NA,ee$pars[2]),
				   xmin=ee$getXmin(),n=e$n,LL=e$LL,AICc=e$AICc,delta_AICc=e$delta_AICc,
				   AICc_weight=e$AICc_weight,GOFp=ifelse(is.null(gg$p),NA,gg$p),bXminQuant=bootXmin,bPar1Quant=bootPar1)

	} else {
		data_frame(model_name=e$model_name,model_set=e$model_set,par1=ee$exponent,par2=ee$rate,
				   xmin=ee$xmin,n=e$n,LL=e$LL,AICc=e$AICc,delta_AICc=e$delta_AICc,
				   AICc_weight=e$AICc_weight,GOFp=ifelse(is.null(gg$p),NA,gg$p),bXminQuant=bootXmin,bPar1Quant=bootPar1)
	}

}

# Read data to call fit_con_heavy_tail and format output in a data.frame
#
#
call_fit_con_heavy_tail <-function(options,i){

	# Read binary data
	connection_file <- file(options$original_bin_files[i], "rb")
	data_set <- readBin(connection_file, "double", n = 10^6)

	ta<-sum(data_set)*233*233/1000000

	cat(options$original_bin_files[i],ta,"\n")

	fit_ht_df<-data_frame()

	if(ta>100000){# Set folder with results for the region

		#
		# Sample data for testing
		if(options$sample_data>0) data_set<- sample(data_set,options$sample_data) ### TESTING

		# Fit distribution models
		fit_ht <- fit_con_heavy_tail(data_set,options$xmins,options)

		# List to data.frame
		fit_ht_df <- ldply(fit_ht$fitted_models,extract_fit_ht)
		fit_ht_df$data_set_name <- strsplit(options$data_set_name[i],".tif")[[1]][1]
		ss <- strsplit(options$data_set_name[i],"_")
		fit_ht_df$region <- ss[[1]][2]
		fit_ht_df$subregion <- ss[[1]][3]
		fit_ht_df$threshold <- ss[[1]][4]
		fit_ht_df$year <- gsub(".*\\.A([0-9]{4}).*","\\1",options$data_set_name[i])
	}

	close(connection_file)

	return(fit_ht_df)

}

# Returns a data.frame with: number of patches, max patch, and total patch area
#
data_con_heavy_tail <-function(options,i){

	# Read binary data
	connection_file <- file(options$original_bin_files[i], "rb")
	data_set <- readBin(connection_file, "double",n = 10^7)
	if(length(data_set)==10^7)
			warning("Data set",options$original_bin_files[i], " may be bigger than 10^7")
	nl<-length(data_set)
	mx<-max(data_set)*233*233/1000000 # Convert to km2
	ta<-sum(data_set)*233*233/1000000
	mx2 <- (sort(data_set,partial=nl-1)[nl-1])*233*233/1000000
	cat(options$original_bin_files[i],"\tNo.patches",nl,"\tMax.PatchKm2",mx,"\t2nd.Max.PatchKm2",mx2,"\tTotalKm2",ta,"\n")

	fit_ht_df <- data_frame(number_of_patches=nl,max_patch=mx,second_max=mx2,total_patch_area=ta)
	fit_ht_df$data_set_name <- strsplit(options$data_set_name[i],".tif")[[1]][1]
	ss <- strsplit(options$data_set_name[i],"_")
	fit_ht_df$region <- ss[[1]][2]
	fit_ht_df$subregion <- ss[[1]][3]
	fit_ht_df$threshold <- ss[[1]][4]
	fit_ht_df$year <- gsub(".*\\.A([0-9]{4}).*","\\1",options$data_set_name[i])

	close(connection_file)

	return(fit_ht_df)

}

# Fit all the images patch sizes for a region with maybe different areas
#
#
region_fit_con_heavy_tail <-function(options,region,year=0){

	# Change to results folder
	#
	setwd(options$resultsDir)

	# Get files with patch sizes (*.bin) and image file names *.tif (data_set_name)
	#
	options$original_bin_files <- list.files(pattern=paste0("^.*",region,".*\\.bin$")) # list.files(pattern="*.\\.bin")
	options$data_set_name <- unlist(strsplit(options$original_bin_files,".bin"))

	if( year > 0)
		options$data_set_name <- options$data_set_name[gsub(".*\\.A([0-9]{4}).*","\\1",options$data_set_name)==year]

	fit <- data_frame()

	for(i in 1:length(options$data_set_name))
	{
		if(options$fit)
		{
		  	fit <- rbind(fit,call_fit_con_heavy_tail(options,i))	# Fit models
		} else {
		 	fit <- rbind(fit,data_con_heavy_tail(options,i)) 		# calculate patch stats
		}
	}
	if(region!=fit$region[1]) warning("Regions don't match ",region, fit$region)

	# Change to base folder
	#
	setwd(oldcd)

	return(fit)
}

# Plot of frequencies of patch sizes with fitted continuous heavy tail functions
# x: data
# fit_ht_df : dataframe with fitted parameters
#
freq_plot_con_ht <- function(x,fit_ht,tit="") # PLOT ALL FROM X=1 ?????????????????
{
	require(dplyr)
	require(ggplot2)
	xx <-as.data.frame(table(x))
	xx$x <- as.numeric(as.character(xx$x))
	ff <- filter(fit_ht,model_name=="PowerExp")
	xmin <- ff$xmin
	xx$pexp <-dpowerexp(xx$x,1,ff$par1,ff$par2)

	ff <- filter(fit_ht,model_name=="Power")
	xx$pow  <-dpareto(xx$x,xmin,ff$par1)

	ff <- filter(fit_ht,model_name=="Exp")
	xx$exp  <-dexp(xx$x,ff$par1)

	xx <-mutate(xx,pexp=ifelse(x<xmin,NA,pexp),pow=ifelse(x<xmin,NA,pexp),
				exp=ifelse(x<xmin,NA,exp),
				Freq=Freq/sum(Freq))

	minFreq <- min(xx$Freq) - 0.5*min(xx$Freq)
	minFreq <- ifelse(minFreq<0,0,minFreq)
	g <- ggplot(xx, aes(y=Freq,x=x)) +  theme_bw() + geom_point(alpha=0.3) +
		coord_cartesian(ylim=c(1,min(minFreq)))+
		scale_y_log10() +scale_x_log10() + ylab("Frequency") + xlab("Patch size") +ggtitle(tit)

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

	g <- g + geom_line(aes(y=pow,x=x,colour="P.law")) +
		geom_line(aes(y=pexp,x=x,colour="P.law with\nexp. cutoff"))+
		geom_line(aes(y=exp,x=x,colour="Exp."))+
		scale_colour_manual(values=mc,name="")

	fil <- gsub(" ", "", tit, fixed = TRUE)
	fil <- paste0(fil,".png")
	if(tit=="")
		print(g)
	else
		ggsave(fil,plot=g,width=6,height=4,units="in",dpi=600)

}

# Function to plot CCDF of fitted continuous heavy tail functions using ggplo2
#
# x: data
# fit_ht : dataframe with fitted parameters
# tit: file name to save graph
# fit_ht1: second set of parameters to superimpose in the same graph

cdfplot_conpl_exp <- function(x,fit_ht,tit="",xmax=0)
{
	require(poweRlaw)
	m <- conpl$new(x)
	tP <- plot(m,draw=F)
	require(ggplot2)
	require(dplyr)

	ff <- filter(fit_ht,model_name=="Power")
	xmin <- ff$xmin

	tP1 <- cdfplot_conpl_exp_helper(x,tP,fit_ht,xmin)

	#tP2 <-filter(tP2, powl>= min(tP$Rank))
	#tP1 <-filter(tP1, powl>= min(tP$Rank))

	#mc <- c("#E69F00", "#56B4E9", "#009E73","#F0E442", "#0072B2","#D55E00", "#CC79A7")
	# Brewer
	#mc <- c("#d7191c","#fdae61","#abd9e9","#2c7bb6")

	g <- ggplot(tP, aes(x=x,y=y)) +  theme_bw() + geom_point(alpha=0.3) +
		coord_cartesian(ylim=c(1,min(tP$y)))+
		scale_y_log10() +scale_x_log10() + ylab("log[P(X > x)]") + xlab("Patch size") #+ggtitle(tit)
	if(xmax>0) {
		g<-g + xlim(0,xmax+1) + scale_x_log10()
	}
	brk<-unique(tP1$model)
	g <- g + geom_line(data=tP1,aes(y=powl,x=psize,colour=model)) +
		#scale_colour_discrete(name="",breaks=brk)
		#scale_colour_manual(values=mc,name="",breaks=brk)
		scale_colour_brewer(type="div",palette=7,name="",breaks=brk)

# 	if(!is.null(fit_ht1))
# 	{
# 		#tP <-filter(tP,x<xmin)
# 		#g <- ggplot(tP, aes(x=x,y=y)) +  theme_bw() + geom_point(alpha=0.3) + coord_cartesian(ylim=c(1,min(tP$y)))+
# 		#	scale_y_log10() +scale_x_log10() + ylab("log[P(X > x)]") + xlab("Patch size") #+ggtitle(tit)
#
#
# 		#xmin <- fit_ht1$xmin
# 		tP2 <- cdfplot_conpl_exp_helper(x,tP,fit_ht1,xmin,"lt")
# 		brk<-unique(tP2$model)
#
# 		g <- g + geom_line(data=tP2,aes(y=powl,x=psize,colour=model)) +
# 			#scale_colour_discrete(name="",breaks=brk)
# 			#scale_colour_manual(values=mc,name="",breaks=brk)
# 			scale_colour_brewer(type="div",palette=7,name="",breaks=brk)
#
# 		fil <- gsub(" ", "", tit, fixed = TRUE)
# 		fil <- paste0(fil,"_1.png")
# 		if(tit=="")
# 			print(g)
# 		else
# 			ggsave(fil,plot=g,width=6,height=4,units="in",dpi=600)
#
#
# 	}
	fil <- gsub(" ", "", tit, fixed = TRUE)
	fil <- paste0(fil,".png")
	if(tit=="")
		print(g)
	else
		ggsave(fil,plot=g,width=6,height=4,units="in",dpi=600)

}

cdfplot_conpl_exp_helper <- function(x,tP,fit_ht,xmin,mode="gt")
{
	x1 <- unique(x)

	# Select model and generate a data frame
	#
	ff <- filter(fit_ht,model_name=="PowerExp")

	if(mode=="gt") {
		x1 <- x1[x1>=xmin]
		shift <- max(filter(tP,x>=xmin)$y)
	} else {
		x1 <- x1[x1<xmin]
		#xmin<-1
		#shift <-1
		# First select lower subset the change to the Xmin of this subset
		xmin <- ff$xmin
		shift <- max(filter(tP,x>=xmin)$y)
	}

	tP2 <- data.frame(psize=x1, powl=ppowerexp(x1,xmin,ff$par1,ff$par2,lower.tail=F)*shift,model="PowerExp")

	ff <- filter(fit_ht,model_name=="Power")

	tP1  <-data.frame(psize=x1, powl=ppareto(x1,xmin,ff$par1,lower.tail=F)*shift,model="Power")

	ff <- filter(fit_ht,model_name=="Exp")
	m <- conexp$new(x)
	m$setPars(ff$par1)
	m$setXmin(xmin)
	tP3 <- data.frame(psize=x1,powl=dist_cdf(m,x1,lower_tail=F)*shift,model="Exp")

	ff <- filter(fit_ht,model_name=="LogNorm")
	m <- conlnorm$new(x)
	m$setPars(c(ff$par1,ff$par2))
	m$setXmin(xmin)
	tP4 <- data.frame(psize=x1,powl=dist_cdf(m,x1,lower_tail=F)*shift,model="LogNorm")
	tP1 <- bind_rows(tP1,tP2,tP3,tP4)
}

# Function to plot CCDF of heavy tailed distributions using base graphics
# x: data set
# fit_ht: a data frame with the fitted parameters
#
cdfplot_con_ht <- function(x,fit_ht,fnam="")
{
	require(dplyr)
	if(fnam!=""){
			fnam <-paste0(fnam,".png")
			png(filename=fnam, res=300,units = "mm", height=200, width=200,bg="white")
	}

	#fil <- gsub(" ", "", tit, fixed = TRUE)
	#fil <- paste0(fil,".png")

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

	require(poweRlaw)
	m <- conpl$new(x)
	po <- plot(m,xlab="Area",ylab="CCDF")
	#x <- x[x>=xmin]

	#x <- unique(x)
	# Plot with base plot and poweRlaw package
	#
	ff <- filter(fit_ht,model_name=="Power")
	xmin <- ff$xmin
	m$setPars(ff$par1)
	m$setXmin(xmin)
	lines(m, col=mc[1])

	shift <- max(filter(po,x>=xmin)$y)
	ff <- filter(fit_ht,model_name=="PowerExp")
	x1 <- sort(unique(x))
	#x1 <- sort(x)
	x1 <- x1[x1>=xmin]
	y1 <- ppowerexp(x1,xmin,ff$par1,ff$par2,lower.tail=F)*shift
	lines(x1,y1,col=mc[2])

	ff <- filter(fit_ht,model_name=="Exp")
	m <- conexp$new(x)
	m$setPars(ff$par1)
	m$setXmin(xmin)
	lines(m, col=mc[3])

	ff <- filter(fit_ht,model_name=="LogNorm")
	m <- conlnorm$new(x)
	m$setPars(c(ff$par1,ff$par2))
	m$setXmin(xmin)
	lines(m, col=mc[4])

	model_names <- c("Power","PowerExp","Exp","LogNorm")
	legend("topright",model_names,bty="n",col=mc[1:4],lty=c(1,1,1,1),cex=0.5)

	if(fnam!="")
		dev.off()

}

# Function to plot distributions fits from the complete dataset Xmin=9
# and the dataset from the estimated Xmin
# calls the function cdfplot_con_ht and use global variables
#
# reg: geographic region {SA,CA,NA,EU, etc}
#
ccdfPlots_one_region <- function(options,region)
{
	for( i_im in 1:length(options$data_set_name))
	{
		connection_file <- file(options$original_bin_files[i_im], "rb")
		data_set <- readBin(connection_file, "double", n = 10^6)
		if(options$sample_data>0) data_set<- sample(data_set,options$sample_data)
		ta<-sum(data_set)*233*233/1000000
		if(ta>100000){
			ss <- strsplit(options$data_set_name[i_im],"_")[[1]][2]
			if( region != ss) warning("Region extracted from file names: ",ss, " Different from parameter: ",region)

			nn <- strsplit(options$original_bin_files[i_im],".tif")[[1]][1]

			# Complete data set (Xmin=1)
			#
			ff <- filter(all_fit,grepl(nn,data_set_name,ignore.case = T),model_set=="Xmin=9",region==region)
			na<-paste0(ff$region[1],"_", ff$subregion[1],"_",ff$year[1],"_",ff$model_set[1])
			cdfplot_conpl_exp(data_set,ff,na)

			# data set< Estimated Xmin (<Xmin)
			#
			ff <- filter(all_fit,grepl(nn,data_set_name,ignore.case = T),model_set=="Estimated Xmin",region==region)
			na<-paste0(ff$region[1],"_", ff$subregion[1],"_",ff$year[1],"_",ff$model_set[1])
			cdfplot_conpl_exp(data_set,ff,na)
		}
	}

}

# Downloada all modis granules for a year in dataDir folder
#
# Returns a data frame with file names and h v year
# use a python module called pyModis
#
down_modis_year <- function(dataDir,year) {

  setwd(dataDir)
  hdfDir <-"hdf"
  if(!dir.exists(hdfDir)) {
    dir.create(hdfDir)
  }
  starty <- sprintf("01-01-%04d", year)
  endy   <- sprintf("31-12-%04d", year)
  system(paste0("modis_download.py -U lsaravia -P Octa2004 -p MOD44B.051 -f ",starty," -e ",endy," hdf"))
  # modis_download.py -U lsaravia -P Octa2004 -p MOD44B.051 -t h18v03 -f 01-01-2015 -e 31-12-2015 -x hdf
  setwd(oldcd)

}

# Downloada modis granules using the filenames contained in Download.txt in dataDir folder
# check that granules are not greater than hmax and less than hmin
# Returns a data frame with file names and h v year
# use a python module called pyModis
#
down_modis <- function(dataDir,hmin,hmax) {

	setwd(dataDir)
  hdfDir <-"hdf"
  if(!dir.exists(hdfDir)) {
    dir.create(hdfDir)
  }

	dn <- read.table("Download.txt",stringsAsFactors = F)

	require(stringr)

	#regexpr("h[0-9]",dn[1,1])

	dn$h=as.numeric(str_sub(dn[,1],18,19))
	dn$v=as.numeric(str_sub(dn[,1],21,22))
	dn$year=str_sub(dn[,1],9,12)

	require(dplyr)

	#
	# For southamerica h in 07-15
	#
	if( !(hmin==0 & hmax==0)) {
	  dn1 <- filter(dn,h>=hmin & h<=hmax)
	} else {
	  dn1 <- dn
	}
	str_sub(dn1$V1,28,40) <- "*"

	write.table(str_c(dn1$V1,"*"),file="MOD44BFiles",row.names = F,col.names = F,quote = F)

	system("modis_download_from_list.py -U lsaravia -P Octa2004 -p MOD44B.051 -f MOD44BFiles hdf ")

	setwd(oldcd)

	return(dn1)
	}

# Make mosaic of hdf files downloaded with down_modis
# in a folder "hdf" with base dataDir, it uses a file called
# "Download.txt" to read the files to compose and the Python PyModis package
#
# dataDir: base folder to output mosaic geotif files
#
#
mosaic_modis <- function(dataDir,hmin,hmax) {

	setwd(dataDir)
	dn <- read.table("Download.txt",stringsAsFactors = F)
	require(stringr)
	dn$h=as.numeric(str_sub(dn[,1],18,19))
	dn$v=as.numeric(str_sub(dn[,1],21,22))
	dn$year=str_sub(dn[,1],9,12)

	require(dplyr)
	dn1 <- filter(dn,h>=hmin & h<=hmax)
	setwd("hdf")
	group_by(dn1,year) %>% do( s=mosaic_by_year(.))

	setwd(oldcd)
}

# helper function for mosaic_modis
#
mosaic_by_year <-function(x) {

  # write list of file names to use in the mosaic
  #
	write.table(x$fname,file="listfileMOD44B.051.txt",quote=F,col.names = F,row.names = F)

  # Output file name
  #
  gname <- paste0('MOD44B.MRTWEB.A',x$year[1],'065.051.Percent_Tree_Cover.tif')

	s <- paste0('modis_mosaic.py -s "1 0 0 0 0 0 0" listfileMOD44B.051.txt -o ', gname)
	system(s)

	return(gname)
}

# Read the h and v limits for modis hdf files to make composite images by continent
#
#
get_modis_limits <-function(region,hmin,hmax){

  setwd("MODIS_tools")
  fn <- paste0("Download_",region,".txt")
  dn <- read.table(fn,stringsAsFactors = F)
  setwd(oldcd)

  require(stringr)

  # regexpr("h[0-9]",dn[1,1])

  dn$h=as.numeric(str_sub(dn[,1],18,19))
  dn$v=as.numeric(str_sub(dn[,1],21,22))
  dn$year=str_sub(dn[,1],9,12)

  # Generate a DF with only the h v needed for a region
  #
  require(dplyr)
  dn <- filter(dn,h>=hmin & h<=hmax)
  m <- matrix(0,nrow=max(dn$v),ncol=max(dn$h))
  m[dn$v,dn$h]<-1
  print(m)
  mod_limits <- dn %>% filter(year==2000) %>% arrange(v,h) %>% select(h,v) %>% mutate( Region=region)

}

#' Make geotiff mosaic of hdf files for a region defined as h & v modis granules
#' in a folder "hdf" within base dataDir
#'
#' @param dataDir Folder where the geotiff file will be generated and where there is
#'                a subfolder hdf with granules
#'
#' @param destDir Destination folder for the generated geotiff files
#'
#' @param granules Data frame with h & v columns identifying granules to be mosaicked, with
#'                 fields h,v,region
#' @param region  region defined in the data frame to generate the geotiff
#'
#' @param year    year of the modis granules to generate the geotiff
#'
#' @return
#' @export
#'
#' @examples
#'
mosaic_modis_region <- function(dataDir,destDir,granules,region,year) {
  oldcd <-getwd()
  setwd(dataDir)

  # read the files in dir 'hdf'
  #
  dn <- list.files("hdf",pattern = "^.*\\.hdf$")
  if(length(dn)==0) stop("The folder hdf is empty")
  require(dplyr)
  dn <- tibble(dn)
  names(dn) <- "fname"

  require(stringr)
  dn$h <- as.numeric(str_match(dn$fname, "h(\\d{2})")[,2])
  dn$v <- as.numeric(str_match(dn$fname, "v(\\d{2})")[,2])
  dn$year <- str_match(dn$fname, "A(\\d{4})")[,2]

  dn1 <- granules %>% filter(Region==region) %>% inner_join(dn)
  setwd("hdf")

  dn2 <- group_by(dn1,year) %>% do( gname=mosaic_by_year(.))
  dn2$gname <-unlist(dn2$gname)

  dn2$toname <- paste0(destDir,"/",dn2$gname)

  # dn2 <- data.frame(gname="MOD44B.MRTWEB.A2015065.051.Percent_Tree_Cover.tif",stringsAsFactors = F)
  file.rename(dn2$gname,dn2$toname)

  setwd(oldcd)
}

# Read data to call fit_con_heavy_tail and format output in a data.frame
#
#
max_patch_size <-function(im_names,opts.out){

	max_s_df <- data_frame()

	for(i in 1:length(im_names))
	{
		# Read binary data
		connection_file <- file(original_bin_files[i], "rb")
		data_set <- readBin(connection_file, "double", n = 10^6)
		if(options.output$sample_data>0) data_set<- sample(data_set,options.output$sample_data) ### TESTING
		max_s_df <- rbind(max_s_df,data_frame( maxS=max(data_set), data_set_name=strsplit(options.output$data_set_name[i],".tif")[[1]][1],
								year=substr(data_set_name,16,19),region=opts.out$region))

	}

	return(max_s_df)
}

read_random_percolation <-function(region) {

	percolation_R_files <- list.files(pattern="^.*_randomized_p_sweep\\.R$")
	df <- data.frame()

	for(i in 1:length(percolation_R_files)){
		ss <- strsplit(percolation_R_files[i],"_")
		#df$region <- ss[[1]][2]
		#df$subregion <- ss[[1]][3]
		if(ss[[1]][2]!=region) warning("Regions don't match ",region, ss[[1]][2])

		source(percolation_R_files[i])
		ll <- length(p_set)
		df1 <- data.frame(region=rep(ss[[1]][2],ll),subregion=rep(ss[[1]][3],ll),correlation_length_km=t(correlation_length_km_set),p_set=t(p_set))
		df1$equivalent_diameter_km <- equivalent_diameter_km
		df1$maximum_length_km <- maximum_length_km
		df1$total_area_km2 <- total_area_km2
		df <- rbind(df,df1)

	}
	return(df)
}

read_region_correlation<-function(region) {

	r_files <- list.files(pattern="^.*_Tree_Cover.tif_Correlation_analisys\\.R$")
	df <- data.frame()

	for(i in 1:length(r_files)){

		ss <- strsplit(r_files[i],"_")
		#df$region <- ss[[1]][2]
		#df$subregion <- ss[[1]][3]
		if(ss[[1]][2]!=region) warning("Regions don't match ",region, ss[[1]][2])

		source(r_files[i])
		df1 <- data.frame(region=ss[[1]][2],subregion=ss[[1]][3],year=gsub(".*\\.A([0-9]{4}).*","\\1",r_files[i]),
			correlation_length_km,maximum_length_km,total_area_km2,equivalent_diameter_km)

		df <- rbind(df,df1)
	}
	return(df)
}

# Estimation of the correlation exponent epsilon ~ (p-pc)^-nu
# based in the potential relationship near the critical point
#
# range: range of p to estimate exponent
# cp: critical point
# df: data frame with data
#
est_correlation_exponent <- function(range,cp,df)
{
	require(ggplot2)

	f_df <- df %>% group_by(region,subregion) %>% filter(p_set>=range[1] & p_set<=range[2]) %>% mutate(p_dif=abs(p_set-cp))

	g <- ggplot(f_df,aes(p_dif,correlation_length_km,colour=subregion))+theme_bw() + geom_point() + scale_y_log10() +scale_x_log10()
	print(g + geom_smooth(method=lm, se=FALSE))    # Don't add shaded confidence region

	mods <- do(f_df,mod=lm(log(correlation_length_km) ~ log(p_dif),data=.),max_corr_length=max(.$correlation_length_km),min_corr_length=min(.$correlation_length_km))
	slop <- mods %>% mutate(log_inter=coef(summary(mod))[1],correl_exp=coef(summary(mod))[2],
						R2 = summary(mod)$r.squared,pvalue_exp=coef(summary(mod))[2,4], #full_coef=coef(summary(.$mod)),
						max_corr_length=max_corr_length,min_corr_length=min_corr_length) %>% select(-mod)

	#slop <- mods %>% do(data.frame(region=.$region, subregion=.$subregion, var = names(coef(.$mod)), coef(summary(.$mod)))) %>% filter(var=="log(p_dif)")
	#R2s <- mods %>% summarise(region=region, subregion=subregion,R2 = summary(mod)$r.squared)
	#slop$R2 <- R2s$R2

	return(slop) # %>% select(-var,-t.value) %>% rename(correl_exp=Estimate,SE=Std..Error,pvalue=Pr...t..))
}

# Calculates critical probability from correlation length based on the estimated exponents using
# function est_correlation_exponent
#
# range: range of p to estimate exponent (not used)
# cp: critical point
# corexp: data frame ouput of the function est_correlation_exponent
# regcor: data frame with data
#
calc_critical_probability <- function(range,cp,corexp,regcor)
{
	allcor <- regcor %>% inner_join(corexp) %>% mutate(p=cp-(correlation_length_km/exp(log_inter))^(1/correl_exp),
													   p=ifelse(p<0,0,ifelse(p>1,1,p)))
#	incor <- allcor %>% filter(correlation_length_km>=min_corr_length,correlation_length_km<=max_corr_length) %>%
#		mutate(pdist=exp((log_inter-log(correlation_length_km))/correl_exp))
#		mutate(p=cp-(correlation_length_km/exp(log_inter))^(1/correl_exp))
#	ltcor <- allcor %>% filter(correlation_length_km<min_corr_length) %>% mutate(p=0.1)
#	gtcor <- allcor %>% filter(correlation_length_km>max_corr_length) %>% mutate(p=0.9)

	return(select(allcor, -(max_corr_length:pvalue_exp)))
}

# Estimation of the critical point using logistic regression
#
#
est_critical_point <- function(rndper)
{
  # Estimate the probability of percolation as correlation_length/equivalent_diameter
  #
	rp <-rndper %>% group_by(region,subregion) 	%>% mutate(p_correlation_length=correlation_length_km/equivalent_diameter_km) %>% mutate(p_correlation_length=ifelse(p_correlation_length>1,1,p_correlation_length))

  # Fit a binomial model to estimate the critical point
	#
	rfit <- rp %>% do(lfit= glm(.$p_correlation_length ~ .$p_set, family=binomial(logit), data = .))
	# slop <- rfit %>% mutate(beta0 = coef(lfit)[1],
	# 						beta1 = coef(lfit)[2],
	# 						pcrit = - beta0 / beta1)

	# Estimate the critical point using a regression of the values around the probability of percolation =0.50
	# p_correlation_length = 0.5
	#
	slop <- rp %>% do(pcrit = est_critical_point_helper(.)) %>% mutate(pcrit=unlist(pcrit))

	# Calculate the predicted values of the binomial regression to plot
	#
	rfit <-rfit %>% inner_join(rp %>% slice(1) %>% transmute(max_cl=equivalent_diameter_km))
	rp1 <-rfit %>% do(data.frame(fit = .$lfit$fitted*.$max_cl))
	rp <- bind_cols(rp, rp1)

	gt <- slop %>% mutate(label = sprintf("p == %.3f", pcrit),x=0.9,y=0.1)
	g <-ggplot(rp,aes(p_set,correlation_length_km))+theme_bw() + geom_point(shape=21) +
		geom_line(aes(x = p_set, y = fit), linetype = 2) +
		geom_vline(aes(xintercept = pcrit),data = slop, color = "blue") +
		geom_text(aes(x,y,label = label) ,data=gt,parse = TRUE ) +
		facet_wrap(region ~ subregion,scales="free_y")
	print(g)

	return(slop)
}

est_critical_point_helper<- function(x)
{
  # lf <-glm(p_correlation_length ~ p_set, family=binomial(logit), data = x)
  # pcrit=- (lf$coefficients[1] / lf$coefficients[2])
  # x$p <-predict(lf,x,type="resp")
  x1 <- x %>% filter(p_correlation_length>0.50) %>% arrange(p_correlation_length) %>% slice(1:10)
  x1 <- bind_rows(x1, x %>% filter(p_correlation_length<=0.50) %>% arrange(desc(p_correlation_length)) %>% slice(1:10))
  pcrit <- approx(x1$p_correlation_length,x1$p_set,xout=0.5)[["y"]]

}

#' Plot estimated correlations lenght with ramdomized correlation lengths
#'
#' @param cpoint Data frame with critical points
#' @param rndcor Data frame with randomized correlation lengths
#' @param corlen Data frame with correlation lengths
#'
plot_corr_length <- function(cpoint,rndcor,corlen)
{
  gt <- cpoint %>% mutate(label = sprintf("p == %.3f", pcrit),x=0.9,y=0.1)
  g <-ggplot(rndcor,aes(p_set,correlation_length_km))+theme_bw() + geom_point(shape=21) +
    geom_vline(aes(xintercept = pcrit),data = cpoint, color = "blue") +
    geom_text(aes(x,y,label = label) ,data=gt,parse = TRUE ) +
    geom_point(aes(),data=corlen)
    facet_wrap(region ~ subregion,scales="free_y")
  print(g)
}

# Calculates the percolation probability using logistic equation parms from est_critical_point
#
# cripoi: critical point and logistic parameters
# regcor: data frame with data
#
calc_critical_probability_logis <- function(cripoi,regcor)
{
	allcor <- regcor %>% inner_join(cripoi) %>% mutate( pl = (-log((max_cl-correlation_length_km)/correlation_length_km) -beta0) / beta1)

	return(select(allcor,-(lfit:max_cl)))

}

# Plot inverse cumulative size distributions fits by region
#
# region
# odir: folder with the size distribution files
#
plot_size_dist_by_region <-function(region,odir,Thres=0,Year=0)
{
	require(ggplot2)

	options.glo$resultsDir <- odir
	options.glo$sample_data <- 0                 # Set >0 For testing

	setwd(options.glo$resultsDir)
	options.glo$original_bin_files <- list.files(pattern=paste0("^.*",region,".*\\.bin$")) # list.files(pattern="*.\\.bin")

	options.glo$data_set_name <- unlist(strsplit(options.glo$original_bin_files,".bin"))
	year <- gsub(".*\\.A([0-9]{4}).*","\\1",options.glo$data_set_name)
	threshold <- sub("^(?:[^_]*_){3}([^_]+).*","\\1",options.glo$data_set_name)

	if(Thres>0)
		options.glo$data_set_name <- options.glo$data_set_name[threshold==thres]

	if(Year>0)
		options.glo$data_set_name <- options.glo$data_set_name[year==Year]

	# Read binary data
	set.seed(seed=0)

	ccdfPlots_one_region(options.glo,region)

	setwd(oldcd)
}

# Fit continuos heavy tail models (used for small data sets not patch size distributions)
#
#
fit_cont_heavy_tail_mdls <- function (data_set,xmins,ploting=TRUE,gof=FALSE)
{
	n <- length(unique(data_set))
	n_models <- 3
	# List of models
	model_list = list(list(model=vector("list", length=0),
						   						GOF=vector("list", length=0),
												 xmin_estimation=vector("list", length=0),
												 uncert_estimation=vector("list", length=0),
												 k=0,
												 LL=0,
												 n=n,
												 AICc=0,
												 delta_AICc=0,
												 AICc_weight=0,
						   model_name=character(0),
						   modelfit_cont_heavy_tail_mdls_set=character(0)))
	fit_ht <- rep(model_list,n_models)
	dim(fit_ht) <- c(n_models)

	# Declare models
	# Continuous power law
	fit_ht[[1]]$model <- conpl$new(data_set)
	fit_ht[[1]]$k <- 1
	# Continuous log-normal
	fit_ht[[2]]$model <- conlnorm$new(data_set)
	fit_ht[[2]]$k <- 2
	# Continuous exponential
	fit_ht[[3]]$model <- conexp$new(data_set)
	fit_ht[[3]]$k <- 1

	# Set xmin for set 1
	fit_ht[[1]]$model$xmin <- xmins
	if(length(xmins)>1){
		# Estimate Xmin with complete data_set for power law model
		fit_ht[[1]]$xmin_estimation <- estimate_xmin(fit_ht[[1]]$model,
			xmins = xmins,
			pars = NULL,
			xmax = max(data_set))
		fit_ht[[1]]$model$setXmin(fit_ht[[1]]$xmin_estimation)
	} else if(xmins-1){
		fit_ht[[1]]$xmin_estimation <- estimate_xmin(fit_ht[[1]]$model,
													 pars = NULL,
													 xmax = max(data_set))
		fit_ht[[1]]$model$setXmin(fit_ht[[1]]$xmin_estimation)
	} else {
		fit_ht[[1]]$model$setXmin(xmins)
	}

	model_names <- c("Power", "LogNorm","Exp")

	AICc_weight <- matrix( nrow = n_models, ncol = 1,
							dimnames = list(model_names))

	delta_AICc <- AICc_weight
	GOF <- delta_AICc
	if(n>8) {
		aic_min=Inf
		norm_aic_weight=0
		for (i in 1:(n_models)){
			# Set cut-off (x_min)
			fit_ht[[i]]$model$xmin <- fit_ht[[1]]$model$xmin

			# Correct n with xmin
			fit_ht[[i]]$n <-length(data_set[data_set>=fit_ht[[1]]$model$xmin])

			# Fit models
			#
			fit_ht[[i]]$model$setPars(estimate_pars(fit_ht[[i]]$model))
			#
			# Get Loglikelihood
			fit_ht[[i]]$LL <- dist_ll(fit_ht[[i]]$model)

			LL <- fit_ht[[i]]$LL
			k <- fit_ht[[i]]$k
			# Compute AICc
			#
			fit_ht[[i]]$AICc <- (2*k-2*LL)+2*k*(k+1)/(n-k-1)
			aic_min <- min(aic_min,fit_ht[[i]]$AICc)
			if (gof && fit_ht[[i]]$n>4){
				#
				# Goodness of fit via boostrap
				#
				# xmins is fixed at estimated value (or 9)
				fit_ht[[i]]$GOF <- try(bootstrap_p(fit_ht[[i]]$model,
											 #xmins=fit_ht[[i]]$model$xmin,
											 pars = NULL,
											 xmax = max(data_set),
											 no_of_sims = 999,
											 threads = parallel::detectCores()))
				GOF <- fit_ht[[i]]$GOF
				if(class(GOF)!="bs_p_xmin"){
					fit_ht[[i]]$GOF <-NULL
				} else {
					fit_ht[[i]]$GOF$p <- sum(GOF$gof >= GOF$bootstraps$gof,na.rm = TRUE)/999
				}
				#
				# Uncertainty in parms estimation via bootstrap
				#
				# Range of xmins to make bootstrap
# 				l_xmin <- fit_ht[[i]]$model$xmin * 0.8
# 				u_xmin <- fit_ht[[i]]$model$xmin * 1.2
# 				fit_ht[[i]]$uncert_estimation <- bootstrap(fit_ht[[i]]$model,
# 											 xmins=l_xmin:u_xmin,
# 											 pars = NULL,
# 											 xmax = max(data_set),
# 											 no_of_sims = 1000,
# 											 threads = parallel::detectCores())
			}
			fit_ht[[i]]$model_name <- model_names[i]
		}

		for (i in 1:n_models){
			delta_AICc[i] <- fit_ht[[i]]$AICc - aic_min
			fit_ht[[i]]$delta_AICc <- delta_AICc[i]
			norm_aic_weight <- norm_aic_weight + exp(-0.5*fit_ht[[i]]$delta_AICc)
		}
		# Akaike weigths
		for (i in 1:n_models){
			AICc_weight[i]  <- exp(-0.5*fit_ht[[i]]$delta_AICc)/norm_aic_weight
			fit_ht[[i]]$AICc_weight <- AICc_weight[i]
		}
		# Plots
		if (ploting){
			#setwd(options.output$resultsDir)
			#fnam <-paste0(strsplit(options.output$data_set_name[i_im],".tif"),"_",labels_set[i_set], ".png")
			#png(filename=fnam, res=300,units = "mm", height=200, width=200,bg="white")

			po <-plot(fit_ht[[1]]$model,xlab="Area",ylab="CCDF")
			for (i in 1:n_models){
				if(model_names[i]!="PowerExp")
				{
					lines(fit_ht[[i]]$model, col=i+1)
				} else {
					est1 <- fit_ht[[i]]$model
					x <- sort(unique(data_set))
					x <- x[x>=est1$xmin]
					shift <- max(po[po$x>=est1$xmin,]$y)
					y <- ppowerexp(x,est1$xmin,est1$exponent,est1$rate,lower.tail=F)*shift
					lines(x,y,col=i+1)
				}
			}

			legend("topright",model_names,bty="n",col=seq(2,5),lty=c(1,1,1,1),cex=0.5)
			#dev.off()
		}
	}
	fit_ht_df <- ldply(fit_ht,extract_fit_ht_mdls)

	return(fit_ht_df)
}

# Function to extract a data frame from output generated by fit_con_heavy_tail
#
#
extract_fit_ht_mdls <-function(e)
{
	ee <- e$model
	gg <- e$GOF
	uu <- e$uncert_estimation
	bootXmin <-list(quantile(uu$bootstraps[,2],probs=c(0.025,0.25,0.5,0.75,0.975),na.rm=T))
	bootPar1 <-list(quantile(uu$bootstraps[,3],probs=c(0.025,0.25,0.5,0.75,0.975),na.rm=T))

	if(grepl("con",class(ee),fixed = T))
	{
		data_frame(model_name=e$model_name,
				   par1=ifelse(is.null(ee$pars[1]),NA,ee$pars[1]),
				   par2=ifelse(is.null(ee$pars[2]),NA,ee$pars[2]),
				   xmin=ee$getXmin(),n=e$n,LL=e$LL,AICc=e$AICc,delta_AICc=e$delta_AICc,
				   AICc_weight=e$AICc_weight,
				   GOFp=ifelse(is.null(gg$p),NA,
				   		ifelse(is.na(gg$p),sum(gg$bootstraps$KS>gg$gof,na.rm=TRUE)/nrow(gg$bootstraps),gg$p)),

				   bXminQuant=bootXmin,bPar1Quant=bootPar1)

	} else {
		data_frame(model_name=e$model_name,model_set=e$model_set,par1=ee$exponent,par2=ee$rate,
				   xmin=ee$xmin,n=e$n,LL=e$LL,AICc=e$AICc,delta_AICc=e$delta_AICc,
				   AICc_weight=e$AICc_weight,GOFp=ifelse(is.null(gg$p),NA,gg$p),bXminQuant=bootXmin,bPar1Quant=bootPar1)
	}

}

# Fit all the images patch sizes for a region with maybe different areas
#
#
merge2_region_fit_con_heavy_tail <-function(options,region,new_region){

	# Change to results folder
	#
	setwd(options$resultsDir)

	# If new_region files already exist don't merge
	#
	if(list.files(pattern=paste0("^.*",new_region,".*\\.bin$"))=="") {

		# Get the original files nameswith patch sizes (*.bin) and image file names *.tif (data_set_name)
		#
		options$original_bin_files <- list.files(pattern=paste0("^.*",region,".*\\.bin$")) # list.files(pattern="*.\\.bin")

		options$data_set_name <- unlist(strsplit(options$original_bin_files,".bin"))

		# Merge the two largest patches
		#
		for(i in 1:length(options$data_set_name))
		{
			connection_file <- file(options$original_bin_files[i], "rb")
			data_set <- sort(readBin(connection_file, "double", n = 10^6),decreasing=TRUE)
			data_set[2] <- data_set[1]+data_set[2]
			data_set <- data_set[2:length(data_set)]
			close(connection_file)

			# Change the name of the file to new_region
			#
			options$original_bin_files[i] <- sub(region,new_region,options$original_bin_files[i])
			connection_file <- file(options$original_bin_files[i], "wb")
			writeBin(data_set,connection_file)
			close(connection_file)
		}
	}

	# Get the new files names with merged patches
	#

	options$original_bin_files <- list.files(pattern=paste0("^.*",new_region,".*\\.bin$")) # list.files(pattern="*.\\.bin")

	options$data_set_name <- unlist(strsplit(options$original_bin_files,".bin"))

	fit <- data_frame()

	for(i in 1:length(options$data_set_name))
	{
		if(options$fit)
		{
		  	fit <- rbind(fit,call_fit_con_heavy_tail(options,i))	# Fit models
		} else {
		 	fit <- rbind(fit,data_con_heavy_tail(options,i)) 		# calculate patch stats
		}
	}

	# Change to base folder
	#
	setwd(oldcd)

	return(fit)
}

#  Plot of RSmax by year and threshold
#
#  pst: pstat_threshold data frame
#  regions: vector of regions to include
plot_RSmax_yearThreshold <- function(pst,regions){

	ff1 <- filter(pst,regsub %in% regions)
	ff2<- group_by(ff1,regsub,threshold) %>%  summarise(mprop=mean(prop_max_patch))

	if(length(unique(ff1$regsub))==1)
	{
		require(viridis)
		g <- ggplot(ff1, aes(y=prop_max_patch,x=year,colour=regsub)) +  theme_bw() +
		geom_point(shape=19) + geom_line() + facet_wrap(~threshold) + scale_colour_viridis(discrete = T,guide=F) +
			ggtitle(unique(ff1$regsub)) +  theme(plot.title = element_text(hjust = 0.5)) +
			geom_hline(aes(yintercept=mprop,colour=regsub),ff2,linetype = 2)

	} else {
		pd <-position_dodge(.3)
		g <- ggplot(ff1, aes(y=prop_max_patch,x=year,colour=regsub)) +  theme_bw() +
		geom_point(shape=19,position=pd) + facet_wrap(~threshold) + scale_colour_brewer(palette="Set1",name="Region")  +
		geom_hline(aes(yintercept=mprop,colour=regsub),ff2,linetype = 2)
	}

	print(g + ylab(expression(RS[max]))  +
		theme(axis.text.x = element_text(angle=90,hjust=0))
		)

}

#  Plot fluctuations of RSmax by year and faceted by threshold
#
#  pst: pstat_threshold data frame
#  regions: vector of regions to include
plot_RSmax_Fluctuations_yearThreshold <- function(pst,regions,isSignif,numcol=3){
	require(viridis)
	ff1 <- filter(pst,regsub %in% regions)
	ff1 <- filter(ff1,threshold %in% isSignif) %>% mutate(is_signif=TRUE) %>% bind_rows( filter(ff1,!(threshold %in% isSignif)) %>% mutate(is_signif=FALSE) )
	#
	# Fluctuations around the mean Smax - <Smax>/TotArea
	#
	g <- ggplot(ff1, aes(y=delta_prop_max_patch,x=year,colour=is_signif)) +  theme_bw() +
		geom_point(shape=19,size=1) + facet_wrap(~threshold,ncol=numcol) +
		ylab(expression(Delta~RS[max])) + scale_colour_viridis(discrete = T,guide=F,direction = -1) +
		ggtitle(unique(ff1$regsub)) +
		theme(axis.text.x = element_text(angle=90,hjust=0),plot.title = element_text(hjust = 0.5,size=12)) +
		stat_quantile(quantiles=c(.10,.90),linetype=2)

	print(g)
	return(g)
}

plot_RSmax_Fluctuations_yearThreshold_regions <- function(pst,regions,isSignif,numcol=3){
	require(viridis)
	ff1 <- filter(pst,regsub %in% regions)
	ff2 <- inner_join(ff1,isSignif) %>% mutate(is_signif=TRUE)
	ff3 <- anti_join(ff1 %>% ungroup(),isSignif) %>% mutate(is_signif=FALSE)
	ff1 <- bind_rows(ff2,ff3)
	#%>% bind_rows( filter(ff1,!(threshold %in% isSignif)) %>% mutate(is_signif=FALSE) )
	#
	# Fluctuations around the mean Smax - <Smax>/TotArea
	#
	g <- ggplot(ff1, aes(y=delta_prop_max_patch,x=year,colour=is_signif)) +  theme_bw() +
		geom_point(shape=19) + facet_grid(threshold~regsub) +
		ylab(expression(Delta~RS[max])) + scale_colour_viridis(discrete = T,guide=F,direction = -1) +
		theme(axis.text.x = element_text(angle=90,hjust=0),plot.title = element_text(hjust = 0.5)) +
		stat_quantile(quantiles=c(.10,.90),linetype=2)

	print(g)
}

#  Plot fluctuations of Absolute max patch Smax by year and faceted by threshold
#
#  pst: pstat_threshold data frame
#  regions: vector of regions to include
plot_Smax_Fluctuations_yearThreshold <- function(pst,regions){

	ff1 <- filter(pst,regsub %in% regions)
	#
	# Fluctuations around the mean Smax - <Smax>/TotArea
	#
	g <- ggplot(ff1, aes(y=delta_max_patch,x=year,colour=region)) +  theme_bw() +
		geom_point(shape=19) + facet_wrap(~threshold) +
		ylab(expression(Delta~S[max]~~~(km^2))) + scale_colour_brewer(palette="Set1",name="Sub-Region",guide=F) +
		theme(axis.text.x = element_text(angle=90,hjust=0)) +
		stat_quantile(quantiles=c(.10,.50,.90),linetype=2)

	print(g)
}

#
#' Call python routine to estimate distributions and likelihood ratio tests
#'
#' @param binDir folder with bin files with patch sizes
#'
#' @return data frame with results
#'
call_python_powlawfit <- function(binDir,fit=TRUE){

	ps <-  paste0("python ", oldcd,"/Code/powlawfit.py 1")

	setwd(binDir)
	if(fit){
		file.remove("fittedDistributions.txt")

		system(ps)
	}
	pyfit <- read.table("fittedDistributions.txt", header=TRUE,sep="\t",stringsAsFactors=FALSE)
	#names(pyfit)

	pyfit1 <- pyfit %>% group_by(model_name,file_name) %>% do(  {
		ss <- strsplit(.$file_name,"_")
		region <- ss[[1]][2]
		subregion <- ss[[1]][3]
		threshold <- ss[[1]][4]
		year <- gsub(".*\\.A([0-9]{4}).*","\\1",.$file_name)
		data.frame(region=region,subregion=subregion,threshold=threshold,year=year)})

	pyfit <- pyfit %>% inner_join(pyfit1) %>% arrange(region,subregion,threshold)

	# Lognormal without restriction has mu negative which results in a 99.7% probability is outside the range of patch data
	#

	lNorm <- pyfit  %>% ungroup() %>% filter(grepl("Log.*",model_name)) %>% select(model_name:xmin) %>% mutate(mu=exp(par1),si=exp(par2),lowd=mu/si^3,hid=mu*si^3)

	print(lNorm %>% mutate(higher= hid>.01) %>% group_by(model_name,higher) %>% summarize(n=n(), mlow=mean(lowd),mhi=mean(hid)) %>% mutate(modFreq= n/sum(n)))
	#
	#
	pyfit <- filter(pyfit, model_name!="LogNorm")

	pyfit <- pyfit %>% group_by(file_name) %>% mutate(delta_AICc= AICc - min(AICc),
													  norm_AICc_w = exp(-0.5*delta_AICc),
													  AICc_weight=exp(-0.5*delta_AICc)/sum(norm_AICc_w))

	setwd(oldcd)

	return(list(pyfit=pyfit,lNorm=lNorm))
	}

#
#' Call python routine to estimate distributions and likelihood ratio tests
#' for delta_Smax and delta_RSmax
#'
#' @param binDir folder with bin files with patch sizes
#'
#' @return data frame with results
#'
call_python_powlawfit_delta_threshold <- function(ff,binDir,fit=TRUE){

	setwd(binDir)

	group_by(ff, regsub,threshold) %>% do( nothing={
		zz <- file(paste0("delta_", .$regsub,"_",.$threshold,"_.bin")[1], "wb")
		writeBin(.$delta_max_patch,zz)
		close(zz)
		return(.$regsub)
	    })

	ps <-  paste0("python ", oldcd,"/Code/powlawfit.py 0")

	if(fit){
		file.remove("fittedDistributions.txt")

		system(ps)
	}
	pyfit <- read.table("fittedDistributions.txt", header=TRUE,sep="\t",stringsAsFactors=FALSE)
	#names(pyfit)

	pyfit1 <- pyfit %>% group_by(model_name,file_name) %>% do(  {
		ss <- strsplit(.$file_name,"_")
		regsub <- ss[[1]][2]
		threshold <- ss[[1]][3]
		data.frame(regsub=regsub,threshold=threshold)})

	pyfit <- pyfit %>% inner_join(pyfit1) %>% arrange(regsub,threshold)

	#
	#
	pyfit <- filter(pyfit, model_name!="LogNormPos")
	pyfit <- filter(pyfit, model_name!="PowerExp")

	pyfit <- pyfit %>% group_by(file_name) %>% mutate(delta_AICc= AICc - min(AICc),
													  norm_AICc_w = exp(-0.5*delta_AICc),
													  AICc_weight=exp(-0.5*delta_AICc)/sum(norm_AICc_w)) %>%
		ungroup() %>% select( -file_name )

	unlink("*.bin")
	setwd(oldcd)

	return(pyfit=pyfit)
	}


#' Splits and array along a given axis, either totally or only subsets
#'
#' @param X        An array that should be split
#' @param along    Along which axis to split; use -1 for highest dimension
#' @param subsets  Whether to split each element or keep some together
#' @param drop     Remove unused dimensions after mapping
#'    default: drop if all resulting arrays have same number of dimensions
#' @return         A list of arrays that combined make up the input array
#' @export
split = function(X, along, subsets=c(1:dim(X)[along]), drop=NULL) {
    if (!is.array(X) && !is.vector(X) && !is.data.frame(X))
        stop("X needs to be either vector, array or data.frame")
    if (along < 0)
        along = length(dim(X)) - along + 1

    if (any(is.na(subsets)))
        warning("'subsets' contains NA, dropping those values")

    usubsets = stats::na.omit(unique(subsets))
    lus = length(usubsets)
    idxList = base::rep(list(base::rep(list(TRUE), length(dim(X)))), lus)

    for (i in 1:lus) {
        cur = subsets==usubsets[i]
        cur[is.na(cur)] = FALSE
        idxList[[i]][[along]] = cur
    }

    if (length(usubsets)!=dim(X)[along] || !is.numeric(subsets)) {
        lnames = usubsets
        if (is.null(drop))
            drop = FALSE
    } else {
        lnames = base::dimnames(X)[[along]]
        if (is.null(drop))
            drop = TRUE
    }

    subs = function(ll) subset(X, ll, drop=drop)
    stats::setNames(lapply(idxList, subs), lnames)
}


#' Score HIV Status Indicators
#'
#' @param df site MSD file
#'
#' @importFrom magrittr %>%
#' @export

score_stat <- function(df){

  #1. OVC Known Status
  if(all((c("OVC_HIVSTAT", "OVC_SERV") %in% unique(df$indicator))) == TRUE){
    stat_ovc <- df %>%
      dplyr::filter(indicator %in% c("OVC_HIVSTAT", "OVC_SERV"),
             (standardizeddisaggregate == "Total Numerator" |
                (standardizeddisaggregate == "ReportedStatus" & otherdisaggregate ==  "No HIV Status"))) %>%
      ICPIutilities::add_cumulative() %>%
      dplyr::mutate(standardizeddisaggregate = stringr::str_remove(standardizeddisaggregate, " ")) %>%
      tidyr::unite(ind, indicator, standardizeddisaggregate) %>%
      dplyr::group_by(operatingunit, psnu, sitename, orgunituid, ind) %>%
      dplyr::summarise_at(dplyr::vars(fy2018cum), ~ sum(., na.rm = TRUE)) %>%
      dplyr::ungroup() %>%
      tidyr::spread(ind, fy2018cum) %>%
      dplyr::filter_at(dplyr::vars(dplyr::contains("OVC")), dplyr::any_vars(!is.na(.) & .!=0)) %>%
      dplyr::mutate(knownstatus = round(1-(OVC_HIVSTAT_ReportedStatus/OVC_HIVSTAT_TotalNumerator), 2)) %>%
      dplyr::select(operatingunit, psnu, sitename, orgunituid, ovc_serv = OVC_SERV_TotalNumerator, knownstatus)

    stat_ovc <- stat_ovc %>%
      dplyr::mutate(stat.ovc.score =
                      dplyr::case_when(ovc_serv > median(ovc_serv, na.rm = TRUE) &
                                       knownstatus < median(knownstatus, na.rm = TRUE)     ~ 2,
                                       knownstatus < median(knownstatus, na.rm = TRUE)     ~ 1,
                                       TRUE                                                ~ 0)) %>%
      dplyr::rename(stat.ovc.value = knownstatus) %>%
      dplyr::select(-ovc_serv)
  }

  valcheck <- df %>%
    dplyr::filter(indicator %in% c("PMTCT_STAT", "TB_STAT"),
                  stringr::str_detect(standardizeddisaggregate, "Total")) %>%
    ICPIutilities::add_cumulative() %>%
    dplyr::summarise_at(dplyr::vars(fy2018cum), sum, na.rm = TRUE)

  if(valcheck != 0 && any((c("PMTCT_STAT", "TB_STAT") %in% unique(df$indicator))) == TRUE){
  #2. & 3. PMTCT & TB Known Status
    stat_oth <- df %>%
      dplyr::filter(indicator %in% c("PMTCT_STAT", "TB_STAT"),
                    stringr::str_detect(standardizeddisaggregate, "Total")) %>%
      ICPIutilities::add_cumulative() %>%
      dplyr::group_by(operatingunit, psnu, sitename, orgunituid, indicator, numeratordenom) %>%
      dplyr::summarise_at(dplyr::vars(fy2018cum), sum, na.rm = TRUE) %>%
      dplyr::ungroup() %>%
      dplyr::filter(fy2018cum != 0) %>%
      tidyr::spread(numeratordenom, fy2018cum) %>%
      dplyr::mutate(knownstatus = round(N / D, 2)) %>%
      dplyr::select(-N)

    stat_oth <- stat_oth %>%
      dplyr::mutate(score =
                      dplyr::case_when(D > median(D, na.rm = TRUE) &
                                       knownstatus < median(knownstatus, na.rm = TRUE)     ~ 2,
                                       knownstatus < median(knownstatus, na.rm = TRUE)     ~ 1,
                                       TRUE                                                ~ 0)) %>%
      dplyr::rename(value = knownstatus) %>%
      dplyr::select(-D) %>%
      dplyr::mutate(indicator = stringr::str_extract(indicator, "(PMTCT|TB)") %>% paste0("stat.", .) %>% tolower()) %>%
      tidyr::gather(type, val, value, score) %>%
      tidyr::unite(ind, indicator, type, sep = ".") %>%
      tidyr::spread(ind, val)
  }

  #join together
  if(all(exists(c("stat_ovc", "stat_oth")))){
    stat <- dplyr::full_join(stat_ovc, stat_oth, by = c("operatingunit", "psnu", "sitename", "orgunituid"))
  }

  #return
  if(exists("stat")) {
    return(stat)
  } else if(exists("stat_ovc")) {
    stat <- stat_ovc
    return(stat)
  } else if(exists("stat_oth")) {
    stat <- stat_oth
    return(stat)
  } else {
    stat <- tibble::tibble(operatingunit = as.character(NA),
                           psnu = as.character(NA),
                           sitename = as.character(NA),
                           orgunituid = as.character(NA))
    return(stat)
  }

}


bio.blue <- function (n, alpha=1) {
    if ((n <- as.integer(n[1])) > 0) {
      blue = 4/6
      c( hsv( h = blue,
              s = seq(0, 1, length = (n-1)),
              v = 1,
              alpha = alpha )
       )
    }
  }


#' Functional normalization
#'
#' Apply functional normalization to a set of Infinium HumanMethylation450 BeadChip IDAT files.
#'
#' Fortin JP, Labbe A, Lemire M, Zanke BW, Hudson TJ, Fertig EJ, Greenwood CM, Hansen KD.
#' Functional normalization of 450k methylation array data
#' improves replication in large cancer studies.
#' Genome Biol. 2014 Dec 3;15(12):503. doi: 10.1186/s13059-014-0503-2.
#' PMID: 25599564
#'
#' @param samplesheet Output from \code{\link{meffil.read.samplesheet}()} or
#' \code{\link{meffil.create.samplesheet}()}.
#'
#' Arguments to \code{\link{meffil.qc}()}:
#' @param number.quantiles
#' @param detection.threshold
#' @param bead.threshold
#' @param sex.cutoff
#' @param chip
#' @param featureset
#' @param cell.type.reference
#'
#' Argument to \code{\link{meffil.qc.summary}()}:
#' @param qc.parameters (parameters)
#'
#' Arguments to \code{\link{meffil.qc.report}()}:
#' @param qc.file (output.file)
#' @param author
#' @param study
#'
#' Arguments to \code{\link{meffil.normalize.quantiles}()}:
#' @param number.pcs
#' @param fixed.effects Names of columns in samplesheet that should be included as fixed effects
#' along with control matrix principal components (Default: NULL).
#' @param random.effects Names of columns in samplesheet that should be included as random effects
#' (Default: NULL).
#'
#' Arguments to \code{\link{meffil.normalize.samples}()}:
#' @param just.beta
#' @param gds.filename If not \code{NULL} (default), then saves the output to a GDS (Genomic Data Structure).
#' This is for cases where the output is too large to fit into main memory.
#' The GDS option assumes that argument \code{just.beta == TRUE}.
#' @param pseudo
#'
#' Arguments to \code{\link{meffil.methylation.pcs}()}.
#' @param npcs (Default: 1:10).
#' @param probe.range (Default: 5000).
#' @param autosomal (Default: TRUE).
#'
#' Arguments to \code{\link{meffil.normalization.summary}()}:
#' @param norm.parameters (parameters)
#' @param norm.file (output.file)
#'
#' Other:
#' @param verbose If \code{TRUE}, then status messages are printed during execution
#' (Default: \code{FALSE}).
#'
#' @return A list:
#' - qc.summary \code{\link{meffil.qc.summary}()} output.
#' - norm \code{\link{meffil.normalize.quantiles}()} output.
#' - beta Normalized beta matrix (methylation levels).
#' - norm.summary \code{\link{meffil.normalization.summary}()} output.
#'
#' @export
meffil.normalize.dataset <- function(samplesheet,

                                     ## meffil.qc
                                     number.quantiles=500,
                                     detection.threshold=0.01,
                                     bead.threshold=3,
                                     sex.cutoff=-2,
                                     chip=NA,
                                     featureset=chip,
                                     cell.type.reference=NA,

                                     ## meffil.qc.summary
                                     qc.parameters=meffil.qc.parameters(),

                                     ## meffil.qc.report
                                     qc.file = "meffil-qc-report.md",
                                     author = "Analyst",
                                     study = "IlluminaHuman450 data",

                                     ## meffil.normalize.quantiles
                                     number.pcs=2,
                                     fixed.effects=NULL,
                                     random.effects=NULL,

                                     ## meffil.normalize.samples
                                     pseudo=100,
                                     just.beta=T,
                                     gds.filename=NULL,

                                     ## meffil.methylation.pcs
                                     probe.range=5000,
                                     autosomal=T,

                                     ## meffil.normalization.summary
                                     norm.parameters=NULL,
                                     norm.file="meffil-normalization-report.md",

                                     verbose=FALSE) {

    qc.objects <- meffil.qc(samplesheet,
                            number.quantiles=number.quantiles,
                            verbose=verbose,
                            detection.threshold=detection.threshold,
                            bead.threshold=bead.threshold,
                            sex.cutoff=sex.cutoff,
                            chip=chip,
                            featureset=featureset,
                            cell.type.reference=cell.type.reference)

    qc.summary <- meffil.qc.summary(qc.objects,
                                    parameters=qc.parameters,
                                    verbose=verbose)

    meffil.qc.report(qc.summary,
                     output.file=qc.file,
                     author=author,
                     study=study)

    if (nrow(qc.summary$bad.samples) > 0)
        qc.objects <- meffil.remove.samples(qc.objects, qc.summary$bad.samples$sample.name)

    norm.objects <- meffil.normalize.quantiles(qc.objects,
                                               fixed.effects=fixed.effects,
                                               random.effects=random.effects,
                                               number.pcs=number.pcs,
                                               verbose=verbose)

    norm <- meffil.normalize.samples(norm.objects,
                                     pseudo=pseudo,
                                     just.beta=just.beta,
                                     gds.filename=gds.filename,
                                     cpglist.remove=qc.summary$bad.cpgs$name,
                                     verbose=verbose)
    if (just.beta)
        beta <- norm
    else
        beta <- get.beta(norm$M, norm$U)

    if (is.null(norm.parameters))
        norm.parameters <- meffil.normalization.parameters(norm.objects)

    sites <- NULL
    if (autosomal)
        sites <- meffil:::autosomal.sites(beta)
    pcs <- meffil.methylation.pcs(beta, probe.range=probe.range, sites=sites, verbose=verbose)

    norm.summary <- meffil.normalization.summary(norm.objects=norm.objects,
                                                 pcs=pcs,
                                                 parameters=norm.parameters,
                                                 verbose=verbose)

    meffil.normalization.report(norm.summary,
                                output.file=norm.file,
                                author=author,
                                study=study)

    list(qc.summary=qc.summary,
         norm.objects=norm.objects,
         M=if (just.beta) NULL else norm$M,
         U=if (just.beta) NULL else norm$U,
         beta=beta,
         norm.summary=norm.summary)
}


code 'cf_liquid_gap'
name '流动性缺口'
dimensions {
	accbook null
	liquidGap null
}
dataRequest {
	table 'liquidGap',{
		allDimensions (['organ','accbook','currency','liquidGap'])
	}
	fields 'accbook,liquidGap,principal value'
	contextParams (['date','organ','currency','staticModel'])
}

dataRequest StaticModelLgaplimitDataRequest

derivedHeads{
    accbook ([
        new Head(name:'流动性缺口',aggregate:true,
            formula:{
                def grids=thisColGrids({parent==null})
                def a=grids.find{it.rowHeadGrid.model?.alType=='A'}
                def l=grids.find{it.rowHeadGrid.model?.alType=='L'}
                if(a && l){
                    a-l
                }
            },
            evaluatedCallback:{
                    //下限额
                    def llimit=v0([liquidGap:params['liquidGap'],bal:'lvalue',dataRequest:'lgaplimit'])
                    //上限额
                    def ulimit=v0([liquidGap:params['liquidGap'],bal:'hvalue',dataRequest:'lgaplimit'])
                    if((llimit!=null && value<llimit) || (ulimit!=null && value>ulimit)){
                        if(properties==null){properties=[:]}
                        properties['cssClass']='lgap_out_of_limit'
                    }
            }
        ),
        new Head(name:'缺口累计',aggregate:true,
            formula:{
                (col==0)? higher:(left+higher)
            },
            evaluatedCallback:{
                    //下限额
                    def llimit=v0([liquidGap:params['liquidGap'],bal:'accumLvalue',dataRequest:'lgaplimit'])
                    //上限额
                    def ulimit=v0([liquidGap:params['liquidGap'],bal:'accumHvalue',dataRequest:'lgaplimit'])
                    if((llimit!=null && value<llimit) || (ulimit!=null && value>ulimit)){
                        if(properties==null){properties=[:]}
                        properties['cssClass']='lgap_out_of_limit'
                    }
            }
        )
    ])
}
dataGrids {
    apply selectRows({children!=null}),{
		formula {sumChildren()}
	}
}


#Generacion de la Linea de Muerte para la UBA año 2020
#Solo necesita 32GB de memoria RAM  , 8 vCPU   y una hora para correr

#limpio la memoria
rm( list=ls() )  #remove all objects
gc()             #garbage collection

require("data.table")
require("lightgbm")
require("DiceKriging")
require("mlrMBO")

#en estos archivos queda el resultado
kbayesiana  <-  paste0("~/buckets/b2/opt_bayesiana_lgbm/linea_de_muerte.RDATA")

kBO_iter    <-  10  #cantidad de iteraciones de la Optimizacion Bayesiana

#------------------------------------------------------------------------------
#esta es la funcion de ganancia, que se busca optimizar
#se usa internamente a LightGBM
#se calcula internamente la mejor ganancia para todos los puntos de corte posibles

fganancia_logistic_lightgbm   <- function(probs, data)
{
  vlabels <- getinfo(data, "label")

  tbl <- as.data.table( list( "prob"=probs, "gan"= ifelse( vlabels==1, 29250, -750 ) ) )

  setorder( tbl, -prob )
  tbl[ , gan_acum :=  cumsum( gan ) ]
  gan <- max( tbl$gan_acum )

  return(  list( name= "ganancia", value=  gan, higher_better= TRUE ) )
}
#------------------------------------------------------------------------------
#funcion que va a optimizar la Bayesian Optimization

estimar_lightgbm <- function( x )
{
  modelo <-  lgb.train(data= dBO_train,
                       objective= "binary",  #la clase es binaria
                       eval= fganancia_logistic_lightgbm,  #esta es la fuciona optimizar
                       valids= list( valid1= dBO_test1 ),
                       first_metric_only= TRUE,
                       metric= "custom",  #ATENCION   tremendamente importante
                       num_iterations=  999999,  #un numero muy grande
                       early_stopping_rounds=  200,
                       min_data_in_leaf= as.integer( x$pmin_data_in_leaf ),
                       feature_fraction= 0.25,
                       learning_rate= 0.02,
                       feature_pre_filter= FALSE,
                       verbose= -1,
                       seed= 102191
                      )

  ganancia1  <- unlist(modelo$record_evals$valid1$ganancia$eval)[ modelo$best_iter ]

  #esta es la forma de devolver un parametro extra
  attr(ganancia1 ,"extras" ) <- list("pnum_iterations"= modelo$best_iter )

  cat( modelo$best_iter, ganancia1, "\n" )

  return( ganancia1 )
}
#------------------------------------------------------------------------------
#Aqui comienza el programa
dataset  <- fread("~/buckets/b1/datasets/fe_exthist.txt.gz")

campos_lags  <- setdiff(  colnames(dataset) ,  c("clase_ternaria","clase01", "numero_de_cliente","foto_mes") )

#agreglo los lags de orden 1
setorderv( dataset, c("numero_de_cliente","foto_mes") )
dataset[,  paste0( campos_lags, "_lag1") :=shift(.SD, 1, NA, "lag"), by=numero_de_cliente, .SDcols= campos_lags]

#agrego los deltas de los lags, de una forma nada elegante
for( vcol in campos_lags )
{
   dataset[,  paste0(vcol, "_delta1") := get( vcol)  - get(paste0( vcol, "_lag1"))]
}

#paso la clase a binaria que tome valores {0,1}  enteros
dataset[ , clase01 :=  ifelse( clase_ternaria=="BAJA+2", 1L, 0L)  ]

#los campos que se van a utilizar, intencionalmente no uso  numero_de_cliente
campos_buenos  <- setdiff(  colnames(dataset) ,  c("clase_ternaria","clase01","numero_de_cliente") )

#hago undersampling de los negativos
#me quedo con TODOS los positivos, pero con solo el 5% de los negativos
set.seed(102191)
dataset[ , azar:= runif( nrow(dataset) ) ]

dataset[ ( foto_mes>=201701 & foto_mes<=202003 & foto_mes!=201912 & ( clase01==1 | azar<=0.05) ),  BO_train := 1L]

#Testeo en 201902, el mismo mes pero un año antes
dataset[ foto_mes==201912,  BO_test1 := 1L]

#dejo los datos en el formato que necesita LightGBM
dBO_train  <- lgb.Dataset( data  = data.matrix(  dataset[ BO_train==1, campos_buenos, with=FALSE]),
                           label = dataset[ BO_train==1, clase01],
                           free_raw_data = TRUE
                         )

dBO_test1  <- lgb.Dataset( data  = data.matrix(  dataset[ BO_test1==1, campos_buenos, with=FALSE]),
                           label = dataset[ BO_test1==1, clase01],
                           free_raw_data = TRUE
                         )

dataset_aplicacion <- copy( dataset[ foto_mes==202005, ] )

#libero la memoria borrando el dataset
rm(dataset)
gc()

#Aqui comienza la configuracion de la Bayesian Optimization
configureMlr(show.learner.output = FALSE)

#configuro la busqueda bayesiana,  los hiperparametros que se van a optimizar
#por favor, no desesperarse por lo complejo
obj.fun <- makeSingleObjectiveFunction(
        name = "OptimBayesiana",  #un nombre que no tiene importancia
        fn   = estimar_lightgbm,  #aqui va la funcion que quiero optimizar
        minimize= FALSE,  #quiero maximizar la ganancia
        par.set = makeParamSet(
            makeNumericParam("pmin_data_in_leaf",  lower=  10, upper=  30000 )
            ),
        has.simple.signature = FALSE,  #porque le pase los parametros con makeParamSet
        noisy= TRUE
        )

ctrl  <-  makeMBOControl( save.on.disk.at.time = 600,  save.file.path = kbayesiana )
ctrl  <-  setMBOControlTermination(ctrl, iters = kBO_iter )
ctrl  <-  setMBOControlInfill(ctrl, crit = makeMBOInfillCritEI())

surr.km  <-  makeLearner("regr.km", predict.type= "se", covtype= "matern3_2", control = list(trace = FALSE))

if(!file.exists(kbayesiana))
{
  #lanzo la busqueda bayesiana
  run  <-  mbo(obj.fun, learner = surr.km, control = ctrl)
} else {
  #retoma el procesamiento en donde lo dejo
  run <- mboContinue( kbayesiana )
}

#En  run$x$pmin_data_in_leaf  ha quedo el optimo
#------------------------------------------------------------------------------

#calculo el modelo final
modelo_final <- lgb.train(data= dBO_train,
                          objective= "binary",
                          eval= fganancia_logistic_lightgbm,
                          valids= list( valid1= dBO_test1 ),
                          first_metric_only= TRUE,
                          metric= "custom",
                          num_iterations=  999999,
                          early_stopping_rounds=  200,
                          learning_rate= 0.02,  #ATENCION, este es el valor que se cambia
                          min_data_in_leaf= as.integer( run$x$pmin_data_in_leaf ),
                          feature_pre_filter= FALSE,
                          feature_fraction= 0.25,
                          verbose= -1,
                          seed= 102191
                         )

#Genero los archivos que voy a probar contra el Leaderboard Publico y quedarme con el mejor
prediccion_202005  <- predict( modelo_final,  data.matrix( dataset_aplicacion[  , campos_buenos, with=FALSE]))

#Genero  posibles probabilidades de corte, tener en
for( vprob_corte  in (25:25)/100 )  #de 0.15 a 0.35
{
  entrega  <- as.data.table( list( "numero_de_cliente"=  dataset_aplicacion[ , numero_de_cliente],
                                   "estimulo"=  (prediccion_202005> vprob_corte)  ) )

  #genero el archivo de salida
  fwrite( entrega, logical01=TRUE, sep=",",  file= paste0("~/buckets/b1/work/BORRADOR_lineademuerte_04_", vprob_corte*100, ".csv") )

  data = data.table('numero_de_cliente' = dataset_aplicacion[, numero_de_cliente], 'prob' = prediccion_202005)
  fwrite(data, sep = ',',  file = paste0("~/buckets/b1/work/BORRADOR_lineademuerte_04.probs"))
}

#Se deben probar con el metodo de busqueda binaria contra el leaderboard publico las salidas, y quedarse con el mejor


#!/usr/bin/Rscript
# Command line arguments for R are not fun... so to make this easy create the args
# by prepending them to this script directly before the R call:
# [bash]$ echo 'arg1 = "value";arg2="someValue"' |cat - script.r | R --no-save
# Variables dataFrame, inputDir, outputDir,  are required
args <- commandArgs(TRUE)

if (length(args) != 3) {
    print("Usage: DESeq.r <refFile> <compFile> <outputDir> <refName> <compName>")
}

refFile <- args[1]
compFile <- args[2]
outputDir <-args[3]
refName <- args[4]
compName <- args[5]

#biocLite("DESeq2");
library(DEGseq);

geneExpMatrix1 <- readGeneExp(file=refFile, geneCol=1, valCol=2);
geneExpMatrix2 <- readGeneExp(file=compFile, geneCol=1, valCol=2);
layout(matrix(c(1,2,3,4,5,6), 3, 2, byrow=TRUE));
par(mar=c(2, 2, 2, 2));
DEGexp(geneExpMatrix1=geneExpMatrix1, geneCol1=1, expCol1=2, groupLabel1=refName,
geneExpMatrix2=geneExpMatrix2, geneCol2=1, expCol2=2, groupLabel2=compName,
method="MARS", outputDir= outputDir);


ld <- function(a, b) Rdym:::levenshtein_dist(a, b)

test <- function(word1, word2)
{
  tmp <- function(word1, word2) ld(word1, word2) == adist(word1, word2)[1,1]
  t1 <- tmp(word1, word2)
  t2 <- tmp(word2, word1)
  t3 <- tmp(word1, word1)

  if (!all(c(t1, t2, t3)))
  {
    if (!t1 && !t2)
      stop("it's really broken")
    if (!t1 || !t2)
      stop("symmetry fails")
    if (!t3)
      stop("reflexivity fails")
  }
  else
    invisible(TRUE)
}

test("kitten", "smitten")
test("gumbo", "gambol")
test("shave", "brave")
test("abcdef", "g")

a <- "rm"
b <- "rmorm"
stopifnot(ld(a, b) == 3)
stopifnot(ld(b, a) == 3)


library(zoo)
library(data.table)
library(FeatureHashing)
library(xgboost) # for extreme booster tree
library(dplyr)
library(Matrix)
library(h2o) # for random forest e deeplearning
library(glmnet) # for glm
library(smbinning) # for optimal binning of continous variable
library(ROCR)
library(caret)

#load data frame
train=fread('/Users/mauropelucchi/Desktop/Work/University/Master_BI_2016/Pump_it_waterpoint/pump_data/training_set.csv') %>% as.data.frame()
labels=fread('/Users/mauropelucchi/Desktop/Work/University/Master_BI_2016/Pump_it_waterpoint/pump_data/training_set_labels.csv') %>% as.data.frame()
test=fread('/Users/mauropelucchi/Desktop/Work/University/Master_BI_2016/Pump_it_waterpoint/pump_data/test_set_values.csv') %>% as.data.frame()

#merge data frame
d1 <- merge(train, labels, by = "id", all.x = T)
d2 <- test

d1$train <- 1
d2$status_group <- -1
d2$status_group_bin <- -1
d2$status_group_id <- -1
d2$train <- 0

#transorm covariate
d1$funder[d1$funder == 0] = NA;
d1$installer[d1$installer == 0] = NA;

d1$gps_height[d1$gps_height == 0] = 0;
d1$population[d1$population == 0] = 0;
d1$amount_tsh[d1$amount_tsh == 0] = 0;
d1$construction_year[d1$construction_year <= 0] = 0;
d1$construction_year[d1$construction_year <= 0]= median(d1$construction_year[d1$construction_year > 0])
d1$gps_height[d1$gps_height <= 0]= median(d1$gps_height[d1$gps_height > 0])
d1$population[d1$population <= 0]= median(d1$population[d1$population > 0])
d1$amount_tsh[d1$amount_tsh <= 0]= median(d1$amount_tsh[d1$amount_tsh > 0])

d2$funder[d2$funder == 0] = NA;
d2$installer[d2$installer == 0] = NA;

d2$gps_height[d2$gps_height == 0] = 0;
d2$population[d2$population == 0] = 0;
d2$amount_tsh[d2$amount_tsh == 0] = 0;
d2$construction_year[d2$construction_year == 0] = 0;
d2$construction_year[d2$construction_year <= 0]= median(d2$construction_year[d2$construction_year > 0])
d2$gps_height[d2$gps_height <= 0]= median(d2$gps_height[d2$gps_height > 0])
d2$population[d2$population <= 0]= median(d2$population[d2$population > 0])
d2$amount_tsh[d2$amount_tsh <= 0]= median(d2$amount_tsh[d2$amount_tsh > 0])

d1$latitude[d1$latitude > -1e-06] = NA;
d1$longitude[d1$longitude < -1e-06] = NA;

d2$latitude[d2$latitude > -1e-06] = NA;
d2$longitude[d2$longitude < -1e-06] = NA;

var = names(d1)
for (f in var) {
  if (class(d1[[f]])=="character") {
    d1[[f]] = tolower(d1[[f]])
    d2[[f]] = tolower(d2[[f]])
  }

}

d1$status_group_id[d1$status_group == 'functional'] = 0;
d1$status_group_id[d1$status_group == 'non functional'] = 1;
d1$status_group_id[d1$status_group == 'functional needs repair'] = 1;

d1$status_group_bin[d1$status_group == 'functional'] = 'to repare';
d1$status_group_bin[d1$status_group == 'non functional'] = 'no repare';
d1$status_group_bin[d1$status_group == 'functional needs repair'] = 'no repare';

# remove duplicate variables
d1$status_group = NULL
d2$status_group = NULL
d1$date_recorded = NULL
d2$date_recorded = NULL
d1$wpt_name = NULL
d2$wpt_name = NULL
d1$num_private = NULL
d2$num_private = NULL
d1$quality_group = NULL
d2$quality_group = NULL
d1$region_code = NULL
d2$region_code = NULL
d1$district_code = NULL
d2$district_code = NULL
d1$recorded_by = NULL
d2$recorded_by = NULL
d1$scheme_name = NULL
d2$scheme_name = NULL
d1$extraction_type_group = NULL
d2$extraction_type_group = NULL
d1$payment = NULL
d2$payment = NULL
d1$quantity_group = NULL
d2$quantity_group = NULL
d1$management_group = NULL
d2$management_group = NULL
d1$source_type = NULL
d2$source_type = NULL
d1$waterpoint_type_group = NULL
d2$waterpoint_type_group = NULL

# remove duplicate record
print(paste('Total number of cases:', nrow(d1)))
train2 = copy(d1)
train2$id <- NULL
d1 = d1[!duplicated(train2),]
print(paste('Total number of unique cases:', nrow(d1)))

# Features to transform - usually with large cardinality
features <- c('subvillage', 'funder', 'installer','ward','lga')
#head(d1[, features], 20)
#head(d2[, features], 20)
# Mean of the status group with noise
n <- nrow(d1)
for (f in features){
  g <- paste0(f,"_","p")
  cat(f, "\n")
  status_group_mean <- tapply(d1$status_group_id, d1[[f]], mean)
  d2[[g]] <- status_group_mean[d2[[f]]]
  d1[[g]] <- status_group_mean[d1[[f]]]
  d1[[g]] <-  rnorm(n, 1, 0.01) * (d1[[g]] * n - d1$status_group_id) / (n - 1)
}

#check data
#head(d1, 10)

n_valid = round(nrow(d1) * 0.3);
n_train = nrow(d1) - n_valid;
d1train_i = sample(nrow(d1), n_train, replace=FALSE)
d1train = d1[d1train_i, ]
d1valid = d1[-d1train_i, ]
d1test = d2

#####################################
# try extreme gradient booster
set.seed(456789)

Y <- d1train$status_group_id
V <- d1valid$status_group_id

d1train$status_group_id <- NULL
d1valid$status_group_id <- NULL
d1test$status_group_id <- NULL

D=rbind(d1train,d1valid,d1test)
D$i=1:dim(D)[1]
test_id=d1test$id

gc()

# show final dataset
head(D, n=10)

# REMOVE VARIBLES
D$longitude = NULL
D$latitude = NULL
D$subvillage = NULL
D$ward = NULL
D$status_group_bin = NULL

# convert categorical covariate to numeric
char.cols=names(D)
for (f in char.cols) {
  if (class(D[[f]])=="character") {
    levels <- unique(c(D[[f]]))
    D[[f]] <- as.numeric(factor(D[[f]], levels=levels))
  }
  if (class(D[[f]])=="factor") {
    D[[f]] <- as.numeric(D[[f]])
  }
}

# show final dataset
head(D, n=10)

D.sparse=
  cBind(sparseMatrix(D$i,D$basin),
        sparseMatrix(D$i,D$region),
        sparseMatrix(D$i,D$lga),
        sparseMatrix(D$i,D$waterpoint_type),
        sparseMatrix(D$i,D$extraction_type),
        sparseMatrix(D$i,D$quantity),
        sparseMatrix(D$i,D$water_quality),
        sparseMatrix(D$i,D$source),
        #
        sparseMatrix(D$i,D$scheme_management),
        sparseMatrix(D$i,D$management),
        sparseMatrix(D$i,D$payment)
  )

D.sparse=
  cBind(D.sparse,
        D$population,
        D$subvillage_p,
        D$ward_p,

        D$construction_year,
        D$amount_tsh,
        D$gps_height,

        #
        D$funder_p,
        D$installer_p,
        #
        D$binay_sum)

train.sparse=D.sparse[1:n_train,]
valid.sparse=D.sparse[(n_train+1):(n_train+n_valid),]
test.sparse=D.sparse[(n_train+1+n_valid):nrow(D.sparse),]

# Hash train to sparse dmatrix X_train
dtrain <- xgb.DMatrix(train.sparse, label = Y)
dvalid <- xgb.DMatrix(valid.sparse, label = V)
dtest  <- xgb.DMatrix(test.sparse)

gc()
watch_list <- list(valid = dvalid, train = dtrain)

### Extreme Gradient Boosted Tree ####

param2 <- list(objective = "binary:logistic",
               eval_metric = "error",
               "stratified"=T,
               booster = "gbtree",
               eta = 0.03,
               subsample = 0.9, # subsample ratio of the training instance
               colsample_bytree = 0.7, # subsample ratio of columns 0.7
               #min_child_weight = 0,
               max_depth = 12 # maximum depth of a tree
)

tab = xgb.cv(data = dtrain, watchlist = watch_list, objective = "binary:logistic", booster = "gbtree",
                 nrounds = 10000, nfold = 10, early.stop.round = 10,
                 maximize = FALSE,
                 evaluation = "logloss", eta = 0.05,
                 max_depth = 12, colsample_bytree = 0.7)

#Create variable that identifies the optimal number of iterations for the model
min_error = which.min(tab[, test.merror.mean])

xgb_m2 <- xgb.train(data = dtrain,
                    param2, nrounds = 10000,
                    watchlist = watch_list,
                    nfold = 10,
                    print_every_n = 100,
                    early.stop.round = 20,
                    maximize = FALSE,
                    save_name = "xgb_m2"
)

#calc confunsion matrix

valid.prd <- predict(xgb_m2, dvalid)
valid.out <- data.frame(id = d1valid$id, status_group_id = valid.prd)
valid.out$status_group_bin[valid.out$status_group_id > 0.25] = 'no repare';
valid.out$status_group_bin[valid.out$status_group_id <= 0.25] = 'to repare';
confusionMatrix(as.data.frame(valid.out)$status_group_bin, as.data.frame(d1valid)$status_group_bin)


library(data.table)
library(stringi)
library(stringr)
library(lubridate)
library(anesrake)

# Declare working directory beforehand in an environment variable
# SPB_COVID_STUDY_PATH = "path_to_your_folder"
# with the aid of usethis::edit_r_environ()
# Restart R session for the changes to make effect
setwd(Sys.getenv('SPB_COVID_STUDY_PATH'))

# Load Сomprehensive monitoring of living
# conditions 2018 data for Saint Petersburg
load("data/kouzh_2018/kouzh_2018_data_spb.rdata")
kouzh_2018_data_spb[, male := NA_real_]
kouzh_2018_data_spb[sex == 1, male := 1]
kouzh_2018_data_spb[sex == 2, male := 0]

# Keep only adults in KOUZh data
kouzh_2018_data_spb <- kouzh_2018_data_spb[ age >= 18 ]

# Load phone survey data from this study
load("data/wave1/phone_survey/phone_survey_data.rdata")

# Load paper survey data from this study
load("data/wave1/paper_survey/paper_survey_data_matched_to_phone_survey_ids.rdata")

# Test results data contains all individuals that were contacted as of this date
initial_phone_call_last_date <- "2020-06-24"
phone_survey_data <- phone_survey_data[interview_date <= initial_phone_call_last_date]

# Remove individuals from Lomonosovskiy and Vsevolozhskiy district as they are outside Saint Petersburg
phone_survey_data <- phone_survey_data[!(district %in% c("Lomonosovskiy District", "Vsevolozhskiy District"))]
# Remove individuals from districts in St. Petersburg that we have omitted from the study
phone_survey_data <- phone_survey_data[!(district %in% c("Kurortniy District", "Petrodvortsoviy District", "Pushkinskiy District", "Kolpinskiy District", "Kronshtadtskiy District", "Krasnoselskiy District"))]
# Remove individuals with missing districts
phone_survey_data <- phone_survey_data[!is.na(district)]

# Define age groups
phone_survey_data[, agegroup := NA_character_]
phone_survey_data[age < 35, agegroup := "18-34"]
phone_survey_data[age >= 35 & age < 50, agegroup := "35-49"]
phone_survey_data[age >= 50 & age < 65, agegroup := "50-64"]
phone_survey_data[age >= 65, agegroup := "65+"]
phone_survey_data[, agegroup := as.factor(agegroup)]

kouzh_2018_data_spb[, agegroup := NA_character_]
kouzh_2018_data_spb[age < 35, agegroup := "18-34"]
kouzh_2018_data_spb[age >= 35 & age < 50, agegroup := "35-49"]
kouzh_2018_data_spb[age >= 50 & age < 65, agegroup := "50-64"]
kouzh_2018_data_spb[age >= 65, agegroup := "65+"]
kouzh_2018_data_spb[, agegroup := as.factor(agegroup)]

# Lives alone variable
kouzh_2018_data_spb[, lives_alone := 0]
kouzh_2018_data_spb[household_size == 1, lives_alone := 1]

# Define raking variables
raking_variables <- c("agegroup", "male", "lives_alone", "education_level")

# Generate target proportions
agegroup_proportions <- kouzh_2018_data_spb[!is.na(agegroup), list(prop = .N/nrow(kouzh_2018_data_spb[!is.na(agegroup)])), by = "agegroup"]
agegroup_proportions_list <- agegroup_proportions$prop
names(agegroup_proportions_list) <- agegroup_proportions$agegroup

male_proportions <- kouzh_2018_data_spb[!is.na(male), list(prop = .N/nrow(kouzh_2018_data_spb[!is.na(male)])), by = "male"]
male_proportions_list <- male_proportions$prop
names(male_proportions_list) <- male_proportions$male
# Zero comes first
male_proportions_list <- rev(male_proportions_list)

lives_alone_proportions <- kouzh_2018_data_spb[!is.na(lives_alone), list(prop = .N/nrow(kouzh_2018_data_spb[!is.na(lives_alone)])), by = "lives_alone"]
lives_alone_proportions_list <- lives_alone_proportions$prop
names(lives_alone_proportions_list) <- lives_alone_proportions$lives_alone
lives_alone_proportions_list <- rev(lives_alone_proportions_list)

education_level_proportions <- kouzh_2018_data_spb[!is.na(education_level), list(prop = .N/nrow(kouzh_2018_data_spb[!is.na(education_level)])), by = "education_level"]
education_level_proportions_list <- education_level_proportions$prop
names(education_level_proportions_list) <- education_level_proportions$education_level

# Define a list with raking targets
raking_target <- list( "male" = male_proportions_list, "agegroup" = agegroup_proportions_list, "education_level" = education_level_proportions_list, "lives_alone" = lives_alone_proportions_list)

# Perform raking
phone_survey_raking_fit <- anesrake(raking_target, phone_survey_data[, c(raking_variables), with = F], phone_survey_data$ID, cap = 5, choosemethod = "total", type = "pctlim", pctlim = 0.05 )

# Save the object with raking
save(phone_survey_raking_fit, file = "estimates/wave1/phone_survey_raking_fit.rdata", compress = "xz")


# File: dbzProcessing.r
# Description:
#    Functions to read and process QPE data: radar and station precipitation tag

# Read in radar data: fixed width format
read.radar <- function(f){
  tmp <- read.fwf(fname, c(8,8,8), header=F, col.names=c("lat","lon","dbz"))
  return(tmp)
}

# Plot radar data with ggmap: remove all 0s and interpolate on the map
plot.radar <- function(dbz){
  require(ggmap)
  map <- get_map(location='Taiwan', zoom=7)
  dbz <- dbz[which(dbz$dbz>0),]
  g <- ggmap(map) + stat_density2d(aes(x=lon, y=lat, fill=..level.., alpha=..level..),
                                   size=2, bins=4, data=dbz, geom="polygon")
  g
  return(g)
}

#
dbz.flist <- function(srcdir){
  output <- NULL
  # Get all days
  daylist <- list.files(srcdir)
  # Loop through days
  for(d in daylist){
    ddir <- paste0(srcdir,d,"/")
    print(ddir)
    fltmp <- list.files(ddir)
    ftab <- data.frame(do.call(rbind, lapply(fltmp, function(x){unlist(strsplit(x,'.', fixed=T))})))
    tmp <- cbind("day"=rep(d, length(fltmp)), "fname"=fltmp, ftab)
    output <- rbind(output, tmp)
  }
  return(output)
}

# Read in preprocessed DBZ data:
read.dbzpcs <- function(fname, npc=20){
  tmp <- read.csv("dbz.ipca50.csv", stringsAsFactors = F, header=F, colClasses = c("character","character",rep("numeric", npc)))
  names(tmp) <- c("date","hhmm",paste("pc", 1:npc, sep="_"))
  return(tmp[,1:(npc+2)])
}

# Create input data for QPE:
# - Use given Y(precipitation) and it's time stamp(YYYYMMDDHH)
# - For the same YYYYMMDD, each HH of precipitation is corresponding to:
#   - 6 HHMM of DBZ data records (with 10min interval)
#   - HH-60min, HH-50min, HH-40min, HH-30min, HH-20min, and HH-10min
#   - impute NA for missing DBZ records
create.input.qpe <- function(y, x, filter.year=NULL){
  # Table for hour-minute correspondence
  hhlist <- c("00","01","02","03","04","05","06","07","08","09","10","11",
              "12","13","14","15","16","17","18","19","20","21","22","23")
  mmlist <- c("00","10","20","30","40","50")
  hhmm <- NULL
  for(h in hhlist){hhmm <- c(hhmm, paste0(h, mmlist))}
  hhmm <- matrix(hhmm, ncol=6, byrow=T)
  # Target hour
  thh <- c("01","02","03","04","05","06","07","08","09","10","11","12",
           "13","14","15","16","17","18","19","20","21","22","23","24")
  # target day-hour
  ydays <- sort(unique(substr(y$date,1,8)))
  newx <- NULL
  for(i in 1:nrow(y)){
    # Process date-hour string
    ydh <- y$date[i]                # YYYYMMDDHH string
    yday <- substr(ydh,1,8)         # YYYYMMDD
    yhh <- substr(ydh,9,10)         # HH
    idx.day <- which(ydays==yday)   # Index of YYYYMMDD
    idx.h <- which(thh==yhh)        # Index of HH
    # Find corresponding X
    ridx.x <- which((x[,1]==yday) & (x[,2] %in% hhmm[idx.h,]))
    # Concatenate all x as the new x
    print(ydh)
    #print(length(ridx.x))
    #print(x[ridx.x, 1:2])
    if(length(ridx.x)==6){
      rec <- as.vector(t(x[ridx.x, -(1:2)]))
      #print(length(rec))
    } else {
      print("missing data")
      rec <- rep(NA, 6*(ncol(x)-2))
    }
    newx <- rbind(newx, rec)
  }
  # Create colnames
  newx <- data.frame(newx)
  pcn <- names(x)[-(1:2)]
  ts <- paste0("m", seq(60,10,-10))
  names(newx) <- apply(expand.grid(pcn, ts), 1, paste, collapse="_")
  #
  return(cbind(y,newx))
}


test_that("Remove commented  characters returns evaluatable code", {

  commented_code = c("# 1 + 1",  "#' 3 + 3")
  noComments <- removeCommentCharacters(commented_code)
#to do  sourcetools::tokenize_string(noComments)

  expect_equal(eval(str2lang(noComments[1])), 2)
  expect_equal(eval(str2lang(noComments[2])), 6)

})


#' Meta cell 2d projection
#'
#' Representing a graph of metacells and their 2D embeddings
#'
#' @slot mc_id id of the metacell object
#' @slot x x coordinate of a (subset) of the metacells
#' @slot y y coordinate of a (subset) of the metacells
#' @slot graph datafame with the edges linking metacells
#'
#'
#' @export tgMC2D
#' @exportClass tgMC2D

tgMC2D <- setClass(
   "tgMC2D",
	slots = c(
	  mc_id = "character",
	  mc_x = "vector",
	  mc_y = "vector",
	  sc_x = "vector",
	  sc_y = "vector",
	  graph = "data.frame")
)

#' Construct a meta cell 2D embedding
#'
#' Just filling up the slots, actuall computation is done by specific algorithms (mcell_mc2d_force)
#'
#' @param mc metacell object
#' @param mc_x x coordinates of metacells
#' @param mc_y y coordinates of metacells
#' @param sc_x x coordinates of cells
#' @param sc_y y coordinates of cells
#' @param graph data.frame with fields mc1, mc2 definining the graph
#' @export

setMethod(
  "initialize",
  signature = "tgMC2D",
  definition =
    function(.Object, mc_id, mc_x, mc_y, sc_x, sc_y, graph) {
		if(is.null(scdb_mc(mc_id))) {
			stop("initlaizing mc2d using mc id ", mc_id, " that is missing from scdb")
		}
		.Object@mc_id = mc_id
		.Object@mc_x = mc_x
		.Object@mc_y = mc_y
		.Object@sc_x = sc_x
		.Object@sc_y = sc_y
		if(length(intersect(colnames(graph), c("mc1", "mc2"))) != 2) {
			stop("Bad tgMC2D initialization, graph parameter must be a dta frame with fields mc1, mc2")
		}
		.Object@graph= graph
      return(.Object)
    }
)

#' Generate a new metacell in scdb
#'
#' This constructs a meta cell cover object and puts it into scdb. It gets an MC assignment (cell->MC_ID), and a matrix, and call standard api of this class to compute the footprints.
#'
#' @param mc2d_id new id of 2d object to add
#' @param mc_id id of scdb meta cell object we link to
#' @param mc_x x coordinates of metacells
#' @param mc_y y coordinates of metacells
#' @param sc_x x coordinates of cells
#' @param sc_y y coordinates of cells
#' @param graph graph data frame (fields mc1,mc2 specifying edges between mc's)
#' @export
mcell_new_mc2d = function(mc2d_id, mc_id, mc_x, mc_y, sc_x, sc_y, graph)
{
	scdb_add_mc2d(mc2d_id, tgMC2D(mc_id, mc_x, mc_y, sc_x, sc_y, graph))
}

#' Rotatae/invert projection
#'
#' transform all coordainte by a rotation and inversion
#'
#' @param mc2d_id new id of 2d object to add
#' @param alpha angle in degrees
#' @param flipx should flip the X over the mean(x)
#' @param flipy should flip the Y over the mean(Y)
#'
#' @export
mcell_mc2d_rotate= function(mc2d_id, alpha = 0, flipx = F, flipy = F)
{
	mc2d = scdb_mc2d(mc2d_id)
	if(is.null(mc2d)) {
		stop("cannot get mc2d object id ", mc2d_id)
	}
	alpha = alpha*pi/180
	sina = sin(alpha)
	cosa = cos(alpha)
	mx = mean(mc2d@sc_x, na.rm=T)
	my = mean(mc2d@sc_y, na.rm=T)
	if(flipx) {
		mc2d@sc_x = 2*mx - mc2d@sc_x
		mc2d@mc_x = 2*mx - mc2d@mc_x
	}
	if(flipy) {
		mc2d@sc_y = 2*my - mc2d@sc_y
		mc2d@mc_y = 2*my - mc2d@mc_y
	}

	dscx = mc2d@sc_x - mx
	dscy = mc2d@sc_y - my
	scx = mx + cosa*dscx - sina*dscy
	scy = my + sina*dscx + cosa*dscy

	dmcx = mc2d@mc_x - mx
	dmcy = mc2d@mc_y - my
	mcx = mx + cosa*dmcx - sina*dmcy
	mcy = my + sina*dmcx + cosa*dmcy

	mc2d@sc_x = scx
	mc2d@sc_y = scy
	mc2d@mc_x = mcx
	mc2d@mc_y = mcy

	scdb_add_mc2d(mc2d_id, mc2d)
}