#' Make regression table
#'
#' @description This function makes a character data frame of regression table.
#' An advantage point of this function is
#' that you can pass on output-format function such as `kable`.
#'
#' @param obj a list or object including regression analysis
#' @param keep_coef a character vector of variables kept
#' @param rm_coef a character vector of variables removed from table
#' @param label_coef a list including `ols variable name = new variable name`
#' @param add_line a list including additional contents of each column.
#' @param ... other augments which pass on each augment. See details.
#'
#' @return a data frame which includes all character strings
#'
#' @details the `binomial` method can show average marginal effect
#' if `ame = TRUE`, using `margins` in the `margins` package
#'
#' @importFrom purrr map
#' @importFrom purrr reduce
#' @importFrom stringr str_detect
#' @importFrom dplyr recode
#' @importFrom dplyr full_join
#' @importFrom dplyr bind_rows
#' @importFrom dplyr select
#' @importFrom dplyr mutate
#' @importFrom dplyr case_when
#' @importFrom tidyr pivot_longer
#' @importFrom tibble tribble
#' @importFrom tibble tibble
#' @importFrom tibble as_tibble
#' @importFrom magrittr %>%
#' @importFrom margins margins
#' @importFrom fixest r2
#' @importFrom stats logLik
#' @importFrom stats nobs
#' @importFrom stats setNames
#'
#' @export
#'
#+
regtab <- function(
  obj,
  keep_coef = NULL, rm_coef = NULL, label_coef = NULL,
  add_line = NULL,
  ...
) {

  # if not list, make list
  if (sum(class(obj) == "list") == 0) obj <- list(obj)

  # get and trim coeftab
  coeftab <- obj %>%
    map(function(x) ctab(x, ...)) %>%
    reduce(full_join, by = c("vars", "stat"))

  coeftab <- setNames(
    coeftab,
    c("vars", "stat", paste0("reg", seq_len(ncol(coeftab) - 2)))
  )

  # keep variables in coeftab
  if (!is.null(keep_coef)) {
    strings <- keep_coef %>% paste(collapse = "|")
    coeftab <- coeftab[str_detect(coeftab$vars, strings), ]
  }

  # drop variables from coeftab
  if (!is.null(rm_coef)) {
    strings <- rm_coef %>% paste(collapse = "|")
    coeftab <- coeftab[!str_detect(coeftab$vars, strings), ]
  }

  # rename variables
  if (!is.null(label_coef)) {
    coeftab <- coeftab %>%
      mutate(vars = recode(vars, !!!label_coef, .default = vars))
  }

  # make tabulation of regression stats
  stattab <- obj %>%
    map(~ stab(.)) %>%
    reduce(full_join, by = c("vars", "stat"))

  stattab <- setNames(
    stattab,
    c("vars", "stat", paste0("reg", seq_len(ncol(stattab) - 2)))
  )

  # make add line tab
  if (!is.null(add_line)) {
    addtab <- as_tibble(add_line) %>%
      mutate(stat = "add")

    tab <- bind_rows(coeftab, addtab) %>%
      bind_rows(stattab)
  } else {
    tab <- bind_rows(coeftab, stattab)
  }

  return(tab)

}

#' A fucntion of getting coefficient table
#'
#' @param x a list or object including regression analysis
#' @param ... other augments which pass on each augment.
#'
#+
ctab <- function(x, ...) {
  UseMethod("ctab")
}

ctab.fe_felm <- function(x) {
  x <- summary(x)$coefficients
  trim_ctab(x)
}

ctab.fe_fixest <- function(x) {
  x <- summary(x)$coeftable
  trim_ctab(x)
}

ctab.lpm <- function(x) {
  x <- x$test
  trim_ctab(x)
}

ctab.ols <- function(x) {
  x <- summary(x)$coefficients
  trim_ctab(x)
}

ctab.RCT <- function(x) {
  if (sum(class(x) == "lpm") > 0) {
    x <- lapply(x$test, trim_ctab)
  } else if (sum(class(x) == "ols") > 0) {
    x <- lapply(x$fit, function(x) summary(x)$coefficients)
    x <- lapply(x, trim_ctab)
  } else {
    stop("Unsupported class applied.")
  }
  x %>% reduce(full_join, by = c("vars", "stat"))
}

ctab.binomial <- function(x, ame = FALSE, ...) {
  if (ame) {
    x <- margins(x, data = x$model, ...)
    mat <- as.matrix(summary(x)[, 2:5])
    rownames(mat) <- summary(x)[, 1]
    trim_ctab(mat)
  } else {
    x <- summary(x)$coefficients
    trim_ctab(x)
  }
}

trim_ctab <- function(x) {

  tab <- tibble(
    vars = rownames(x),
    coef = x[, 1],
    se = x[, 2],
    p = x[, 4]
  )

  tab <- tab %>%
    mutate(
      coef = case_when(
        p <= .01 ~ sprintf("%1.3f***", coef),
        p <= .05 ~ sprintf("%1.3f**", coef),
        p <= .1 ~ sprintf("%1.3f*", coef),
        TRUE ~ sprintf("%1.3f", coef)
      ),
      se = sprintf("(%1.3f)", se)
    ) %>%
    select(-p) %>%
    pivot_longer(-vars, names_to = "stat", values_to = "val")

  return(tab)

}

#' A function of making regression stats table
#'
#' @param x a list or object including regression analysis
#+
stab <- function(x) {
  UseMethod("stab")
}

stab.fe_felm <- function(x) {
  tribble(
    ~vars, ~stat, ~val,
    "N", "stat", sprintf("%3d", nobs(x)),
    "R-squared", "stat", sprintf("%1.3f", summary(x)$r.squared)
  )
}

stab.fe_fixest <- function(x) {
  tribble(
    ~vars, ~stat, ~val,
    "N", "stat", sprintf("%3d", nobs(x)),
    "Adjusted R-squared", "stat", sprintf("%1.3f", r2(x)["ar2"])
  )
}

statlm <- function(x) {
  tribble(
    ~vars, ~stat, ~val,
    "N", "stat", sprintf("%3d", nobs(x)),
    "R-squared", "stat", sprintf("%1.3f", summary(x)$r.squared)
  )
}

stab.lpm <- function(x) {
  statlm(x$fit)
}

stab.ols <- function(x) {
  statlm(x)
}

stab.RCT <- function(x) {
  x <- lapply(x$fit, statlm)
  x %>% reduce(full_join, by = c("vars", "stat"))
}

stab.binomial <- function(x) {
  tribble(
    ~vars, ~stat, ~val,
    "N", "stat", sprintf("%3d", nobs(x)),
    "Log-likelihood", "stat", sprintf("%1.3f", logLik(x)[1])
  )
}


# f0basics.r: Catherine Lai
# Basic functions to do with processing F0.
require(geometry)
require(mFilter)
source("legendre.r")

sigmoid <- function(x) {
	return(1/(1 + exp(-x)))
}

refactor <- function(vrmi) {
        for (fx in names(vrmi)) {
                if (is.factor(vrmi[[fx]])) {
                        vrmi[[fx]] <- factor(unlevel(vrmi[[fx]]))
                }
        }
        return(vrmi)
}

bw.smooth <- function(x, xname="Time", yname="F0", freq=NA) {
        #points(x, col="magenta")
	if (is.na(freq)) {
		 freq <- bwcuttoff(x, nv=0.1, xname)
	}

        if (is.null(freq) | (nrow(x) < 4)){ p1 <- x }
        else {
		#print(tail(x))
                p1 <- data.frame(x[[xname]],
			fitted(bwfilter(x[[yname]],freq=freq)))
		names(p1) <- c(xname, yname)
                p1 <- bw.brute.ends(p1, xname, yname)

        }
        return(p1)
}

bw.brute.ends <- function(p1, xname="Time", yname="F0") {
        if(nrow(p1) == 0) {return(p1)}
        x <- head(tail(p1,min(5, nrow(p1))),4)
        xs <- x[[xname]]
        ys <- x[[yname]]
        pend <- predict(lm(ys ~ xs), data.frame(xs=tail(p1[[xname]],1)))
        p1[nrow(p1), yname] <- pend

        return(p1)
}

# calculate normalized cutoff for Butterworth filter.
bwcuttoff <- function(x, xname="Time", nv=0.1) {
	if (nrow(x) > 1) {
		return((1/min(diff(x[[xname]]))/2) * nv)
	} else {
		return(NULL)
	}
}

from.semitone <- function(F0.st, F0.ref=min(F0.hz)) {
        F0.ref * (2^(F0.st/12))
}

to.semitone <- function(x, F0.ref=100) {
	if (length(names(x))==0) {
		F0.hz <- x
		y <- 12* log2(F0.hz/F0.ref)
	} else {
		F0.hz <- x$F0
        	y <- data.frame(Time=x$Time, F0=12* log2(F0.hz/F0.ref))
	}
	y
}

to.zscore <- function(x, x.mean=mean(x,na.rm=T), x.sd=sd(x,na.rm=T)) {
        (x - x.mean)/x.sd
}

unfactor <- function(x) {
        as.numeric(levels(x)[x])
}

unlevel <- function(x) {
        levels(x)[x]
}

remove.outliers <- function(x)  {
        y <- to.semitone(x$F0)
        i.new <- (y < mean(y, na.rm=T) + 3*sd(y, na.rm=T)) &  (y > mean(y, na.rm=T) - 3*sd(y, na.rm=T))
        data.frame(Time=x$Time[i.new], F0=x$F0[i.new])
}

#############################################################################################
irange <- function(x){
	if(nrow(x) > 0) { max(x$I0)-min(x$I0) }
	else {NA}
}

mean.i0 <- function(x) {
	if(nrow(x) > 0) { mean(x$I0, na.rm=T) }
	else {NA}
}

sd.i0 <- function(x) {
	if(nrow(x) > 0) { sd(x$I0, na.rm=T) }
	else {NA}
}

median.i0 <- function(x) {
	if(nrow(x) > 0) { median(x$I0, na.rm=T) }
	else {NA}
}
min.i0 <- function(x) {
	if(nrow(x) > 0) { min(x$I0, na.rm=T) }
	else {NA}
}

max.i0 <- function(x) {
	if(nrow(x) > 0) { max(x$I0, na.rm=T) }
	else {NA}
}

slope.i0 <- function(x0) {
	x <- x0[!is.na(x0$I0),]
	if(nrow(x) > 1) {
		y <- lm(x$I0 ~ x$Time)$coefficients[2]
		names(y) <- NULL
		return(y)
	} else {return(NA)}
}

intercept.i0 <- function(x0) {
	x <- x0[!is.na(x0$I0),]
	if(nrow(x) > 1) {
		y <- lm(x$I0 ~ x$Time)$coefficients[1]
		names(y) <- NULL
		return(y)
	} else {return(NA)}
}

jitter.i0 <- function(x) {
	if(nrow(x) > 0) {
		y <- x$I0
        	(sum(abs(diff(y)),na.rm=T)/(length(y)-1))/(sum(abs(y))/length(y))
	} else {NA}
}

npoints.i0 <- function(x) {
	length(x$I0[!is.na(x$I0)])
}

##################################################################################
prange.value <- function(x0, xname="Time", yname="Value"){
	x <- x0[!is.na(x0[[yname]]),]
	if(nrow(x) > 0) { max(x[[yname]],na.rm=T)-min(x[[yname]],na.rm=T) }
	else {NA}
}

mean.value <- function(x0, xname="Time",yname="Value") {
	x <- x0[!is.na(x0[[yname]]),]
	if(nrow(x) > 0) { mean(x[[yname]], na.rm=T) }
	else {NA}
}

sd.value <- function(x0, xname="Time", yname="Value") {
	x <- x0[!is.na(x0[[yname]]),]
	if(nrow(x) > 0) { sd(x[[yname]], na.rm=T) }
	else {NA}
}

median.value <- function(x0, xname="Time",yname="Value") {
	x <- x0[!is.na(x0[[yname]]),]
	if(nrow(x) > 0) { median(x[[yname]], na.rm=T) }
	else {NA}
}
min.value <- function(x0, xname="Time",yname="Value") {
	x <- x0[!is.na(x0[[yname]]),]
	if(nrow(x) > 0) { min(x[[yname]], na.rm=T) }
	else {NA}
}

max.value <- function(x0, xname="Time", yname="Value") {
	x <- x0[!is.na(x0[[yname]]),]
	if(nrow(x) > 0) { max(x[[yname]], na.rm=T) }
	else {NA}
}

slope.value <- function(x0, xname="ActualTime", yname="Value", sampletime=F) {
	#print(c(xname, yname))
	#print(x0)
	x <- x0[!is.na(x0[[yname]]),]
	zy <- x[[yname]]
	zx <- x[[xname]]

	if(nrow(x) > 1) {
		if (sampletime) {
			y <- lm(Value ~ SampleTime, data=x)$coefficients[2]
		}  else {
			y <- lm(zy ~ zx)$coefficients[2]
		}
		names(y) <- NULL
		return(y)
	} else {return(NA)}
}

intercept.value <- function(x0, xname="ActualTime", yname="Value", sampletime=F) {
	x <- x0[!is.na(x0[[yname]]),]
	zy <- x[[yname]]
	zx <- x[[xname]]

	if(nrow(x) > 1) {
		if (sampletime) {
			y <- lm(Value ~ SampleTime, data=x)$coefficients[1]
		} else {
			y <- lm(zy ~ zx)$coefficients[1]
		}
		names(y) <- NULL
		return(y)
	} else {return(NA)}
}

jitter.value <- function(x0, xname="Time", yname="Value") {
	x <- x0[!is.na(x0[[yname]]),]
	if(nrow(x) > 0) {
		y <- x[[yname]]
        	(sum(abs(diff(y)),na.rm=T)/(length(y)-1))/(sum(abs(y),na.rm=T)/length(y))
	} else {NA}
}

npoints.value <- function(x, xname="Time", yname="Value") {
	length(x[[yname]][!is.na(x[[yname]])])
}

get.legendre.coeffs <- function(x, degree=5) {
	lp <- legendre.polynomials(degree, normalize=T)
	p <- legendre.coeff(x$ActualTime,x$Value,lp)
	p
}

#############################################################################################
prange <- function(x){
	if(nrow(x) > 0) { max(x$F0)-min(x$F0) }
	else {NA}
}

mean.f0 <- function(x) {
	if(nrow(x) > 0) { mean(x$F0, na.rm=T) }
	else {NA}
}

sd.f0 <- function(x) {
	if(nrow(x) > 0) { sd(x$F0, na.rm=T) }
	else {NA}
}

median.f0 <- function(x) {
	if(nrow(x) > 0) { median(x$F0, na.rm=T) }
	else {NA}
}
min.f0 <- function(x) {
	if(nrow(x) > 0) { min(x$F0, na.rm=T) }
	else {NA}
}

max.f0 <- function(x) {
	if(nrow(x) > 0) { max(x$F0, na.rm=T) }
	else {NA}
}

slope.f0 <- function(x0) {
	x <- x0[!is.na(x0$F0),]
	if(nrow(x) > 1) {
		y <- lm(x$F0 ~ x$Time)$coefficients[2]
		names(y) <- NULL
		return(y)
	} else {return(NA)}
}

intercept.f0 <- function(x0) {
	x <- x0[!is.na(x0$F0),]
	if(nrow(x) > 1) {
		y <- lm(x$F0 ~ x$Time)$coefficients[1]
		names(y) <- NULL
		return(y)
	} else {return(NA)}
}

jitter.f0 <- function(x) {
	if(nrow(x) > 0) {
		y <- x$F0
        	(sum(abs(diff(y)))/(length(y)-1))/(sum(abs(y))/length(y))
	} else {NA}
}

npoints.f0 <- function(x) {
	length(x$F0[!is.na(x$F0)])
}

get.legendre.coeffs.f0 <- function(x, degree=5) {
	lp <- legendre.polynomials(degree, normalize=T)
	p <- legendre.coeff(x$Time,x$F0,lp)
	p
}

pred.point2 <- function(y1, y2, x) {
	a <- y1[2] - ((y2[2]-y1[2])/(y2[1]-y1[1])) * y1[1]
	m = ((y2[2]-y1[2])/(y2[1]-y1[1]))
	m*x + a
}

sort.hull <- function(y) {
	ynew <- NULL
	for (i in 1:nrow(y)) {
		ynew <- rbind(ynew, sort(y[i,]))
	}
	ynew
}

get.max <- function(x, y) {
	vs <- unique(c(y[,1], y[,2]))
	vs[which.max(x[vs,]$F0)]
}

get.prevs <- function(x, y, v) {
	curr <- y[y[,2] == v,]
	if (length(curr) == 2) {
		return(c(v, get.prevs(x, y, curr[1])))
	} else if (length(curr) > 2) {
		cx <- find.highv(x,curr,forward=F)
		return(c(v, get.prevs(x, y, cx[1])))
	} else {
		return(v)
	}
}

# Find the highest vertex in the convex hull top.
find.highv <- function(x, curr, forward=T) {
	preds <- NULL
	if (forward) {
		v1 <- unique(curr[,1])
		for (i in 1:nrow(curr)) {
			preds <- c(preds,
				pred.point2(x[curr[i,1],], x[curr[i,2],], x[v1+1,1]))
		}
	} else {
		v1 <- unique(curr[,2])
		for (i in 1:nrow(curr)) {
			preds <- c(preds,
				pred.point2(x[curr[i,1],], x[curr[i,2],], x[v1-1,1]))
		}
	}
	#print(which.max(preds))
	#print(curr[which.max(preds),])
	curr[which.max(preds),]
}

get.nxts <- function(x, y, v) {
	curr <- y[y[,1] == v,]
	if (length(curr) == 2) {
		return(c(v, get.nxts(x, y, curr[2])))
	} else if (length(curr) > 2) {
		cx <- find.highv(x,curr,forward=T)
		return(c(v, get.nxts(x, y, cx[2])))
	} else {
		return(v)
	}
}

# get.hulltop: get the part of the convex hull above the contour.
get.hulltop <- function(x, y0, vmax) {
	#print("hulltop")
	y <- sort.hull(y0)
	prev <- get.prevs(x, y, vmax)
 	nxt <- get.nxts(x, y,vmax)
	top <- unique(sort(c(prev,nxt)))
	return(list(prev=prev, nxt=nxt, top=top))
}

# get.nxtdiff: find the point with maximum difference from
# the hull top that exceeds the threshold.
get.nxtdiff <- function(x, y, nxt, diffthresh=1) {
	maxdiff <- 0
	idiff <- NA
	for (i in 1:(length(nxt)-1)) {
		vs <- c(nxt[i], nxt[i+1])
		#points(x[vs,], col="blue", pch=15)

		preds <- NULL
		curr <- vs[1]:vs[2]
		for (j in curr)  {
			preds <- c(preds,pred.point2(x[vs[1],], x[vs[2],], x[j,1]))
		}
		preds <- unlist(preds)
		#points(x[curr,1], preds, col="red", pch=13)
		diffs <- preds - x[curr,2]
		md <- which.max(diffs)
		#print(diffs[md])
		#points(x[curr[md],], col="green", pch=15)
		if (diffs[md] > diffthresh & diffs[md] > maxdiff) {
			idiff <- curr[md]
			maxdiff <- diffs[md]
		}
	}
	return(idiff)
}

# get.maxdiffs: Recursively apply Mermelstein algorithm to
# time series (x0) to find inflection points.
# (This function is unfortunately named! It should get a wrapper!)

get.maxdiffs <- function(x0, vs=1:nrow(x0), diffthresh=2) {
	if (length(vs) == 0) {return(NULL)}

	if (length(vs) < 3 ) {
		return(c(which.max(px[[1]]$F0), 1, nrow(px[[1]])))
	}

	x <- x0[vs,]

	y <- convhulln(as.matrix(x))
	y <- sort.hull(y)
	vmax <- get.max(x,y)
	#points(x0[vs[vmax],], col="red", pch=15)
	print(vs[vmax])
	htop <- get.hulltop(x,y,vmax)
	itop <- get.nxtdiff(x,y,htop$top,diffthresh)
	if (!is.na(itop)) {
		#abline(v=x[itop,], col="green")
		prev <- head(vs,1):vs[itop]
		nxt <- vs[itop]:tail(vs,1)
		return(rbind(c(vs[vmax], head(vs,1), tail(vs,1)),
			get.maxdiffs(x0, prev, diffthresh),
			get.maxdiffs(x0, nxt, diffthresh)))
	} else {
		return(c(vs[vmax], head(vs,1), tail(vs,1)))
	}
}

chunk.by.pause <- function (x, plen=0.1) {
        chunks <- list()
        lx <- 1
        pauses <- get.pause.indices(x, plen)

                if (length(pauses) > 0) {
                for (i in 1:length(pauses)) {
                        p <- pauses[i]
                        curr <- list()
                        curr$Time <- x$Time[lx:p]
                        curr$F0 <- x$F0[lx:p]

                        chunks[[i]] <- curr
                        lx <- p+1
                }
        }
        curr <- list()
        curr$Time <- x$Time[lx:length(x$Time)]
        curr$F0 <- x$F0[lx:length(x$Time)]
        chunks[[length(chunks)+1]] <- curr
        chunks
}

get.pause.indices <- function(x, plen=0.1) {
        tdiff <- diff(x$Time,1)
        which(tdiff > plen)
}

apply.by.pause <- function(x, f, plen=0.1) {
        xs <- chunk.by.pause(x, plen)
        ys  <- lapply(xs, f)

        x.new <- list(Time=NULL, F0=NULL)
        for (y in ys) {
                x.new$Time <- c(x.new$Time, y$Time)
                x.new$F0 <- c(x.new$F0, y$F0)
        }

        x.new

}

unlist.df <- function(x) {
	y <- NULL
	if (length(x) > 0) {
		for (i in 1:length(x)) {
			y <- rbind(y, x[[i]])
		}
	}
	y
}

unlist.vec <- function(x) {
	y <- NULL
	for (i in 1:length(x)) {
		y <- c(y, x[[i]])
	}
	y
}

get.pquantiles <- function(pitchtiers, probs=c(0,0.05,0.25,0.5,0.75,0.95,1)) {
	pquantile <- sapply(pitchtiers, function(x) {quantile(x$F0, probs=probs)})
	pquantile <- t(pquantile)
	data.frame(rownames(pquantile), pquantile, row.names=NULL)
}


# wahpenayo at gmail dot com
# 2018-01-25
#-----------------------------------------------------------------
if (file.exists('e:/porta/projects/taigabench')) {
  setwd('e:/porta/projects/taigabench')
} else {
  setwd('c:/porta/projects/taigabench')
}
source('src/scripts/r/functions.r')
readr.show_progress <- FALSE
#-----------------------------------------------------------------
dataset <- 'ontime'
suffixes <- c('32768','131072')#,'524288','2097152','8388608','33554432')
for (na.action in c('na.omit','na.impute')) {
  prefix <- paste0('randomForestSRC',substring(na.action,first=4))
#-----------------------------------------------------------------
#  response <- 'arr_delayed_15min'
#  dataf <- ontime.classify.data
#  dtest <- dataf(test.file(dataset=dataset))
#  problem <- 'classify'
#  bench(
#    dataset=dataset,problem=problem,dataf=dataf,dtest=dtest,
#    response=response,
#    suffixes=suffixes,
#    trainf=classify.randomForestSRC,
#    prefix=prefix,
#    na.action=na.action)
#-----------------------------------------------------------------
  response <- 'arrdelay'
  dataf <- ontime.data
  dtest <- dataf(test.file(dataset=dataset))
  problem <- 'l2'
  bench(
    dataset=dataset,
    problem=problem,
    dataf=dataf,
    dtest=dtest,
    response=response,
    suffixes=suffixes,
    trainf=l2.randomForestSRC,
    prefix=prefix,
    na.action=na.action)
#-----------------------------------------------------------------
#  problem <- 'qcost'
#  bench(
#    dataset=dataset,problem=problem,dataf=dataf,dtest=dtest,
#    response=response,
#    suffixes=suffixes,
#    trainf=qcost.randomForestSRC,
#    prefix=prefix,
#    na.action=na.action)
#-----------------------------------------------------------------
}


library( "rmacrolite" )

#   Path to an example par-file
par_file_path <- system.file( "par-files",
    "chat_winCer_GW-X_900gHa_d182.par",
    package = "rmacrolite" )

#   Import the example par-file
par_file <- rmacroliteImportParFile(
    file = par_file_path )

#   Current value of ZKD (Freundlich sorption)
as.numeric( rmacroliteGet1Param(
     x    = par_file,
     pTag = "ZKD\t%s\t%s",
     type = "SOLUTE PARAMETERS" ) )

#   Organic matter content profile
oc <- as.numeric( rmacroliteGet1Param(
     x    = par_file,
     pTag = "ORGC\t%s\t%s",
     type = "PROPERTIES" ) )

oc_factors <- oc / oc[ 1L ]

#   Change ZKD
par_file <- rmacroliteChangeParam(
    x = par_file,
    p = data.frame(
        "tag"    = sprintf( "ZKD\t%s\t%s", 1L:6L, "%s" ),
        "values" = 1 * oc_factors, # 1 is Kf for topsoil
        "type"   = rep( "SOLUTE PARAMETERS", 6L ),
        "set_id" = rep( 1L, 6L ),
        stringsAsFactors = FALSE ) )[[ 1L ]]

#   Check new value
new_zkd <- as.numeric( rmacroliteGet1Param(
     x    = par_file,
     pTag = "ZKD\t%s\t%s",
     type = "SOLUTE PARAMETERS" ) )

new_zkd

#   Parameter variations for several parameter sets
p <- data.frame(
    "tag"    = c( "ALPHA\t1\t%s", "ALPHA\t2\t%s",
        "ZKD\t1\t%s", "ZKD\t2\t%s" ),
    "type"   = c( "PHYSICAL PARAMETERS", "PHYSICAL PARAMETERS",
        "SOLUTE PARAMETERS", "SOLUTE PARAMETERS" ),
    "values" = c( 0.02, 0.02, 2, 2 ),
    "set_id" = c( 1, 1, 2, 2 ),
    stringsAsFactors = FALSE )

par_file_list <- rmacroliteChangeParam( x = par_file, p = p )

class( par_file_list ) # Should be a list
length( par_file_list ) # Should be 2

# # Not run
# rmacroliteRun( x = par_file_list )

#   Internal checks
if( !all( abs( (1 * oc_factors) - new_zkd ) < 1e-15 ) ){
    stop( "Test of rmacroliteChangeParam() failed" )
}

#   Clean-up
rm( par_file_path, par_file, oc, oc_factors, new_zkd, p,
    par_file_list )


#' Fit a model via local, adaptive grouped regularization
#'
#' \code{lagr} fits a LAGR model This method fits a local model at each location indicated by \code{fit.loc}.
#'
#' @param formula symbolic representation of the model
#' @param data data frame containing observations of all the terms represented in the formula
#' @param weights vector of prior observation weights (due to, e.g., overdispersion). Not related to the kernel weights.
#' @param family exponential family distribution of the response
#' @param coords matrix of locations, with each row giving the location at which the corresponding row of data was observed
#' @param fit.loc matrix of locations where the local models should be fitted
#' @param longlat \code{TRUE} indicates that the coordinates are specified in longitude/latitude, \code{FALSE} indicates Cartesian coordinates. Default is \code{FALSE}.
#' @param kernel kernel function for generating the local observation weights
#' @param bw bandwidth parameter
#' @param bw.type type of bandwidth - options are \code{dist} for distance (the default), \code{knn} for nearest neighbors (bandwidth a proportion of \code{n}), and \code{nen} for nearest effective neighbors (bandwidth a proportion of the sum of squared residuals from a global model)
#' @param tol.loc tolerance for the tuning of an adaptive bandwidth (e.g. \code{knn} or \code{nen})
#' @param varselect.method criterion to minimize in the regularization step of fitting local models - options are \code{AIC}, \code{AICc}, \code{BIC}, \code{GCV}
#' @param tuning logical indicating whether this model will be used to tune the bandwidth, in which case only the tuning criteria are returned
#' @param D pre-specified matrix of distances between locations
#' @param verbose print detailed information about our progress?
#'
#' @return list containing the local models.
#'
#' @export
lagr <- function(formula, data, family=gaussian(), weights=NULL, coords, fit.loc=NULL, tuning=FALSE, predict=FALSE, simulation=FALSE, oracle=NULL, kernel=NULL, bw=NULL, varselect.method=c('AIC','BIC','AICc', 'wAIC', 'wAICc'), verbose=FALSE, longlat=FALSE, tol.loc=NULL, bw.type=c('dist','knn','nen'), D=NULL, lambda.min.ratio=0.001, n.lambda=50, lagr.convergence.tol=0.001, lagr.max.iter=20, jacknife=FALSE, bootstrap.index=NULL, na.action=na.fail, contrasts=NULL) {
    result = list()
    class(result) = "lagr"

    if (is(bw, 'lagr.bw')) {
        bw.type = bw$bw.type
        kernel = bw$kernel
        bw = bw$bw
    } else {
        bw.type = match.arg(bw.type)
    }

    if (is.null(kernel))
        stop("Error: There is no kernel specified!")

    cl <- match.call()
    formula = eval.parent(substitute_q(formula, sys.frame(sys.parent())))
    mf = eval(lagr.parse.model.frame(formula, data, family, weights, coords, fit.loc, longlat, na.action, contrasts))

    y = mf$y
    x = mf$x
    w = mf$w
    mt = mf$mt
    coords = mf$coords
    dist = mf$dist
    max.dist = mf$max.dist
    min.dist = mf$min.dist
    family = mf$family

    #Set some variables that determine how we fit the model
    varselect.method = match.arg(varselect.method)

    #Fit the model:
    vcr.model = lagr.dispatch(
        x=x,
        y=y,
        family=family,
        prior.weights=w,
        tuning=tuning,
        predict=predict,
        simulation=simulation,
        coords=coords,
        oracle=oracle,
        fit.loc=fit.loc,
        D=dist,
        varselect.method=varselect.method,
        verbose=verbose,
        bw=bw,
        bw.type=bw.type,
        kernel=kernel,
        min.dist=min.dist,
        max.dist=max.dist,
        tol.loc=tol.loc,
        lambda.min.ratio=lambda.min.ratio,
        n.lambda=n.lambda,
        lagr.convergence.tol=lagr.convergence.tol,
        lagr.max.iter=lagr.max.iter,
        jacknife = jacknife,
        bootstrap.index=bootstrap.index
    )

    for (nn in names(vcr.model))
        result[[nn]] = vcr.model[[nn]]

    coefs = as.data.frame(t(sapply(result[['fits']], function(x) x[['coef']])))
    is.zero = as.data.frame(t(sapply(result[['fits']], function(x) x[['conf.zero']])))
    varnames = names(result[['fits']][[1]]$coef)
    colnames(coefs) = varnames
    colnames(is.zero) = varnames

    #Store results from model fitting:
    if (!tuning) {
        result[['data']] = data
        result[['response']] = as.character(formula[[2]])
        result[['family']] = family
        result[['weights']] = w
        result[['coords']] = coords
        result[['fit.locs']] = fit.loc
        result[['longlat']] = longlat
        result[['kernel']] = kernel
        result[['bw']] = bw
        result[['bw.type']] = bw.type
        result[['varselect.method']] = varselect.method
        result[['dim']] = mf$dim
        result[['coefs']] = coefs
        result[['is.zero']] = is.zero

        result[['na.action']] <- attr(mf, "na.action")
        result[['contrasts']] <- attr(x, "contrasts")
        result[['xlevels']] <- .getXlevels(mt, mf)
        result[['call']] <- cl
        result[['terms']] <- mt
    }

    return(result)
}


#install.packages("bio3d")
#downloading the file with protein ids  in the Home folder
#f=download.file("ftp://ftp.wwpdb.org/pub/pdb/derived_data/index/compound.idx",destfile="idx_file.idx");

#-------------------------------import libraries---------------------------

library("bio3d");

#------------------read from idx file with ids and move data into matrix-----------------------
fileName <- 'idx_file.idx'
fff= readChar(fileName, file.info(fileName)$size);
fff=strsplit(fff, "\n");
l=length(fff[[1]]);
ccc=fff[[1]][5:l];
remove(l);
fff=ccc;
remove(ccc);
fff=strsplit(fff, "\t");
output <- matrix(unlist(fff), ncol = 2, byrow = TRUE);
remove(fff);
remove(fileName);
#remove(f);

#============================ask from user the Query========1N21========5L5V=====2QPS====1U98====1U99=====5NQ3

#Q=readline(prompt = "Give the pdb_id of the query \n");

#-----------------------download from database or load if there is already downloaded----------------
query_id = Q;
Q=read.pdb(Q, maxlines = -1, multi = FALSE, rm.insert = FALSE,rm.alt = TRUE, ATOM.only = FALSE, hex = FALSE, verbose = TRUE);

#***********************************start of algorithm**************************

#=======================computation of Query=======================================
#--------------------we need only Calpha coordinates-----------------------------------------

t = length((which(Q$calpha==TRUE))*3);
cord = rep(NaN,t);
counter=1;

for (i in 1:length(Q$calpha)) {
if(Q$calpha[i]==TRUE){
  cord[counter]   = Q$xyz[[(i-1)*3+1]];
  cord[counter+1] = Q$xyz[[(i-1)*3+2]];
  cord[counter+2] = Q$xyz[[(i-1)*3+3]];
counter=counter+3;
}
}

coordinates_Q = c(xyz=c("xyz"),size=0,name=query_id);
coordinates_Q$xyz = cord;
coordinates_Q$size = length((which(Q$calpha==TRUE)))*3;

#-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-finding centroids G_right, G_left-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

half_v = length(coordinates_Q$xyz)-(length(coordinates_Q$xyz))%%2;
half_v = (half_v - half_v%%3)/2;
t_square_left =  sqrt((half_v/3)/(coordinates_Q$size/3));
t_square_right=  sqrt(((coordinates_Q$size/3)-half_v/3)/(coordinates_Q$size/3));

sumx = 0;
sumy = 0;
sumz = 0;
i=1;
while(i<half_v) {
sumx = sumx + coordinates_Q$xyz[i];
sumy = sumy + coordinates_Q$xyz[i+1];
sumz = sumz + coordinates_Q$xyz[i+2];
i=i+3;
}
G_right_Q = c(sumx,sumy,sumz) /half_v;

sumx = 0;
sumy = 0;
sumz = 0;
i=half_v+1;
while(i<length(coordinates_Q$xyz)) {
sumx = sumx + coordinates_Q$xyz[i];
sumy = sumy + coordinates_Q$xyz[i+1];
sumz = sumz + coordinates_Q$xyz[i+2];
i=i+3;
}
G_left_Q = c(sumx,sumy,sumz) /(length(coordinates_Q$xyz)-half_v);

#-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-finding centroids G_right, G_left-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

#=============================read ids from matrix, download pdb files==========

#==============iteration over packets===============================

counter_iter=1;
counter1=1;
packet=100;
total_time=0;
iter=length(output)-(length(output)%%packet);
number_of_proteins =0;
number_of_substructures=0;
rmsd_var = list(value=-1,name="NaN",start=-1);
while(counter1<=(iter+1)){

ids = unlist(output[((counter1-1)*100+1):(counter1*packet),1], recursive = TRUE, use.names = TRUE);
ids = as.character(ids);

#-------------create a list of pdb files----------------------------
pdb_list=NULL;
coordinates_P=NULL;
pdb_length <- rep(0,length(ids));
pdb_file=1;

coordinates_P = c(xyz=c("NaN"),size=0);
cord = rep(NaN,1);
#cord = c(xyz=NaN,calpha=-1);
coordinates_P$xyz = cord;
coordinates_P$name = "NaN";

#--------------store coordinates of Calpha and length of each molecule---------------
for (i in 1:(length(ids))) {
	pdb_file=try(read.pdb(ids[i],maxlines=-1,multi=FALSE,rm.insert=FALSE,rm.alt=TRUE,ATOM.only=FALSE,hex=FALSE,verbose=TRUE));

	if(typeof(pdb_file)!="character"){
		Calpha = which(pdb_file$calpha==TRUE);
		t = length((which(pdb_file$calpha==TRUE)))*3;
		cord = rep(NaN,1);
		counter=1;
		tr=length(which(Q$calpha==TRUE))*3;
		#------------if there is Calpha or protein is greater than the query--------------
		if( t >=tr){
			for (j in 1:(length(pdb_file$calpha))) {
				if(pdb_file$calpha[j]==TRUE){
					cord[counter]   = pdb_file$xyz[[(j-1)*3+1]];
					cord[counter+1] = pdb_file$xyz[[(j-1)*3+2]];
					cord[counter+2] = pdb_file$xyz[[(j-1)*3+3]];
					counter=counter+3;
				}
			}
				coordinates_P$xyz = c(coordinates_P$xyz,cord);
				coordinates_P$size = c(coordinates_P$size,length(cord));
				coordinates_P$name = c(coordinates_P$name,ids[i])
		}else{
		#-remove from list------
		ids = ids[(which(ids!=ids[i]))];
		}
	}else{
	#----------------if pdb doesn't exist remove from list----------------------
	print(ids[i]); print("doesn't exist or cannot be read properly due to C++ error remove from list");
	  #ids = ids[(which(ids!=ids[i]))];
	}
}#--------------------end of for--------------

coordinates_P$size = coordinates_P$size[which(coordinates_P$size!="NaN")];
coordinates_P$xyz = coordinates_P$xyz[which(coordinates_P$xyz!="NaN")];
coordinates_P$name = coordinates_P$name[which(coordinates_P$name!="NaN")];

#---------------remove false data------------------------------
if(length((which(coordinates_P$size!=0)))){
ids = ids[(which(coordinates_P$size!=0))];
coordinates_P$size = coordinates_P$size[(which(coordinates_P$size!=0))];

}

coordinates_P$size = strtoi(coordinates_P$size);

b = -1;

hits=0;
D_values = -1;
#=======================calculating from 100 substructures of P=======================================
number_of_proteins = number_of_proteins+length(coordinates_P$size);
number_of_substructures = number_of_substructures + sum(coordinates_P$size)/3-sum(coordinates_Q$size)/3+length(coordinates_P$size);
start_time <- Sys.time();
counter3=1;
counter4=0;
for (i in 1:(length(coordinates_P$size))) {
	start=TRUE;
	j=1;
	while(j<=(coordinates_P$size[i]-(length(coordinates_Q$xyz))+1)) {

	if(start==TRUE){

		#finding centroids G_right, G_left

		half_v = length(coordinates_Q$xyz)-(length(coordinates_Q$xyz))%%2;
		half_v = (half_v - half_v%%3)/2;

		sumx = 0;
		sumy = 0;
		sumz = 0;
		e=1;
		while(e<=half_v) {
			sumx = sumx + coordinates_P$xyz[e+(counter4+j)-1];
			sumy = sumy + coordinates_P$xyz[e+(counter4+j)+1-1];
			sumz = sumz + coordinates_P$xyz[e+(counter4+j)+2-1];
			e=e+3;
		}
		G_right_P = c(sumx,sumy,sumz) /half_v;

		sumx = 0;
		sumy = 0;
		sumz = 0;
		e=half_v+1;
		while(e<=length(coordinates_Q$xyz)) {
			sumx = sumx + coordinates_P$xyz[e+(counter4+j)-1];
			sumy = sumy + coordinates_P$xyz[e+(counter4+j)+1-1];
			sumz = sumz + coordinates_P$xyz[e+(counter4+j)+2-1];
			e=e+3;
		}
		G_left_P = c(sumx,sumy,sumz) /(length(coordinates_Q$xyz)-half_v);

		start=FALSE;
	}else{
		#finding centroids G_right, G_left

		tt= length(coordinates_Q$xyz) - (length(coordinates_Q$xyz))%%2;
		tt = tt/2;
		G_left_P = G_left_P - (1/tt)*( c(coordinates_P$xyz[(counter4+j)],coordinates_P$xyz[(counter4+j)+1],coordinates_P$xyz[(counter4+j)+2])  );
		G_right_P = G_right_P - (1/tt)*(c(coordinates_P$xyz[tt+(counter4+j)],coordinates_P$xyz[tt+(counter4+j)+1],coordinates_P$xyz[tt+(counter4+j)+2]));
	}

#----------------------compute F for even or odd n---------------------------------

	  if((length(coordinates_Q$xyz)/3)%%2==0 ){

	    F_left =  t_square_left*sqrt((G_left_P[1]-G_left_Q[1])^2+ (G_left_Q[2]-G_left_P[2])^2+(G_left_Q[3]-G_left_P[3])^2 )/1;
	  }else{
	    F_left = t_square_left*(sqrt(   (((coordinates_Q$size/3)/2)-1)/((coordinates_Q$size/3)/2)  ))*(sqrt((G_left_P[1]-G_left_Q[1])^2+ (G_left_Q[2]-G_left_P[2])^2+(G_left_Q[3]-G_left_P[3])^2 )/1);
	  }

	  if((length(Q$xyz)/3)%%2==0 ){
		F_right = t_square_right*sqrt((G_right_Q[1]-G_right_P[1])^2+ (G_right_Q[2]-G_right_P[2])^2+(G_right_Q[3]-G_right_P[3])^2 )/2;
	}else{
		F_right = t_square_right*(sqrt(   ((((coordinates_Q$size/3))/2)-1)/((coordinates_Q$size/3)/2)  ))*(sqrt((G_right_Q[1]-G_right_P[1])^2+ (G_right_Q[2]-G_right_P[2])^2+(G_right_Q[3]-G_right_P[3])^2 )/2);
	}

#----------------------compute D---------------------------
	D_left = abs(F_left) ;
	D_right = abs(F_right);
	D = (D_left^2 + D_right^2)^0.5
	if(D<1){
	  hits = hits+1;
	  r =rmsd(coordinates_Q$xyz,coordinates_P$xyz[(counter4+j):(length(coordinates_Q$xyz)+(counter4+j) -1)]);
	  if(r<1){

	#rmsd_var = c(rmsd_var$value,r);
	rmsd_var$value = c(rmsd_var$value,r);
	rmsd_var$name = c(rmsd_var$name,coordinates_P$name[i]);
	rmsd_var$start = c(rmsd_var$start,j);

	}
	}

	counter_iter = counter_iter +1;
	counter3=counter3+1;
	j=j+3;

}#end of whilej

	counter4=counter4+coordinates_P$size[i];

}#end of fori

end_time <- Sys.time();
time_is=end_time-start_time;
total_time = total_time+time_is;

if(iter!=counter1){
  counter1 = counter1 +1;
}else{
  packet = length(output)%%packet;
}

}#-----------end of while iter----------

#------------after algorithm processing-----------------

#-----remove initialized values NaN-------------
rmsd_var[[1]] = rmsd_var[[1]][2:length(rmsd_var[[1]])];
rmsd_var[[2]] = rmsd_var[[2]][2:length(rmsd_var[[2]])];
rmsd_var[[3]] = rmsd_var[[3]][2:length(rmsd_var[[3]])];

b=b[2:length(b)];

#--------------------use plot3D---library---------------
library("plot3D");

pdf('results_2.pdf')
i=1;
x = rep(NaN,(coordinates_Q$size/3));
y = rep(NaN,(coordinates_Q$size/3));
z = rep(NaN,(coordinates_Q$size/3));
while(i<coordinates_Q$size) {
  x[((i-1))/3+1]=coordinates_Q$xyz[i];
  y[((i-1))/3+1]=coordinates_Q$xyz[i+1];
  z[((i-1))/3+1]=coordinates_Q$xyz[i+2];
i=i+3;
}

scatter3D(x,y,z,type="l",main=coordinates_Q$name,pch=20)
points3D(x,y,z,type="b",main=coordinates_Q$name, pch=20)
points3D(x,y,z,type="p",main=coordinates_Q$name,pch=19)
points3D(x,y,z,type="l",main=coordinates_Q$name,pch=20)

scatter3D(x,y,z,type="b",main="0 degrees",theta = 0,pch=20)
scatter3D(x,y,z,type="b",main="60 degrees",theta = 60,pch=20)
scatter3D(x,y,z,type="b",main="180 degrees",theta = 120,pch=20)
scatter3D(x,y,z,type="b",main="180 degrees",theta = 180,pch=20)
scatter3D(x,y,z,type="b",main="240 degrees",theta = 240,pch=20)
scatter3D(x,y,z,type="b",main="300 degrees",theta = 300,pch=20)

scatter3D(x,y,z,type="l",main="0 degrees",theta = 0,pch=20)
scatter3D(x,y,z,type="l",main="60 degrees",theta = 60,pch=20)
scatter3D(x,y,z,type="l",main="180 degrees",theta = 120,pch=20)
scatter3D(x,y,z,type="l",main="180 degrees",theta = 180,pch=20)
scatter3D(x,y,z,type="l",main="240 degrees",theta = 240,pch=20)
scatter3D(x,y,z,type="l",main="300 degrees",theta = 300,pch=20)

i=1;
links=NULL;
while(i<=length(rmsd_var$name)) {

links=c(links,paste("https://files.rcsb.org/download/",rmsd_var$name[i],sep=""));
i=i+1;
}
barplot(rmsd_var$value,names.arg =rmsd_var$name,col="dark blue",ylab = "rmsd",y=c(0,max(rmsd_var$value)+1))
barplot(rmsd_var$value,names.arg =links,col="dark blue",ylab = "rmsd",y=c(0,max(rmsd_var$value)+1))
dev.off();

#-------------------end-------------------------


#' Iterator that returns the elements of an object along with their indices
#'
#' Constructs an iterator that returns the elements of an object along with each
#' element's indices. Enumeration is useful when looping through an
#' \code{object} and a counter is required.
#'
#' This function is intended to follow the convention used in Python's
#' \code{enumerate} function where the primary difference is that a list is
#' returned instead of Python's \code{tuple} construct.
#'
#' Each call to \code{\link[iterators]{nextElem}} returns a list with two
#' elements:
#' \describe{
#'   \item{index:}{a counter}
#'   \item{value:}{the current value of \code{object}}
#' }
#'
#' \code{ienum} is an alias to \code{ienumerate} to save a few keystrokes.
#'
#' @export
#' @param object object to return indefinitely.
#' @return iterator that returns the values of \code{object} along with the
#' index of the object.
#'
#' @examples
#' set.seed(42)
#' it <- ienumerate(rnorm(5))
#' as.list(it)
#'
#' # Iterates through the columns of the iris data.frame
#' it2 <- ienum(iris)
#' iterators::nextElem(it2)
#' iterators::nextElem(it2)
#' iterators::nextElem(it2)
#' iterators::nextElem(it2)
#' iterators::nextElem(it2)
ienumerate <- function(object) {
  izip(index=icount(start=1), value=object)
}

#' @rdname ienumerate
#' @export
ienum <- ienumerate


degsat <- function(t, rh, pa) {
    .Call('biometeoR_degsat', PACKAGE = 'biometeoR', t, rh, pa)
}


function (sj, wsz)
{
    tmp <- data[[sj]][[3]][, c(10, 11, 13)]
    tmp <- tmp[order(tmp[, 1]), 2:3]
    npts <- dim(tmp)[1] - wsz
    out <- rep(0, times = npts)
    for (i1 in c(1:npts)) {
        tmprange <- c(i1:(i1 + wsz))
        is <- glm(acc ~ Pic, family = "binomial", data = tmp[tmprange,
            ])$coef
        out[i1] <- -(is[1]/is[2])
    }
    out
}


#' kmh2fts
#'
#' Conversion from kilometer per hour to feets per second.
#'
#' @param kmh numeric  Speed in kilometer per hour.
#' @return  feets per second
#'
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#'
#' @export
#'
#'
#'
#'

kmh2fts=function(kmh) {
                         ct$assign("kmh", as.array(kmh))
                         ct$eval("var res=[]; for(var i=0, len=kmh.length; i < len; i++){ res[i]=kmh2fts(kmh[i])};")
                          res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


\name{hc_layer-GenomicHilbertCurve-method}
\alias{hc_layer,GenomicHilbertCurve-method}
\title{
Add a new layer to the Hilbert curve
}
\description{
Add a new layer to the Hilbert curve
}
\usage{
\S4method{hc_layer}{GenomicHilbertCurve}(object, gr, col = "red", border = NA,
    mean_mode = c("w0", "absolute", "weighted", "max_freq"), grid_line = 0,
    grid_line_col = "black", overlay = default_overlay)
}
\arguments{

  \item{object}{a \code{\link{GenomicHilbertCurve-class}} object}
  \item{gr}{a \code{\link[GenomicRanges:GRanges-class]{GRanges}} object which contains the genomic regions to be mapped to the curve}
  \item{col}{a scalar or a vector of colors which correspond to regions in \code{gr}, pass to \code{\link{hc_layer,HilbertCurve-method}}}
  \item{border}{a scalar or a vector of colors which correspond to the borders of regions. Set it to \code{NA} if borders are suppressed.}
  \item{mean_mode}{Under 'pixel' mode, each pixel represents a small window. This argument provides methods to summarize value for the small window if the input genomic regions can not completely overlap with the window,  pass to \code{\link{hc_layer,HilbertCurve-method}}}
  \item{grid_line}{whether add grid lines to show blocks of the Hilber curve, pass to \code{\link{hc_layer,HilbertCurve-method}}}
  \item{grid_line_col}{color for the grid lines, pass to \code{\link{hc_layer,HilbertCurve-method}}}
  \item{overlay}{a self-defined function which defines how to overlay new layer to the plot, pass to \code{\link{hc_layer,HilbertCurve-method}}}

}
\details{
It is basically a wrapper of \code{\link{hc_layer,HilbertCurve-method}}.
}
\value{
Refer to \code{\link{hc_layer,HilbertCurve-method}}
}
\author{
Zuguang Gu <z.gu@dkfz.de>
}
\examples{
require(circlize)
require(GenomicRanges)
bed = generateRandomBed()
gr = GRanges(seqnames = bed[[1]], ranges = IRanges(bed[[2]], bed[[3]]))
hc = GenomicHilbertCurve(mode = "pixel", level = 9)
hc_layer(hc, gr, col = rand_color(length(gr)))
}


  get.fishery.stats.by.region = function( Reg="cfaall", y=NULL ) {

    landings = landings.db()

    if (is.null(y)) y = sort(unique(landings$yr) )
    out = data.frame( yr=y )

    if (Reg=="cfaall")  region = sort( unique(landings$cfa) ) # all data
    if (Reg=="cfanorth") region = c("cfa20", "cfa21", "cfa22", "cfanorth", "north")
    if (Reg=="cfasouth") region = c("cfa23", "cfa24", "cfasouth", "cfaslope")
    if (Reg=="cfa4x") region = "cfa4x"

    lnd = landings[ which(landings$cfa %in% region) ,]

    l = aggregate( lnd$landings, list(yr=lnd$yr), function(x) sum(x, na.rm=T))
    names(l) = c("yr", "landings")

    out = merge(out, l, by="yr", all.x=T, all.y=F, sort=T)

    lnd$cpue_direct = lnd$landings / lnd$effort
    lnd$cpue_direct[ which( lnd$cpue_direct > (650*0.454)) ] = NA  # same rule as in landings.db -- 650lbs/trap is a reasonable upper limit

    cpue = aggregate( lnd$cpue, list(yr=lnd$yr), function(x) mean(x, na.rm=T))
    names(cpue) = c("yr", "cpue")

    out = merge (out, cpue, by="yr", all.x=T, all.y=F, sort=T)

    out$effort = out$landings / out$cpue  ## estimate effort level as direct estimates are underestimates (due to improper logbook records)
    rownames(out) = out$yr

    return(out)

  }


dyn.load('/Library/Java/JavaVirtualMachines/jdk1.8.0_131.jdk/Contents/Home/jre/lib/server/libjvm.dylib')

setwd("/Users/mengmengjiang/all datas/voltage")

#对单个内容进行画图分析，尝试记录单个内容的pdf图片格式
#文件名：voltage_stable , OV电压与BV电压之差，即stable 稳定电压与三种液体之间随流量、极间距离、针头直径变化的影响

library(xlsx)

#读取v~Q的数据
eq<-read.xlsx("voltage.xls",sheetName="ethanol_r",header=TRUE)
aq<-read.xlsx("voltage.xls",sheetName="acetone_r",header=TRUE)
iq<-read.xlsx("voltage.xls",sheetName="iso_r",header=TRUE)

plot(eq$r, eq$va,  col=0, xaxs="i", xlim=c(0.25,0.85), ylim=c(1, 3.3),xlab=expression(paste(italic(Nozzle)," ",italic(diameter),(mm))),mgp=c(1, 0,0),tck=0.01,cex.lab=1.1,ylab=expression(italic(V)(kv)))

mtext("Nozzles",col="black",3,line=-1,font=2,cex=1)

###error bar####
error.bar <- function(x, y, upper, coll,lower=upper, length=0.05,...){
  if(length(x) != length(y) | length(y) !=length(lower) | length(lower) != length(upper))
    stop("vectors must be same length")
  arrows(x,y+upper, x, y-lower,col=coll, angle=90, code=3, length=length, ...)
}

###lines##
yan<-c("red","red","blue","blue","green3","green3")
pch<-c(1,2,1,2,1,2)

lines(eq$r,eq$vaeva,col=yan[1],pch=1,lwd=2,lty=4,type="b")
lines(eq$r,eq$vbeva,col=yan[2],pch=2,lwd=2,lty=4,type="b")
lines(aq$r,aq$vaeva,col=yan[3],pch=1,lwd=2,lty=4,type="b")
lines(aq$r,aq$vbeva,col=yan[4],pch=2,lwd=2,lty=4,type="b")
lines(iq$r,iq$vaeva,col=yan[5],pch=1,lwd=2,lty=4,type="b")
lines(iq$r,iq$vbeva,col=yan[6],pch=2,lwd=2,lty=4,type="b")

error.bar(eq$r,eq$vaeva,eq$vastd/2,col=yan[1])
error.bar(eq$r,eq$vbeva,eq$vbstd/2,col=yan[2])

error.bar(aq$r,aq$vaeva,aq$vastd/2,col=yan[3])
error.bar(aq$r,aq$vbeva,aq$vbstd/2,col=yan[4])

error.bar(iq$r,iq$vaeva,iq$vastd/2,col=yan[5])
error.bar(iq$r,iq$vbeva,iq$vbstd/2,col=yan[6])

leg<-c("ethanol-Von","ethanol-Vbr","acetone-Von","acetone-Vbr","iso-Von","iso-Vbr")

legend("bottomright",legend=leg, col=yan, pch=c(1,2,1,2,1,2),bty="n",lwd=2,lty=2,inset=.01,cex=0.8)


Cit.HepPh.Unique<-unique(Cit.HepPh)
cit.HepPh.dates.Unique<-unique(cit.HepPh.dates)

Cit.HepPh.WithDates<-data.frame()

dateOfPaper <- function(paperNodeId){
  cit.HepPh.dates.Unique[(cit.HepPh.dates.Unique$V1==paperNodeId),]$V2[1]
}
#dateOfPaper(112008)301097
j<-1
for(i in 1:nrow(Cit.HepPh.Unique)){
  date1<-dateOfPaper(Cit.HepPh.Unique[i,1])
  date2<-dateOfPaper(Cit.HepPh.Unique[i,2])
  if((!is.na(date1))&&(!is.na(date2))){
    Cit.HepPh.WithDates[j,1]<-Cit.HepPh.Unique[i,1]
    Cit.HepPh.WithDates[j,2]<-date1
    Cit.HepPh.WithDates[j,3]<-Cit.HepPh.Unique[i,2]
    Cit.HepPh.WithDates[j,4]<-date2
    j=j+1
  }
}


library(gWidgets)
options(guiToolkit="RGtk2") ## using gWidgtsRGtk2

w <- gwindow("Disable components")

g <- ggroup(cont=w, horizontal=FALSE)
e <- gedit("0", cont=g, coerce.with=as.numeric)
bg <- ggroup(cont=g)

down_btn <- gbutton("-", cont=bg)
up_btn <- gbutton("+", cont=bg)

update_ctrls <- function(h,...) {
  val <- svalue(e)
  enabled(down_btn) <- val >= 0
  enabled(up_btn) <- val <= 10
}

rement <- function(h,...) {
  svalue(e) <- svalue(e) + h$action
  update_ctrls(h,...)
}

addHandlerChanged(e, handler=update_ctrls)
addHandlerChanged(down_btn, handler=rement, action=-1)
addHandlerChanged(up_btn, handler=rement, action=1)


#  James Rekow

identifyNumSubgroupsTest = function(MVec = NULL, NVec = NULL, lambdaVec = NULL, numSubgroupsVec = NULL,
                                    iStrength = 1, univVec = NULL, sigmaMax = 0.1,
                                    thresholdMult = 10 ^ (-1), maxSteps = 10 ^ 4, tStep = 10 ^ (-2),
                                    intTime = 1, interSmplMult = 0.01, conGraph = NULL, rollRange = 0.025,
                                    numReplicates = 10){

  #  ARGS:
  #
  #  RETURNS: percentErrorDF - data frame containing columns for all the input data and the percent
  #                            of replicates for which identifyNumSubgroups returned the wrong number
  #                            of subgroups

  source("subgroupsAbdListCreator.r")
  source("computeInfoWeightMat.r")
  source("identifyNumSubgroups.r")

  #  set default value of MVec
  if(is.null(MVec)){
    MVec = seq(40, 200, 80)
  } #  end if

  #  set default value of NVec
  if(is.null(NVec)){
    NVec = seq(20, 100, 40)
  } #  end if

  #  set default value of numSubgroupsVec
  if(is.null(numSubgroupsVec)){
    numSubgroupsVec = seq(1, 4, 1)
  } #  end if

  #  set default value of lambdaVec
  if(is.null(lambdaVec)){
    lambdaVec = seq(0, 200, 50)
  } #  end if

  #  set default value of univVec
  if(is.null(univVec)){
    univVec = seq(0, 1, 0.5)
  } #  end if

  correctNumberIdentified = function(inputVec){

    #  ARGS: inputVec - a vector of the form c(M, N, numSUbgroups, lambda, univ)
    #
    #  RETURNS: correct - boolean corresponding to whether or not identifyNumSubgroups correctly
    #                     identified the number of subgroups in an abundance list generated using the
    #                     input treatment

    #  extract parameter values from inputVec
    M = inputVec[1]
    N = inputVec[2]
    numSubgroups = inputVec[3]
    lambda = inputVec[4]
    univ = inputVec[5]

    #  create abundance list using the input parameters for the given treatment
    abdList = subgroupsAbdListCreator(M = M, numSubgroups = numSubgroups, N = N, iStrength = iStrength,
                                      univ = univ, sigmaMax = sigmaMax, thresholdMult = thresholdMult,
                                      maxSteps = maxSteps, tStep = tStep, intTime = intTime,
                                      interSmplMult = interSmplMult, lambda = lambda, returnParams = FALSE,
                                      conGraph = conGraph)

    #  compute the info weight matrix for the given abundance list
    infoWeightMat = computeInfoWeightMat(abdList = abdList, rollRange = rollRange)

    #  compute percent error of algorithm's subgroup classification
    numSubgroupsGuess = identifyNumSubgroups(infoMat = infoWeightMat)

    #  check if the algorithm identified the correct number of subgroups
    correct = numSubgroupsGuess == numSubgroups

    return(correct)

  } #  end correctNumberIdentified function

  percentErrorProducer = function(inputVec){

    #  ARGS: inputVec - vector of the form c(M, N, lambda, univ)
    #
    #  RETURNS: percentError - the percent of replicates at each treatment for which identifyNumSubgroups
    #                          returned the incorrect number of subgroups

    #  compute whether or not the algorithm identified the correct number of subgroups for the given input
    #  and repeat for numReplicates replicates
    correctGuessVec = replicate(numReplicates, correctNumberIdentified(inputVec = inputVec))

    #  compute the percent of replicates for which the algorithm failed
    percentError = 100 * sum(!correctGuessVec) / numReplicates

    return(percentError)

  } #  end percentErrorProducer function

  #  create a matrix of all unique combinations of elements from Mvec, NVec, numSubgroupsVec, lambdaVec,
  #  and univVec
  inputMat = expand.grid(MVec, NVec, numSubgroupsVec, lambdaVec, univVec)

  #  for each combination of inputs, compute the percent error of the algorithm using those inputs
  percentError = apply(inputMat, 1, percentErrorProducer)

  #  store data in a data frame
  percentErrorDF = data.frame(M = inputMat[ , 1], N = inputMat[ , 2], numSubgroups = inputMat[ , 3],
                              lambda = inputMat[ , 4], univ = inputMat[ , 5],
                              percentError = percentError)

  return(percentErrorDF)

} #  end identifyNumSubgroupsTest function


# Make map of region
library(maps)

rlong <- c(-124.5, -113.5)
rlat <- c(32.5, 42.5)

ca <- data.frame(map("county", xlim = rlong, ylim = rlat, plot = F, fill = T)[c("x", "y")])
camap <- c(
  geom_path(aes(x, y), data = ca, colour=alpha("grey40", 0.5), size = 0.5),
  xlim(rlong),
  ylim(rlat)
)

bayarea <- c(
  geom_polygon(aes(x, y), data = ca, colour=alpha("grey40", 0.5), size = 0.5, fill = "grey95"),
  coord_cartesian(xlim = c(-123.5576, -120.5427), ylim = c(35.80061, 38.84582))
)


# Author: Justin Abraham
# R Version: R-3.6.2
# RStudio Version: 1.2.5033

###############################
## Install required packages ##
###############################

set.seed(47269801)

install.packages("pacman", repos='https://cloud.r-project.org/')
library("pacman")

p_load("here", "tidyr", "dplyr", "lmtest", "multiwayvcov", "multcomp", "reshape2", "knitr", "flextable", "officer", "forestplot", "cowplot", "ggplot2", "matrixStats", "ggthemes", "ggsignif", "rstudioapi", "iptools")

source(here("r", "Funs.r"), echo = TRUE)

################
## Clean data ##
################

## Read data ##

varnames <- as.vector(read.delim(file = here("data", "U1_MTurk_Eligible.csv"), sep = ",", header = FALSE, stringsAsFactors = FALSE, na.strings = "", nrows = 1))
u1_df <- read.delim(file = here("data", "U1_MTurk_Eligible.csv"), sep = ",", header = FALSE, stringsAsFactors = FALSE, na.strings = "", skip = 1, col.names = varnames)

## Treatment assignment ##

u1_df$treat[u1_df$condition == "poverty"] <- 0
u1_df$treat[u1_df$condition == "individual"] <- 1
u1_df$treat[u1_df$condition == "community"] <- 2
u1_df$treat <- factor(u1_df$treat, labels = c("Pov", "Ind", "Com"), levels = c(0, 1, 2))

u1_df$pov <- ifelse(u1_df$condition == "poverty", 1, 0)
u1_df$ind <- ifelse(u1_df$condition == "individual", 1, 0)
u1_df$com <- ifelse(u1_df$condition == "community", 1, 0)

## Recoding vars ##

u1_df$spot1[which(u1_df$spot1 == 4)] <- 3
u1_df$donation_me <- u1_df$donation_pov_1
u1_df$donation_org <- u1_df$donation_pov_2
u1_df$donated <- as.logical(u1_df$donation_org > 0)
d.donated <- u1_df %>%
  dplyr::filter(donated==1)

u1_df$donor_status <- NA
u1_df$donor_status <- u1_df$stat.ladder_14

u1_df$recip.impact_r <- 8-u1_df$recip.impact
u1_df$recip.improve_r <- 8-u1_df$recip.improve
u1_df$recip.ladder_r <- 11-u1_df$recip.ladder_14

## Clean sociodems ##

u1_df$priordonor <- as.numeric(as.logical(u1_df$priorgiving == 2))
u1_df$age <- as.numeric(u1_df$age)
u1_df$gen.fem <- as.numeric(as.logical(u1_df$gender ==2))
u1_df$income.hh <- as.numeric(u1_df$income/sqrt(u1_df$hhsize))
u1_df$hi.income.hh <- as.numeric(as.logical(u1_df$income.hh > 31305))
u1_df$hi.income <- as.numeric(as.logical(u1_df$income > 50000))
u1_df$edu.self.ba <- as.numeric(as.logical(u1_df$educ >4))
u1_df$edu.par.ba <- as.numeric(as.logical(u1_df$educ.parent >4))
u1_df$edu.par.ba <- as.numeric(as.logical(u1_df$educ.parent >4))
u1_df$race.minor <- as.numeric(as.logical(u1_df$race !=1))
u1_df$is.religi <- as.numeric(as.logical(u1_df$religiosity >2))
u1_df$is.chr <- as.numeric(as.logical(u1_df$religion == 6))
u1_df$is.dem <- as.numeric(as.logical(u1_df$party == 3))

# need to add religion dummy

## Center covariates ##

u1_df$priordonor.c <- scale(u1_df$priordonor, scale = FALSE)
u1_df$gen.fem.c <- scale(u1_df$gen.fem, scale = FALSE)
u1_df$hi.income.hh.c <- scale(u1_df$hi.income.hh, scale = FALSE)
u1_df$edu.self.ba.c <- scale(u1_df$edu.self.ba, scale = FALSE)
u1_df$race.minor.c <- scale(u1_df$race.minor, scale = FALSE)
u1_df$is.religi.c <- scale(u1_df$is.religi, scale = FALSE)
u1_df$is.chr.c <- scale(u1_df$is.chr, scale = FALSE)
u1_df$is.dem.c <- scale(u1_df$is.dem, scale = FALSE)

save(u1_df, file = here("data", "USData.RData"))
write.csv(u1_df, file = here("data", "USData.csv"))


library("dplyr")

get_genotype_ages <- function(pop_df) {
	# construct a dataframe with "Age" of each genotype:
	pop_df <- arrange_(pop_df, ~-Population)
	pop_df <- arrange_(pop_df, ~Generation)
	lookup <- group_by_(pop_df, ~Identity) %>%
		filter_(~Population > 0 | Generation == max(Generation)) %>%
		slice(1) %>%
		arrange_(~Generation) %>%
		ungroup()
	lookup <- mutate(lookup, Age = 1:dim(lookup)[1]) %>%
		select_(~-c(Generation, Population))
	if(is.factor(lookup$Identity)) lookup$Identity <- levels(lookup$Identity)[lookup$Identity]
	lookup <- select_(lookup, ~c(Identity, Age))

	return(lookup)
}

args = commandArgs(trailingOnly=TRUE)
filename <- args[1]
pop_df <- read.table(filename, sep = "\t", header = TRUE)

# Add the sorting to match the python script
pop_df <- arrange_(pop_df, ~-Population)
pop_df <- arrange_(pop_df, ~Generation)

#write.table(pop_df, args[2], sep = "\t", row.names = FALSE)

#result <- add_start_points(pop_df)
lookup <- get_genotype_ages(pop_df)
#lookup <- pop_df
write.table(lookup, args[2], sep = "\t", row.names = FALSE)


library(tidyverse)
# library(dplyr)
# library(ggrepel)
require(rgdal)
library(ggpubr)

#get folder directory
folder <- dirname(rstudioapi::getSourceEditorContext()$path)

results <- read.csv(file.path(folder, '..', '..', 'results', 'national_results_technology_options.csv'))
names(results)[names(results) == 'GID_0'] <- 'iso3'

clusters <- read.csv(file.path(folder, '..', 'clustering', 'results', 'data_clustering_results.csv'))
names(clusters)[names(clusters) == 'ISO_3digit'] <- 'iso3'
clusters <- select(clusters, iso3, cluster, country)

results <- merge(results, clusters, x.by='iso3', y.by='iso3', all=FALSE)

mean_user_cost_by_cluster <- select(results, scenario, strategy, confidence, cost_per_network_user, cluster)

mean_user_cost_by_cluster <- mean_user_cost_by_cluster %>%
  group_by(scenario, strategy, confidence, cluster) %>%
  summarise(mean_cost_per_user = mean(cost_per_network_user))

results <- merge(clusters, mean_user_cost_by_cluster, x.by='cluster', y.by='cluster', all=TRUE)

gdp <- read.csv(file.path(folder, '..', 'gdp.csv'))
names(gdp)[names(gdp) == 'iso3'] <- 'iso3'
gdp <- select(gdp, iso3, gdp)

results <- merge(results, gdp, by='iso3', all=FALSE)

pop <- read.csv(file.path(folder, 'data_inputs', 'population_2018.csv'))
pop <- select(pop, iso3, population)
pop$iso3 <- as.character(pop$iso3)

results <- merge(results, pop, by='iso3', all=FALSE)

#Not sure if this is right
#Current costs are for a user on a network with 25% market share
#We then multiply the user cost across the whole population?
#check and revise this
results$total_cost <- results$mean_cost_per_user * results$population

results$gdp_percentage <- (results$total_cost / 5) / results$gdp * 100

results$confidence = factor(results$confidence, levels=c('5','50', '95'),
                            labels=c("lower", 'mean', "upper"))
unique(results$scenario)
results$scenario = factor(results$scenario, levels=c("S1_25_10_2",
                                                     "S2_200_50_5",
                                                     "S3_400_100_10"),
                          labels=c("S1 (25 Mbps)",
                                   "S2 (200 Mbps)",
                                   "S3 (400 Mbps)"))

results$strategy = factor(results$strategy, levels=c(
  "4G_epc_microwave_baseline_baseline_baseline_baseline",
  "4G_epc_fiber_baseline_baseline_baseline_baseline",
  "5G_nsa_microwave_baseline_baseline_baseline_baseline",
  "5G_sa_fiber_baseline_baseline_baseline_baseline"),
  labels=c(
    "4G (Microwave)",
    "4G (Fiber)",
    "5G NSA (Microwave)",
    "5G SA (Fiber)"))

results <- results[complete.cases(results), ]

raw_num <- select(results, country, cluster, scenario, strategy, confidence, total_cost)
raw_num <- spread(raw_num, confidence, total_cost)

cost_by_strategy <- ggplot(raw_num, aes(x=raw_num$cluster, y=raw_num$mean/1e9, colour=raw_num$cluster)) +
  geom_boxplot(aes(group=factor(raw_num$cluster))) +
  # geom_jitter(width = 0.4, height=0.5, size=1.7) +
  scale_colour_manual(values = c("#F0E442","#E69F00","#D55E00", "#0072B2", "#56B4E9","#009E73")) +
  theme(legend.position = NULL) +
  labs(colour=NULL,
       title = "Total Investment Cost",
       subtitle = "Boxplot of results by scenario, strategy and cluster",
       x = NULL, y = "Total Investment ($USD Billions)") +
  theme(panel.spacing = unit(0.6, "lines")) +
  expand_limits(x = 0, y = 0) +
  scale_y_continuous(limits=c(0,40), expand=c(0,0)) +
  guides(fill=FALSE, colour=FALSE) +
  facet_grid(scenario~strategy)

gdp_num <- select(results, country, cluster, scenario, strategy, confidence, gdp_percentage)
gdp_num <- spread(gdp_num, confidence, gdp_percentage)

gdp_perc_by_strategy <- ggplot(gdp_num, aes(x=gdp_num$cluster, y=gdp_num$mean, colour=gdp_num$cluster)) +
  geom_boxplot(aes(group=factor(gdp_num$cluster))) +
  # geom_jitter(width = 0.4, height=0.5, size=1.7) +
  scale_colour_manual(values = c("#F0E442","#E69F00","#D55E00", "#0072B2", "#56B4E9","#009E73")) +
  theme(legend.position = NULL) +
  labs(colour=NULL,
       title = "Annual Investment Cost as GDP Share Over 5 Years",
       subtitle = "Boxplot of results by scenario, strategy and cluster",
       x = NULL, y = "Annual GDP (% over 5 years)") +
  theme(panel.spacing = unit(0.4, "lines")) +
  expand_limits(x = 0, y = 0) +
  scale_y_continuous(limits=c(0,10), expand=c(0,0), breaks=seq(0, 9.7, 2)) +
  guides(fill=FALSE, colour=FALSE) +
  facet_grid(scenario~strategy)

panel <- ggarrange(cost_by_strategy, gdp_perc_by_strategy, ncol = 1, nrow = 2, align = c("hv"))

#export to folder
path = file.path(folder, 'figures', 'cost_by_strategy.png')
ggsave(path, units="cm", width=25, height=35)
print(panel)
dev.off()


library(geosphere)

# Case time series in GB areas
uk_cases <- read.csv("data/uk_cases.csv")
ind <- sapply(uk_cases[,2], function(s)
    !(s %in% c('Outside Wales','Unknown','...17','...18'))
)
uk_cases <- uk_cases[ind,]

N <- nrow(uk_cases) # 348 LTLA in England, NHS health boards Scotland, X in Wales

areas <- uk_cases[,2]
quoted_areas <- sapply(areas,function(s) paste('"',s,'"',sep=''))

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

# Assumes that metadata contains all areas in uk_cases and area names match perfectly
metadata <- read.csv("data/metadata.csv")
ind <- sapply(metadata[,1], function(s)
    s %in% areas
)
metadata <- metadata[ind,]

geoloc <- matrix(0, N, 2)
geodist <- matrix(0, N, N)
population <- rep(0.0, N)

# match up areas in uk_cases and metadata
meta_areas <- metadata$AREA
longitudes <- metadata$LONG
latitudes <- metadata$LAT

nhs_regions <- metadata$NHS_Region
nhs_regions_unique <- nhs_regions[!duplicated(nhs_regions)]
nhs_regions_to_areas <- matrix(0, N, 9)

for (i in 1:N) {
  area <- areas[i]
  j <- grep(sprintf('^%s$',area), meta_areas)
  l <- length(j)
  if (l >= 1) {                 # just use first match!!
    if (l > 1) {
      print(sprintf("Area: %s",area))
      print(sprintf("Matched meta_areas: %s", paste(meta_areas[j],collapse=', ')))
      print(sprintf("Using: %s, %s",meta_areas[j[l]],metadata$CODE[j[l]]))
    }
    geoloc[i, 1] = longitudes[j[l]]
    geoloc[i, 2] = latitudes[j[l]]
    population[i] = metadata$POPULATION[j[l]]

    nhs_row = (nhs_regions_unique == nhs_regions[j[l]])
    nhs_regions_to_areas[i,] = nhs_row
  } else {
    print(sprintf("Cannot find area '%s'",area))
    for (r in 1:length(meta_areas)) {
      if (length(grep(meta_areas[r], area))>0) {
        geoloc[i, 1] = longitudes[r]
        geoloc[i, 2] = latitudes[r]
        population[i] = metadata$POPULATION[r]
        print(sprintf("...found area '%s'",meta_areas[r]))
      }
    }
  }
}

write.csv(
  data.frame(
    area=quoted_areas,
    longitude=geoloc[,1],
    latitude=geoloc[,2],
    population=population,
    nhs_region=nhs_regions_to_areas
  ),'data/areas.csv',row.names=FALSE,quote=FALSE)

write.csv(
  data.frame(
    nhs_region=nhs_regions_unique
  ),'data/nhs_regions.csv',row.names=FALSE,quote=FALSE)

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

write.matrix.csv <- function(m,filename) {
  colnames(m) <- quoted_areas
  rownames(m) <- quoted_areas
  write.csv(m,filename,quote=FALSE)
}

# compute distances between areas. Straight line, not actual travel distance.
for (i in 1:N) {
  for (j in i:N) {
    # distance between two points on an ellipsoid (default is WGS84 ellipsoid), in units of 100km
    geodist[i, j] = distGeo(geoloc[i, 1:2], geoloc[j, 1:2]) / 100000
    geodist[j, i] = geodist[i, j]
  }
}
write.matrix.csv(geodist,'data/distances.csv')


#' Evaluate deep learning model performance
#'
#' A function to evaluate a deep learning model.
#' @param model_keras Keras deep learning model.
#' @param input_data A dataframe containing occurrence data parsed for deep learning using the \code{\link{prepare_dl_data}} function.
#'
#' @return A tibble containing the model estimates.
#' @examples
#' \dontrun{
#' # download benchmarking data
#' benchmarking_data <- get_benchmarking_data("Lynx lynx",
#'                                            limit = 1500)
#'
#' # transform benchmarking data into a format suitable for deep learning
#' # if you have previously used a partitioning method you should specify it here
#' benchmarking_data_dl <- prepare_dl_data(input_data = benchmarking_data$df_data,
#'                                        partitioning_type = "default")
#'
#' # perform sanity checks on the transformed data
#' # for the training set
#' head(benchmarking_data_dl$train_tbl)
#' table(benchmarking_data_dl$y_train_vec)
#'
#' # for the test set
#' head(benchmarking_data_dl$test_tbl)
#' table(benchmarking_data_dl$y_test_vec)
#'
#' # train neural network
#' keras_results <- train_dl(benchmarking_data_dl)
#'
#' # inspect training results
#' keras_results$history
#'
#' # you can also plot them
#' plot(keras_results$history)
#'
#' # create evaluation tibble containing training results
#' keras_evaluation <- evaluate_dl(keras_results$model, benchmarking_data_dl)
#' head(keras_evaluation)
#' }
#' @export
evaluate_dl <- function(model_keras, input_data) {
    yhat_keras_class_vec <- keras::predict_classes(object = model_keras,
                                                   x = as.matrix(input_data$test_tbl)) %>%
        as.vector()

    yhat_keras_prob_vec <- keras::predict_proba(object = model_keras,
                                                x = as.matrix(input_data$test_tbl)) %>%
        as.vector()

    estimates_keras_tbl <- tibble::tibble(truth = as.factor(input_data$y_test_vec),
                                          estimate = as.factor(yhat_keras_class_vec),
        class_prob = yhat_keras_prob_vec)

    return(estimates_keras_tbl)
}


setwd("/Users/xxuadmin/BUSINESS/PUBLICATIONS/WorkingOn_Abramoff_Perspective/millennial_code_2017July_Century_WT")

# output
data <- read.table("outputcontrol.txt")
LMC <- data$V2[729636:730000]
POM <- data$V3[729636:730000]
MB <- data$V4[729636:730000]
MINERAL <- data$V5[729636:730000]
AGG <- data$V6[729636:730000]
outputcontrol <- data$V2 + data$V3 + data$V4 + data$V5 + data$V6

summary(LMC)
summary(POM)
summary(MB)
summary(MINERAL)
summary(AGG)
lmcaverage = mean(LMC)
pomaverage = mean(POM)
mbaverage = mean(MB)
mineralaverage = mean(MINERAL)
aggaverage = mean(AGG)

carbon <- c(lmcaverage, pomaverage, mbaverage, mineralaverage, aggaverage)
#lbls <- c("LMWC", "POM", "MB", "MINERAL", "AGGREGATE")
#pct <- round(carbon/sum(carbon)*100)
#lbls <- paste(lbls,pct) # add percents to labels
#lbls <- paste(lbls, "%", sep="")
#pie(carbon, labels=lbls, col=rainbow(length(lbls)),main=round(sum(carbon)))
#par(mai = c(1,1,1,1,1))
colors <- c("black","red","green","blue","pink")
numb_labels <- round(carbon/sum(carbon) * 100,1)
numb_labels <- paste(numb_labels, "%", sep="")
xx <- c("LMWC","POM","MB","MINERAL","AGGREGATE")
xx <- paste(round(carbon/sum(carbon) * 100,1),xx,sep=" ")

pdf(file = "outputcontrol.pdf")
pie(carbon, labels="", col=colors,clockwise=TRUE,main=paste("Control run:", round(sum(carbon)),"gC",sep=" "))
legend(-1.25,-0.5, legend = xx, fill=colors,bty="n")
dev.off()

rm(data)
rm(LMC)
rm(POM)
rm(MB)
rm(MINERAL)
rm(AGG)
# end

# output
data <- read.table("output5cwarm.txt")
LMC <- data$V2[729636:730000]
POM <- data$V3[729636:730000]
MB <- data$V4[729636:730000]
MINERAL <- data$V5[729636:730000]
AGG <- data$V6[729636:730000]
output5cwarm <- data$V2 + data$V3 + data$V4 + data$V5 + data$V6

summary(LMC)
summary(POM)
summary(MB)
summary(MINERAL)
summary(AGG)
lmcaverage = mean(LMC)
pomaverage = mean(POM)
mbaverage = mean(MB)
mineralaverage = mean(MINERAL)
aggaverage = mean(AGG)

carbon <- c(lmcaverage, pomaverage, mbaverage, mineralaverage, aggaverage)
#lbls <- c("LMWC", "POM", "MB", "MINERAL", "AGGREGATE")
#pct <- round(carbon/sum(carbon)*100)
#lbls <- paste(lbls,pct) # add percents to labels
#lbls <- paste(lbls, "%", sep="")
#pie(carbon, labels=lbls, col=rainbow(length(lbls)),main=round(sum(carbon)))
colors <- c("black","red","green","blue","pink")
numb_labels <- round(carbon/sum(carbon) * 100,1)
numb_labels <- paste(numb_labels, "%", sep="")
xx <- c("LMWC","POM","MB","MINERAL","AGGREGATE")
xx <- paste(round(carbon/sum(carbon) * 100,1),xx,sep=" ")

pdf(file = "output5cwarm.pdf")
pie(carbon, labels="", col=colors,clockwise=TRUE,main=paste("5 C warming:", round(sum(carbon)),"gC",sep=" "))
legend(-1.25,-0.5, legend = xx, fill=colors,bty="n")
dev.off()

rm(data)
rm(LMC)
rm(POM)
rm(MB)
rm(MINERAL)
rm(AGG)
# end

# output
data <- read.table("output10clay.txt")
LMC <- data$V2[729636:730000]
POM <- data$V3[729636:730000]
MB <- data$V4[729636:730000]
MINERAL <- data$V5[729636:730000]
AGG <- data$V6[729636:730000]
output10clay <- data$V2 + data$V3 + data$V4 + data$V5 + data$V6

summary(LMC)
summary(POM)
summary(MB)
summary(MINERAL)
summary(AGG)
lmcaverage = mean(LMC)
pomaverage = mean(POM)
mbaverage = mean(MB)
mineralaverage = mean(MINERAL)
aggaverage = mean(AGG)

carbon <- c(lmcaverage, pomaverage, mbaverage, mineralaverage, aggaverage)
#lbls <- c("LMWC", "POM", "MB", "MINERAL", "AGGREGATE")
#pct <- round(carbon/sum(carbon)*100)
#lbls <- paste(lbls,pct) # add percents to labels
#lbls <- paste(lbls, "%", sep="")
#pie(carbon, labels=lbls, col=rainbow(length(lbls)),main=round(sum(carbon)))
colors <- c("black","red","green","blue","pink")
numb_labels <- round(carbon/sum(carbon) * 100,1)
numb_labels <- paste(numb_labels, "%", sep="")
xx <- c("LMWC","POM","MB","MINERAL","AGGREGATE")
xx <- paste(round(carbon/sum(carbon) * 100,1),xx,sep=" ")

pdf(file = "output10clay.pdf")
pie(carbon, labels="", col=colors,clockwise=TRUE,main=paste("10% Clay content:", round(sum(carbon)),"gC",sep=" "))
legend(-1.25,-0.5, legend = xx, fill=colors,bty="n")
dev.off()

rm(data)
rm(LMC)
rm(POM)
rm(MB)
rm(MINERAL)
rm(AGG)
# end

# output
data <- read.table("output20clay.txt")
LMC <- data$V2[729636:730000]
POM <- data$V3[729636:730000]
MB <- data$V4[729636:730000]
MINERAL <- data$V5[729636:730000]
AGG <- data$V6[729636:730000]
output20clay <- data$V2 + data$V3 + data$V4 + data$V5 + data$V6

summary(LMC)
summary(POM)
summary(MB)
summary(MINERAL)
summary(AGG)
lmcaverage = mean(LMC)
pomaverage = mean(POM)
mbaverage = mean(MB)
mineralaverage = mean(MINERAL)
aggaverage = mean(AGG)

carbon <- c(lmcaverage, pomaverage, mbaverage, mineralaverage, aggaverage)
#lbls <- c("LMWC", "POM", "MB", "MINERAL", "AGGREGATE")
#pct <- round(carbon/sum(carbon)*100)
#lbls <- paste(lbls,pct) # add percents to labels
#lbls <- paste(lbls, "%", sep="")
#pie(carbon, labels=lbls, col=rainbow(length(lbls)),main=round(sum(carbon)))
colors <- c("black","red","green","blue","pink")
numb_labels <- round(carbon/sum(carbon) * 100,1)
numb_labels <- paste(numb_labels, "%", sep="")
xx <- c("LMWC","POM","MB","MINERAL","AGGREGATE")
xx <- paste(round(carbon/sum(carbon) * 100,1),xx,sep=" ")

pdf(file = "output20clay.pdf")
pie(carbon, labels="", col=colors,clockwise=TRUE,main=paste("20% Clay content:", round(sum(carbon)),"gC",sep=" "))
legend(-1.25,-0.5, legend = xx, fill=colors,bty="n")
dev.off()

rm(data)
rm(LMC)
rm(POM)
rm(MB)
rm(MINERAL)
rm(AGG)
# end

# output
data <- read.table("output30clay.txt")
LMC <- data$V2[729636:730000]
POM <- data$V3[729636:730000]
MB <- data$V4[729636:730000]
MINERAL <- data$V5[729636:730000]
AGG <- data$V6[729636:730000]
output30clay <- data$V2 + data$V3 + data$V4 + data$V5 + data$V6

summary(LMC)
summary(POM)
summary(MB)
summary(MINERAL)
summary(AGG)
lmcaverage = mean(LMC)
pomaverage = mean(POM)
mbaverage = mean(MB)
mineralaverage = mean(MINERAL)
aggaverage = mean(AGG)

carbon <- c(lmcaverage, pomaverage, mbaverage, mineralaverage, aggaverage)
#lbls <- c("LMWC", "POM", "MB", "MINERAL", "AGGREGATE")
#pct <- round(carbon/sum(carbon)*100)
#lbls <- paste(lbls,pct) # add percents to labels
#lbls <- paste(lbls, "%", sep="")
#pie(carbon, labels=lbls, col=rainbow(length(lbls)),main=round(sum(carbon)))
colors <- c("black","red","green","blue","pink")
numb_labels <- round(carbon/sum(carbon) * 100,1)
numb_labels <- paste(numb_labels, "%", sep="")
xx <- c("LMWC","POM","MB","MINERAL","AGGREGATE")
xx <- paste(round(carbon/sum(carbon) * 100,1),xx,sep=" ")

pdf(file = "output30clay.pdf")
pie(carbon, labels="", col=colors,clockwise=TRUE,main=paste("30% clay content:", round(sum(carbon)),"gC",sep=" "))
legend(-1.25,-0.5, legend = xx, fill=colors,bty="n")
dev.off()

rm(data)
rm(LMC)
rm(POM)
rm(MB)
rm(MINERAL)
rm(AGG)
# end

# output
data <- read.table("output40clay.txt")
LMC <- data$V2[729636:730000]
POM <- data$V3[729636:730000]
MB <- data$V4[729636:730000]
MINERAL <- data$V5[729636:730000]
AGG <- data$V6[729636:730000]
output40clay <- data$V2 + data$V3 + data$V4 + data$V5 + data$V6

summary(LMC)
summary(POM)
summary(MB)
summary(MINERAL)
summary(AGG)
lmcaverage = mean(LMC)
pomaverage = mean(POM)
mbaverage = mean(MB)
mineralaverage = mean(MINERAL)
aggaverage = mean(AGG)

carbon <- c(lmcaverage, pomaverage, mbaverage, mineralaverage, aggaverage)
#lbls <- c("LMWC", "POM", "MB", "MINERAL", "AGGREGATE")
#pct <- round(carbon/sum(carbon)*100)
#lbls <- paste(lbls,pct) # add percents to labels
#lbls <- paste(lbls, "%", sep="")
#pie(carbon, labels=lbls, col=rainbow(length(lbls)),main=round(sum(carbon)))
colors <- c("black","red","green","blue","pink")
numb_labels <- round(carbon/sum(carbon) * 100,1)
numb_labels <- paste(numb_labels, "%", sep="")
xx <- c("LMWC","POM","MB","MINERAL","AGGREGATE")
xx <- paste(round(carbon/sum(carbon) * 100,1),xx,sep=" ")

pdf(file = "output40clay.pdf")
pie(carbon, labels="", col=colors,clockwise=TRUE,main=paste("40% clay content:", round(sum(carbon)),"gC",sep=" "))
legend(-1.25,-0.5, legend = xx, fill=colors,bty="n")
dev.off()

rm(data)
rm(LMC)
rm(POM)
rm(MB)
rm(MINERAL)
rm(AGG)
# end

# output
data <- read.table("output50clay.txt")
LMC <- data$V2[729636:730000]
POM <- data$V3[729636:730000]
MB <- data$V4[729636:730000]
MINERAL <- data$V5[729636:730000]
AGG <- data$V6[729636:730000]
output50clay <- data$V2 + data$V3 + data$V4 + data$V5 + data$V6

summary(LMC)
summary(POM)
summary(MB)
summary(MINERAL)
summary(AGG)
lmcaverage = mean(LMC)
pomaverage = mean(POM)
mbaverage = mean(MB)
mineralaverage = mean(MINERAL)
aggaverage = mean(AGG)

carbon <- c(lmcaverage, pomaverage, mbaverage, mineralaverage, aggaverage)
#lbls <- c("LMWC", "POM", "MB", "MINERAL", "AGGREGATE")
#pct <- round(carbon/sum(carbon)*100)
#lbls <- paste(lbls,pct) # add percents to labels
#lbls <- paste(lbls, "%", sep="")
#pie(carbon, labels=lbls, col=rainbow(length(lbls)),main=round(sum(carbon)))
colors <- c("black","red","green","blue","pink")
numb_labels <- round(carbon/sum(carbon) * 100,1)
numb_labels <- paste(numb_labels, "%", sep="")
xx <- c("LMWC","POM","MB","MINERAL","AGGREGATE")
xx <- paste(round(carbon/sum(carbon) * 100,1),xx,sep=" ")

pdf(file = "output50clay.pdf")
pie(carbon, labels="", col=colors,clockwise=TRUE,main=paste("50% clay content:", round(sum(carbon)),"gC",sep=" "))
legend(-1.25,-0.5, legend = xx, fill=colors,bty="n")
dev.off()

rm(data)
rm(LMC)
rm(POM)
rm(MB)
rm(MINERAL)
rm(AGG)
# end

# output
data <- read.table("output60clay.txt")
LMC <- data$V2[729636:730000]
POM <- data$V3[729636:730000]
MB <- data$V4[729636:730000]
MINERAL <- data$V5[729636:730000]
AGG <- data$V6[729636:730000]
output60clay <- data$V2 + data$V3 + data$V4 + data$V5 + data$V6

summary(LMC)
summary(POM)
summary(MB)
summary(MINERAL)
summary(AGG)
lmcaverage = mean(LMC)
pomaverage = mean(POM)
mbaverage = mean(MB)
mineralaverage = mean(MINERAL)
aggaverage = mean(AGG)

carbon <- c(lmcaverage, pomaverage, mbaverage, mineralaverage, aggaverage)
#lbls <- c("LMWC", "POM", "MB", "MINERAL", "AGGREGATE")
#pct <- round(carbon/sum(carbon)*100)
#lbls <- paste(lbls,pct) # add percents to labels
#lbls <- paste(lbls, "%", sep="")
#pie(carbon, labels=lbls, col=rainbow(length(lbls)),main=round(sum(carbon)))
colors <- c("black","red","green","blue","pink")
numb_labels <- round(carbon/sum(carbon) * 100,1)
numb_labels <- paste(numb_labels, "%", sep="")
xx <- c("LMWC","POM","MB","MINERAL","AGGREGATE")
xx <- paste(round(carbon/sum(carbon) * 100,1),xx,sep=" ")

pdf(file = "output60clay.pdf")
pie(carbon, labels="", col=colors,clockwise=TRUE,main=paste("60% clay content:", round(sum(carbon)),"gC",sep=" "))
legend(-1.25,-0.5, legend = xx, fill=colors,bty="n")
dev.off()

rm(data)
rm(LMC)
rm(POM)
rm(MB)
rm(MINERAL)
rm(AGG)
# end
# output
data <- read.table("output70clay.txt")
LMC <- data$V2[729636:730000]
POM <- data$V3[729636:730000]
MB <- data$V4[729636:730000]
MINERAL <- data$V5[729636:730000]
AGG <- data$V6[729636:730000]
output70clay <- data$V2 + data$V3 + data$V4 + data$V5 + data$V6

summary(LMC)
summary(POM)
summary(MB)
summary(MINERAL)
summary(AGG)
lmcaverage = mean(LMC)
pomaverage = mean(POM)
mbaverage = mean(MB)
mineralaverage = mean(MINERAL)
aggaverage = mean(AGG)

carbon <- c(lmcaverage, pomaverage, mbaverage, mineralaverage, aggaverage)
#lbls <- c("LMWC", "POM", "MB", "MINERAL", "AGGREGATE")
#pct <- round(carbon/sum(carbon)*100)
#lbls <- paste(lbls,pct) # add percents to labels
#lbls <- paste(lbls, "%", sep="")
#pie(carbon, labels=lbls, col=rainbow(length(lbls)),main=round(sum(carbon)))
colors <- c("black","red","green","blue","pink")
numb_labels <- round(carbon/sum(carbon) * 100,1)
numb_labels <- paste(numb_labels, "%", sep="")
xx <- c("LMWC","POM","MB","MINERAL","AGGREGATE")
xx <- paste(round(carbon/sum(carbon) * 100,1),xx,sep=" ")

pdf(file = "output70clay.pdf")
pie(carbon, labels="", col=colors,clockwise=TRUE,main=paste("70% Clay content:", round(sum(carbon)),"gC",sep=" "))
legend(-1.25,-0.5, legend = xx, fill=colors,bty="n")
dev.off()

rm(data)
rm(LMC)
rm(POM)
rm(MB)
rm(MINERAL)
rm(AGG)
# end

# output
data <- read.table("output80clay.txt")
LMC <- data$V2[729636:730000]
POM <- data$V3[729636:730000]
MB <- data$V4[729636:730000]
MINERAL <- data$V5[729636:730000]
AGG <- data$V6[729636:730000]
output80clay <- data$V2 + data$V3 + data$V4 + data$V5 + data$V6

summary(LMC)
summary(POM)
summary(MB)
summary(MINERAL)
summary(AGG)
lmcaverage = mean(LMC)
pomaverage = mean(POM)
mbaverage = mean(MB)
mineralaverage = mean(MINERAL)
aggaverage = mean(AGG)

carbon <- c(lmcaverage, pomaverage, mbaverage, mineralaverage, aggaverage)
#lbls <- c("LMWC", "POM", "MB", "MINERAL", "AGGREGATE")
#pct <- round(carbon/sum(carbon)*100)
#lbls <- paste(lbls,pct) # add percents to labels
#lbls <- paste(lbls, "%", sep="")
#pie(carbon, labels=lbls, col=rainbow(length(lbls)),main=round(sum(carbon)))
colors <- c("black","red","green","blue","pink")
numb_labels <- round(carbon/sum(carbon) * 100,1)
numb_labels <- paste(numb_labels, "%", sep="")
xx <- c("LMWC","POM","MB","MINERAL","AGGREGATE")
xx <- paste(round(carbon/sum(carbon) * 100,1),xx,sep=" ")

pdf(file = "output80clay.pdf")
pie(carbon, labels="", col=colors,clockwise=TRUE,main=paste("80% Clay content:", round(sum(carbon)),"gC",sep=" "))
legend(-1.25,-0.5, legend = xx, fill=colors,bty="n")
dev.off()

rm(data)
rm(LMC)
rm(POM)
rm(MB)
rm(MINERAL)
rm(AGG)
# end

# output
data <- read.table("outputdoubleCinput.txt")
LMC <- data$V2[729636:730000]
POM <- data$V3[729636:730000]
MB <- data$V4[729636:730000]
MINERAL <- data$V5[729636:730000]
AGG <- data$V6[729636:730000]
outputdoubleCinput <- data$V2 + data$V3 + data$V4 + data$V5 + data$V6

summary(LMC)
summary(POM)
summary(MB)
summary(MINERAL)
summary(AGG)
lmcaverage = mean(LMC)
pomaverage = mean(POM)
mbaverage = mean(MB)
mineralaverage = mean(MINERAL)
aggaverage = mean(AGG)

carbon <- c(lmcaverage, pomaverage, mbaverage, mineralaverage, aggaverage)
#lbls <- c("LMWC", "POM", "MB", "MINERAL", "AGGREGATE")
#pct <- round(carbon/sum(carbon)*100)
#lbls <- paste(lbls,pct) # add percents to labels
#lbls <- paste(lbls, "%", sep="")
#pie(carbon, labels=lbls, col=rainbow(length(lbls)),main=round(sum(carbon)))
colors <- c("black","red","green","blue","pink")
numb_labels <- round(carbon/sum(carbon) * 100,1)
numb_labels <- paste(numb_labels, "%", sep="")
xx <- c("LMWC","POM","MB","MINERAL","AGGREGATE")
xx <- paste(round(carbon/sum(carbon) * 100,1),xx,sep=" ")

pdf(file = "outputdoubleCinput.pdf")
pie(carbon, labels="", col=colors,clockwise=TRUE,main=paste("Double C input:", round(sum(carbon)),"gC",sep=" "))
legend(-1.25,-0.5, legend = xx, fill=colors,bty="n")
dev.off()

rm(data)
rm(LMC)
rm(POM)
rm(MB)
rm(MINERAL)
rm(AGG)
# end

# output
data <- read.table("outputhalfwater.txt")
LMC <- data$V2[729636:730000]
POM <- data$V3[729636:730000]
MB <- data$V4[729636:730000]
MINERAL <- data$V5[729636:730000]
AGG <- data$V6[729636:730000]
outputhalfwater <- data$V2 + data$V3 + data$V4 + data$V5 + data$V6

summary(LMC)
summary(POM)
summary(MB)
summary(MINERAL)
summary(AGG)
lmcaverage = mean(LMC)
pomaverage = mean(POM)
mbaverage = mean(MB)
mineralaverage = mean(MINERAL)
aggaverage = mean(AGG)

carbon <- c(lmcaverage, pomaverage, mbaverage, mineralaverage, aggaverage)
#lbls <- c("LMWC", "POM", "MB", "MINERAL", "AGGREGATE")
#pct <- round(carbon/sum(carbon)*100)
#lbls <- paste(lbls,pct) # add percents to labels
#lbls <- paste(lbls, "%", sep="")
#pie(carbon, labels=lbls, col=rainbow(length(lbls)),main=round(sum(carbon)))
colors <- c("black","red","green","blue","pink")
numb_labels <- round(carbon/sum(carbon) * 100,1)
numb_labels <- paste(numb_labels, "%", sep="")
xx <- c("LMWC","POM","MB","MINERAL","AGGREGATE")
xx <- paste(round(carbon/sum(carbon) * 100,1),xx,sep=" ")

pdf(file = "outputhalfwater.pdf")
pie(carbon, labels="", col=colors,clockwise=TRUE,main=paste("Half water moisture:", round(sum(carbon)),"gC",sep=" "))
legend(-1.25,-0.5, legend = xx, fill=colors,bty="n")
dev.off()

rm(data)
rm(LMC)
rm(POM)
rm(MB)
rm(MINERAL)
rm(AGG)
# end

# output
data <- read.table("outputTandCinput.txt")
LMC <- data$V2[729636:730000]
POM <- data$V3[729636:730000]
MB <- data$V4[729636:730000]
MINERAL <- data$V5[729636:730000]
AGG <- data$V6[729636:730000]
outputTandCinput <- data$V2 + data$V3 + data$V4 + data$V5 + data$V6

summary(LMC)
summary(POM)
summary(MB)
summary(MINERAL)
summary(AGG)
lmcaverage = mean(LMC)
pomaverage = mean(POM)
mbaverage = mean(MB)
mineralaverage = mean(MINERAL)
aggaverage = mean(AGG)

carbon <- c(lmcaverage, pomaverage, mbaverage, mineralaverage, aggaverage)
#lbls <- c("LMWC", "POM", "MB", "MINERAL", "AGGREGATE")
#pct <- round(carbon/sum(carbon)*100)
#lbls <- paste(lbls,pct) # add percents to labels
#lbls <- paste(lbls, "%", sep="")
#pie(carbon, labels=lbls, col=rainbow(length(lbls)),main=round(sum(carbon)))
colors <- c("black","red","green","blue","pink")
numb_labels <- round(carbon/sum(carbon) * 100,1)
numb_labels <- paste(numb_labels, "%", sep="")
xx <- c("LMWC","POM","MB","MINERAL","AGGREGATE")
xx <- paste(round(carbon/sum(carbon) * 100,1),xx,sep=" ")

pdf(file = "outputTandCinput.pdf")
pie(carbon, labels="", col=colors,clockwise=TRUE,main=paste("5C Warming and Double C input:", round(sum(carbon)),"gC",sep=" "))
legend(-1.25,-0.5, legend = xx, fill=colors,bty="n")
dev.off()

rm(data)
rm(LMC)
rm(POM)
rm(MB)
rm(MINERAL)
rm(AGG)
# end

# output
data <- read.table("outputTandW.txt")
LMC <- data$V2[729636:730000]
POM <- data$V3[729636:730000]
MB <- data$V4[729636:730000]
MINERAL <- data$V5[729636:730000]
AGG <- data$V6[729636:730000]
outputTandW <- data$V2 + data$V3 + data$V4 + data$V5 + data$V6

summary(LMC)
summary(POM)
summary(MB)
summary(MINERAL)
summary(AGG)
lmcaverage = mean(LMC)
pomaverage = mean(POM)
mbaverage = mean(MB)
mineralaverage = mean(MINERAL)
aggaverage = mean(AGG)

carbon <- c(lmcaverage, pomaverage, mbaverage, mineralaverage, aggaverage)
#lbls <- c("LMWC", "POM", "MB", "MINERAL", "AGGREGATE")
#pct <- round(carbon/sum(carbon)*100)
#lbls <- paste(lbls,pct) # add percents to labels
#lbls <- paste(lbls, "%", sep="")
#pie(carbon, labels=lbls, col=rainbow(length(lbls)),main=round(sum(carbon)))
colors <- c("black","red","green","blue","pink")
numb_labels <- round(carbon/sum(carbon) * 100,1)
numb_labels <- paste(numb_labels, "%", sep="")
xx <- c("LMWC","POM","MB","MINERAL","AGGREGATE")
xx <- paste(round(carbon/sum(carbon) * 100,1),xx,sep=" ")

pdf(file = "outputTandW.pdf")
pie(carbon, labels="", col=colors,clockwise=TRUE,main=paste("5C Warming and Half Water:", round(sum(carbon)),"gC",sep=" "))
legend(-1.25,-0.5, legend = xx, fill=colors,bty="n")
dev.off()

rm(data)
rm(LMC)
rm(POM)
rm(MB)
rm(MINERAL)
rm(AGG)
# end

#plot time series of total carbon for all scenarios
#outputcontrol
#output5cwarm
#output10clay
#output20clay
#output30clay
#output40clay
#output50clay
#output60clay
#output70clay
#output80clay
#outputdoubleCinput
#outputhalfwater
#outputTandCinput
#outputTandW
pdf(file = "timeseries.pdf")
day=c(1:136500)
plot(c(1,175000),c(-2000,2000),type="n",xlab="Day",ylab="changed in total C storage")
lines(day,output5cwarm[1:136500] - outputcontrol[1:136500],col="blue")
lines(day,output10clay[1:136500] - outputcontrol[1:136500],col="brown")
lines(day,output20clay[1:136500] - outputcontrol[1:136500],col="yellow")
lines(day,output30clay[1:136500] - outputcontrol[1:136500],col="cyan")
lines(day,output40clay[1:136500] - outputcontrol[1:136500],col="darkblue")
lines(day,output50clay[1:136500] - outputcontrol[1:136500],col="darkgreen")
lines(day,output60clay[1:136500] - outputcontrol[1:136500],col="darkgray")
lines(day,output70clay[1:136500] - outputcontrol[1:136500],col="darkorange")
lines(day,output80clay[1:136500] - outputcontrol[1:136500],col="darkred")
lines(day,outputdoubleCinput[1:136500] - outputcontrol[1:136500],col="deeppink")
lines(day,outputhalfwater[1:136500] - outputcontrol[1:136500],col="deepskyblue")
lines(day,outputTandCinput[1:136500] - outputcontrol[1:136500],col="darkgreen")
lines(day,outputTandW[1:136500] - outputcontrol[1:136500],col="lightgreen")
legend(137500,1000,c("warming","10% clay","20% clay","30% clay","40% clay","50% clay","60% clay","70% clay","80% clay","double C input","half water","warming and double C input","warming and half water"),lty=c(1,1),lwd=c(2.5,2.5),col=c("blue","brown","yellow","cyan","darkblue","darkgreen","darkgray","darkorange","darkred","deeppink","deepskyblue","darkgreen","lightgreen"))
dev.off()