## \int f(x)dg(x) with step functions f,g
## integral reduces to finite sum over all jump times
stepIntegrate <- function(f, g) {
    ##f[is.nan(f)] <- 0
    sum(f * (g - c(1, g[-length(g)])))
}

evalFun <- function(times, x, y) {
    f <- approxfun(x, y, method="constant", yleft=1, rule=2, f=0)
    f(times)
}

## get all jump points (i.e. events) up to time L
getTimes <- function(L, data) {
    obs <- c(0, data$time[(data$to != "cens") & (data$time <= L)], data$Y[(data$D == 1) & (data$Y <= L)], L)
    sort(unique(obs))
}

## example: Surv(V, Y, D) ~ Trt + strata(W)
parseFormula <- function(formula, data, one.sample=FALSE) {

  Terms <- terms(formula, "strata")
  mf <- model.frame(Terms, data)

  ## extract Surv object
  surv <- model.response(mf)
  if(!is.Surv(surv)) stop("Model response must be 'Surv' object")

  n <- nrow(surv)
  
  if(ncol(surv) == 2) {
      Start <- rep.int(0, n)
      Stop <- surv[,1]
      status <- surv[,2]
  } else {
      Start <- surv[,1]
      Stop <- surv[,2]
      status <- surv[,3]
  }
  
  ## extract stratum indicator
  st <- attr(Terms, "specials")$strata
  if(is.null(st)) {
      W <- rep.int(0, n)
      st.labels <- NULL
  } else {
      st.labels <- dimnames(attr(Terms, "factors"))[[1]][st]
      W <- as.integer(mf[[st.labels]])
  }

  ## extract group indicator
  if(!one.sample) {
      sdi <- setdiff(labels(Terms), st.labels)
      if(length(sdi) > 0) Trt <- as.factor(as.matrix(mf[sdi])) ## multiple covariates are combined into one factor
      else stop("No treatment groups specified!")
  } else Trt <- rep.int(0, n)
  
  data.frame(V=Start, Y=Stop, D=status, W=factor(W), Trt=factor(Trt))
}
make_decision <- function(x, cutoff)
  data.frame(x, Amyloid = factor(ifelse(x[["Probability"]] > cutoff, "yes", "no")))
#' @importFrom dplyr %>%
#' @export
dplyr::`%>%`
#' @title Utility functions
#'
#' @description Not called directly by user.
#'
#' @param beta  Effect size.
#' @param se.beta Standard error of the effect.
#' @param beta0  Prior for the effect size.
#' @param se0 Prior standard error.
#' @param ci A numeric value that is used to calculate the prior standard error.
#' 
# posterior mean (standard Bayesian updating for normal conjugate prior)
calc.post.beta <- function(beta, se.beta, beta0, se0){
    ((beta/se.beta^2) + (beta0/se0^2)) / ((1/se.beta^2) + (1/se0^2))
}


#' @rdname calc.post.beta
# Posterior variance
calc.post.se <- function(se.beta, se0){
    sqrt(1 / ((1/se.beta^2) + (1/se0^2)) )
}


#' @rdname calc.post.beta
# Prior variance
prior.se <- function(beta, se.beta, ci) {
    
    if (!is.numeric(beta))    stop("beta is not numeric")
    if (!is.numeric(se.beta)) stop("se.beta is not numeric")
    
    # multiplier for confidence intervals
    ci <- (ci / 100)
    ci <- ci + (1 - ci) / 2
    multiplier <- qnorm(ci)
    data <- matrix(NA, ncol = 2, nrow = length(beta))
    
    # get min/max
    data[, 1:2] <- beta + c(-se.beta, se.beta) * multiplier

    bounds <- abs(data)
    se0 <- apply(bounds, 1, max)
    se0 <- ( (se0 / multiplier))
    
    return(se0)
}
### check if object is a formula

is.formula <- function(x) return(class(x) == "formula")


### check if matrix is positive semidefinite

is.pos.semidefinite.matrix <- function(x) {
  if (!is.matrix(x))
    return(FALSE)
  if (!isSymmetric(x, tol = 10^-9))
    return(FALSE)
  return(all(eigen(x, only.values = TRUE)$values >= 0))
}


### check if matrix can be inverted

is.invertible.matrix <- function(x) {
  return(class(try(solve(x), silent = TRUE)) == "matrix")
}


### relabel indicators for dedicated factor model
### example:
###   > d <- c(6, 6, 6, 2, 2, 2, 0, 0, 4, 4, 4)
###   > relabel(d) [1] 1 1 1 2 2 2 0 0 3 3 3

relabel.dedic <- function(d) {
  u <- unique(d[d != 0])
  t <- rep(0, max(d))
  t[u] <- 1:length(u)
  d[d != 0] <- t[d]
  return(d)
}


### count number of unique nonzero elements in x

count.unique.nonzero <- function(x) return(length(unique(x[x != 0])))


### convert matrix to list

mat2list <- function(x, byrow = FALSE) {
  if (byrow) {
    y <- split(x, c(row(x)))
    names(y) <- rownames(x)
  } else {
    y <- split(x, c(col(x)))
    names(y) <- colnames(x)
  }
  return(y)
}


### get maximum correlation (in absolute value) from correlation matrix

get.maxcor <- function(x) max(abs(x[lower.tri(x)]))


### get minimum eigenvalue of symmetric matrix

get.mineig <- function(x) min(eigen(x, symmetric = TRUE,
                                    only.values = TRUE)$values)
logMeanExpLogs = function(v)
{
	N = length(v)
	.Call("RLogMeanExpLogs", as.numeric(v), N, package="BayesSingleSub")
}
as_mcmc.matrix = function(x, names, par = NULL) {
  dimnames(x)=list(NULL, names)
  if (is.null(par)) {
    attr(x, 'mcpar') = c(1, nrow(x), 1)
  } else {
    attr(x, 'mcpar') = par
  }
  class(x) = 'mcmc'
  return(x)
}

calc_mpsrf = function(x, end) {
  x = window(x, start(x), end, 1)
  Niter = niter(x)
  Nchain = nchain(x)
  Nvar = nvar(x)
  x = lapply(x, as.matrix)
  S2 = array(sapply(x, var, simplify=TRUE), dim=c(Nvar,Nvar,Nchain))
  W = apply(S2, c(1,2), mean)
  xbar = matrix(sapply(x, apply, 2, mean, simplify=TRUE), nrow=Nvar, ncol=Nchain)
  B = Niter * var(t(xbar))
  CW = chol(W)
  emax = eigen(backsolve(CW, t(backsolve(CW, B, transpose=TRUE)), transpose=TRUE), symmetric=TRUE, only.values=TRUE)$values[1]
  res = sqrt( (1 - 1/Niter) + (1 + 1/Nvar) * emax/Niter )
  return(res)
}

mpsrf = function(x, step = 50, ...) {
  if (nchain(x) < 2 | nvar(x) == 1) 
    stop("You need at least two chains and two parameters.")
  z = seq(start(x)-1+step, end(x), by = step)
  res = sapply(z, function(i) calc_mpsrf(x,i))
  x = data.frame(z,MPSRF = res)
  return(x)
}
# inspired from https://gist.github.com/doobwa/941125
# maybe replace with logSumExp {matrixStats} which might be faster?
#' Funktion to compute log(sum(exp(x))
#' @author Florian Hartig
#' @param x values
#' @param mean logical, determines whether the mean should be used
#' @export
logSumExp<- function(x, mean = F) {
  # Computes log(sum(exp(x))
  # Uses offset trick to avoid numeric overflow: http://jblevins.org/notes/log-sum-exp
  if ( max(abs(x)) > max(x) ) offset <- min(x) else offset <- max(x)
  if (mean == T) out = log(mean(exp(x - offset))) + offset
  else out = log(sum(exp(x - offset))) + offset
  return(out)
}


#x = rep(-100, 100) 

#log(sum(exp(x)))
#logSumExp(x, mean = F)
#log(mean(exp(x)))
#logSumExp(x, mean = T)
#' Dummy algorithm routine to test the sampling procedures
#'
#' This is a dummy algorithm routine to test the sampling procedures. It
#' basically returns values according to the distribution function given
#' in \code{distribution.fun} with parameters given by \code{distribution.pars}.
#'
#' @param distribution.fun name of a function that generates random values
#' according to a given distribution, e.g., "rnorm", "runif", "rexp" etc.
#' @param distribution.pars list of named parameters required by the function
#' in \code{distribution.fun}. Parameter \code{n} (number of points to
#' generate) is unnecessary (this routine always considers `n = 1`).
#' @param instance instance parameters. This parameter is always ignored, and
#' was only included for compatibility with \code{run_nreps2} and other `nreps`
#' functions.
#'
#' @return a list object with a single field \code{$value}, containing a value
#' distributed according to \code{distribution.fun} and \code{distribution.pars}.
#'
#' @author Felipe Campelo (\email{fcampelo@@ufmg.br})
#'
#' @export

# TESTED
dummyalgo <- function(distribution.fun = "rnorm",
                      distribution.pars = list(mean = 0, sd = 1),
                      instance)
{
  # ========== Error catching ========== #
  assertthat::assert_that(
    is.character(distribution.fun) && length(distribution.fun) == 1,
    is.list(distribution.pars))
  # ==================================== #

  distribution.pars$n <- 1
  return(list(value = do.call(distribution.fun, args = distribution.pars)))
}


#' Dummy instance (for testing only) - a function that does nothing and returns
#' nothing
#' @export
# TESTED
dummyinstance <- function(){
  # do nothing
}
is_cdec_data <- function(.) {
  identical(get_cdec_serivce(.), "cdec_data")
}

is_cdec_dataset <- function(.) {
  identical(get_cdec_serivce(.), "cdec_datasets")
}

is_cdec_meta <- function(.) {
  identical(get_cdec_serivce(.), "cdec_meta")
}

is_cdec_station <- function(.) {
  identical(get_cdec_serivce(.), "cdec_stations")
}

get_cdec_serivce <- function(o) {
  return(attr(o, "cdec_service"))
}


# display error that are informative to the user

missing_xml <- function(.) {
  identical(., xml2::xml_missing())
}
# CHNOSZ/util.matrix.R
# miscellaneous functions for matrices

invertible.combs <- function(A, nmax=20) {
  # given a matrix A, with number of rows equal to or greater 
  # than the number of columns, return the combinations of row 
  # numbers that constitute invertible square matrices  20111126 jmd
  # start with all combinations
  # nmax: don't consider more than this many rows (to save time for large systems)
  nr <- min(nrow(A), nmax)
  combs <- t(combn(nr, ncol(A)))
  ic <- numeric()
  zero <- sqrt(.Machine$double.eps)
  # loop over the combinations
  for(i in 1:nrow(combs)) {
    # a slow method, actually calculating the inverse
    #tt <- try(solve(A[combs[i,],]),silent=TRUE)
    #if(class(tt)!="try-error") ic <- c(ic,i)
    # it's faster just to test if the determinant is non-zero
    d <- det(A[combs[i,],])
    if(abs(d) > zero) ic <- c(ic, i)
  }
  return(combs[ic,,drop=FALSE])
}
# CHNOSZ/util.test.R
# functions for writing tests 20171005

# the maximum (absolute) pairwise difference between x and y
maxdiff <- function(x, y) max(abs(y - x))

# modelled after the "expect_" functions in testthat ...
# is the maximum of the pairwise differences between two objects less than some value?
expect_maxdiff <- function(object, expected, maxdiff = 0) {
  if(!"testthat" %in% row.names(installed.packages())) {
    stop("please install the 'testthat' package to use this function")
  } else {
    # get the names for the object and expected values
    # we use a double substitute here because
    # as.character(substitute(x$a$b)) ==  c("$", "x$a", "b")
    # as.character(substitute(substitute(x$a$b)))[2] == "x$a$b" --> better for printing
    lab_act <- as.character(substitute(substitute(object)))[2]
    lab_exp <- as.character(substitute(substitute(expected)))[2]
    truemd <- maxdiff(object, expected)
    failmsg <- sprintf("maxdiff(%s, %s) not less than %s", lab_act, lab_exp, maxdiff)
    truemsg <- sprintf("actual value: %s", truemd)
    testthat::expect(maxdiff(object, expected) <= maxdiff, sprintf("%s\n%s", failmsg, truemsg))
    invisible(object)
  }
}
logger <- function(msg, ...)
{
	sys.time <- as.character(Sys.time())
	cat(sys.time, "-", sprintf(msg, ...))
}
wwwDirectory = function(){
  path <- system.file("www",package="D3GB")
  return(path)
}

createHTML <- function(dir, dependencies, data, chromosomes){
  if(file.exists(dir))
    unlink(dir, recursive = TRUE)
  dir.create(dir)
  www <- wwwDirectory()
  html <- scan(file = paste(www, "template.html", sep = "/"), what = character(0), sep = "\n", quiet = TRUE)
  name <- strsplit(dir,"/")[[1]]
  name <- name[length(name)]
  html <- sub("<!--title-->", name, html)
  dep <- "<!--head-->"
  for(i in seq_along(dependencies)){
    if(grepl(".css$",dependencies[i])){
      dep <- paste(dep, paste0("<link rel=\"stylesheet\" type=\"text/css\" href=\"styles/",dependencies[i],"\"></link>"), sep = "\n")
      dirName <- "styles"
    }else{
      dep <- paste(dep, paste0("<script type=\"text/javascript\" src=\"scripts/",dependencies[i],"\"></script>"), sep = "\n")
      dirName <- "scripts"
    }
    dir.create(paste(dir, dirName, sep = "/"),FALSE)
    file.copy(paste(www, dependencies[i], sep = "/"), paste(dir, dirName, sep = "/"))
  }
  html <- sub("<!--head-->", dep, html)
  chromosomes <- paste0('<script type="application/json" id="chromosomes">',chromosomes,'</script>')
  html <- sub("<!--body-->",paste("<!--body-->", chromosomes, sep = "\n"),html)
  data <- paste0('<script type="application/json" id="data">',data,'</script>')
  html <- sub("<!--body-->",paste("<!--body-->", data, sep = "\n"),html)
  write(html, paste(dir, "index.html", sep = "/"))
  message(paste0("The graph has been generated in the ",dir," folder."))
}
#' Add brush to plot
#' This adds a rectangle to a ggplot plot indicating the brush position.
#'
#' @param plot plot object
#' @param x x position of brush
#' @param y y position of brush
#' @param width width of brush
#' @param height height of brush
#' @param just which corner of brush should be determined by x and y position
#' @param fill fill colour for brush.  Use ggplot-alpha for alpha blending.
#' @param col outline colour of brush
#' @author Hadley Wickham \email{h.wickham@@gmail.com}
#' @keywords hplot
#' @export
addbrush <- function(
  plot,
  x, y,
  width = 0.5, height = 0.5,
  just = c("left", "top"),
  fill = "transparent",
  col = "black"
) {
  brush <- data.frame(x = x, y = y, width = width, height = height)
  geom_rect(
    aes_string("x", "y", width = "width", height = "height"),
    data = brush,
    justification = just, fill = fill, colour = col
  )
}

#' Remove hidden points
#' Will remove all hidden points from the plot.
#'
#' @param d ddplot object
#' @author Hadley Wickham \email{h.wickham@@gmail.com}
#' @keywords manip
#' @export
removehiddens <- function(d) {
  d$plots <- lapply(d$plots, function(dd) {
    dd$points <- dd$points[!dd$points$hidden, ]
    dd
  })

  d
}

#' Run All Examples
#' Will run all examples within the package
#' @author Barret Schloerke schloerke@@gmail.com
#' @keywords hplot
#' @export
zeeThemAll <- function() {
  example(ggplot.dd)
  example(ggplot.scatmat)
  example(ggplot.parcoords)
  example(ggplot.timeseries)
}


"%||%" <- function(a, b) {
  if (!is.null(a)) a else b
}
print.oa <- DoE.base:::print.oa

ff <- function(...){
  ein <- list(...)
  if (!is.numeric(unlist(ein))) stop("ff takes only integers as arguments")
  if (length(ein)==1) ein <- unlist(ein)
  hilf <- expand.grid(rev(lapply(ein, function(obj) 0:(obj-1))))
  as.matrix(hilf[,ncol(hilf):1])
}

countToD <- function(nlevels, count){
  ## function to transform a vector of counts into a design matrix
  dim <- log(length(count), base=nlevels)
  if (!round(dim%%1,12)==0) stop("wrong length of count")
  D <- eval(parse(text=paste("ff(",paste(rep(nlevels,dim),collapse=","),")")))
  d <- matrix(rep(D[1,], count[1]), ncol=dim, byrow=TRUE)
  csum <- cumsum(count)
  for (i in 2:length(count)){
    from <- csum[i-1]+1
    ci <- count[i]
    to <- csum[i]
    if (ci > 0)
      d <- rbind(d, matrix(rep(D[i,], ci), ncol=dim, byrow=TRUE))
  }
  as.matrix(d)
}

countToDmixed <- function(nlevels, count){
  ## function to transform a vector of counts into a design matrix
  dim <- length(nlevels)
  if (!prod(nlevels)==length(count)) stop("wrong length of count")
  D <- ff(nlevels)
  d <- matrix(rep(D[1,], count[1]), ncol=dim, byrow=TRUE)
  csum <- cumsum(count)
  for (i in 2:length(count)){
    from <- csum[i-1]+1
    ci <- count[i]
    to <- csum[i]
    if (ci > 0)
      d <- rbind(d, matrix(rep(D[i,], ci), ncol=dim, byrow=TRUE))
  }
  as.matrix(d)
}

dToCount <- function(d){
  ## function for creating counts of design rows in lexicographic order
  dim <- ncol(d)
  nlevels <- DoE.base:::levels.no(d)
  d <- d[DoE.base::ord(as.data.frame(d)),]
  D <- as.matrix(expand.grid(lapply(rev(nlevels), function(obj) 0:(obj-1))))
  D <- D[,dim:1]
  index <- 1:(prod(nlevels))
  sapply(index, function(obj)
    sum(apply(d, 1, function(obj2) all(obj2==D[obj,]))))
}
# Quiets concerns of R CMD check concerning the .'s that appear in pipelines
if (getRversion() >= "2.15.1") utils::globalVariables(c(".") )
generate.partition <- function(ntot, nfold=5) {
  foldsize <- rep(round(ntot/nfold), nfold-1)
  foldsize <- c(foldsize, ntot-sum(foldsize))
  
  remain <- 1:ntot
  folds <- rep(NA, ntot)
  for (n in 1:(nfold-1)) {
    idxtmp <- sample(remain, size=foldsize[n])
    folds[idxtmp] <- n
    remain <- setdiff(remain, idxtmp)
  }
  folds[remain] <- nfold
  return (as.integer(folds))
}

generate.partitions <- function(npart=1, ntot, nfold=5, ids=1:npart) {
  if (npart>1) ret <- sapply(1:npart, function(x,ntot,nfold) generate.partition(ntot,nfold), ntot, nfold)
  else ret <- as.matrix(generate.partition(ntot,nfold))
  colnames(ret) <- ids[1:npart]
  return (ret)
}

rmse.error <- function(a,b) sqrt(mean((a-b)^2))

# credit (and potential blame!) for this function goes to anonymous stackoverflow user!
load.object <- function(file) {
  env <- new.env()
  load(file, envir=env)
  loadedObjects <- objects(env, all.names=TRUE)
  stopifnot(length(loadedObjects)==1)
  return (env[[loadedObjects]])
}

extract.baselearner.name <- function(config, type="regression") {
  if (type=="regression") return (strsplit(class(config), "[.]Regression.Config")[[1]][1])
  stop("invalid type")
}

regression.extract.response <- function(formula, data) {
  ret <- try(data[,all.vars(formula)[1]], silent=T)
  if (inherits(ret, "try-error")) stop("response extraction failed")
  return (ret)
}
#' @title 
#' Proposal Distribution for MH Step for \code{mu}
#' 
#' @description 
#' This function caculates realizations from the proposal distribution for \code{mu} in 
#'     the Metropolis-Hastings (MH) step in the hybrid Gibbs sampler used in the 
#'     \code{\link{EpiBayes_ns}} and \code{\link{EpiBayes_s}} functions. Recall,
#'     in the context of disease freedom, \code{mu} was the average disease prevalence
#'     in a given diseased cluster of subjects.
#'
#' @param mumh The proposed or old value of \code{mu}.
#' @param mumh.alpha The old first shape parameter.
#' @param mumh.beta The old second shape parameter.
#' @param mumh.alphastar The new first shape parameter.
#' @param mumh.betastar The new second shape parameter.
#' 
#' @return
#' A realization from the (beta) proposal distribution.
#'
#' @references
#' Norets, A. and Tang, X. \emph{MCMC estimation of a finite beta mixture}. Technical 
#'     report, Princeton University, 2010.
#'
#' @seealso
#' Used in the functions \code{\link{EpiBayes_ns}} and \code{\link{EpiBayes_s}}.
#'
#' @export 
#' @name utils_mumhproposaldist
#' @import stats
utils_mumhproposaldist = function(mumh, mumh.alpha, mumh.beta, mumh.alphastar, mumh.betastar){
						return(dbeta(mumh, mumh.alphastar + mumh.alpha - 1, mumh.betastar + mumh.beta - 1))
					}
#' @title 
#' Target Distribution for MH Step for \code{mu}
#' 
#' @description 
#' This function caculates realizations from the target distribution for \code{mu} in 
#'     the Metropolis-Hastings (MH) step in the hybrid Gibbs sampler used in the 
#'     \code{\link{EpiBayes_ns}} and \code{\link{EpiBayes_s}} functions. Recall,
#'     in the context of disease freedom, \code{mu} was the average disease prevalence
#'     in a given diseased cluster of subjects.
#'
#' @param mumh The proposed or old value of \code{mu}.
#' @param psi The current MCMC iteration's value for \code{psi} (related to the variability
#'     of the disease prevalences among infected clusters of subjects).
#' @param pi The current MCMC iteration's value for \code{pi} (the subject-level 
#'     prevalences in each cluster).
#' @param z.pi The current MCMC iteration's value for \code{z.pi} (the indicator variables
#'     corresponding to the disease status of each cluster).
#' @param muparm The old first and second shape parameters.
#' 
#' @return
#' A realization from the target distribution.
#'
#' @references
#' Norets, A. and Tang, X. \emph{MCMC estimation of a finite beta mixture}. Technical 
#'     report, Princeton University, 2010.
#'
#' @seealso
#' Used in the functions \code{\link{EpiBayes_ns}} and \code{\link{EpiBayes_s}}.
#' 
#' @export 
#' @name utils_mumhtargetdist
#' @import stats
utils_mumhtargetdist = function(mumh, psi, pi, z.pi, muparm){
						return(prod((1 / (gamma(mumh * psi) * (gamma((1 - mumh) * psi))) * pi^mumh * (1 - pi)^(1 - mumh))^z.pi) * mumh^(muparm[1] - 1) * (1 - mumh)^(muparm[2] - 1))
					}
# Generate an matrix of uniformly distributed values in the interval (0,1) with
# the same dimension as M
randM <- function(M) {
  matrix(stats::runif(prod(dim(M))), 
         ncol = ncol(M))
}

# Denormalize population
denormalize_population <- function(probpars, Pop){
  # Denormalize population
  LL <- matrix(rep(probpars$xmin, nrow(Pop)),
               ncol = ncol(Pop),
               byrow = TRUE)
  UL <- matrix(rep(probpars$xmax, nrow(Pop)),
               ncol = ncol(Pop),
               byrow = TRUE)
  return(LL + Pop*(UL-LL))
}

# Check if a numeric value is within certain bounds
is_within <- function(x, xmin = 0, xmax = 1, strict = FALSE){
  out <- is.numeric(x) &&
    ifelse(strict,
           x >  xmin,
           x >= xmin) &&
  ifelse(strict,
         x <  xmax,
         x <= xmax)
  return(out)
}
## Plackett Burman generating vectors and matrices, according to 1946 article
## are in pb.list (in workspace sysdata.rda)
## most functions in here are used for extending the pb designs with entries 0 in this list
## (double.des, Williamson etc.)

## function for doubling designs
## normalize.row.last is applied later to ensure that last row is "-1"
double.des <- function(des){
   zeil <- nrow(des)
   ### +/- column and reflected columns unconventionally moved to the front !!!
   ### benefit: first columns are resolution IV
   rbind(cbind(rep(1,zeil),des,des),cbind(rep(-1,zeil),-des,des))
}

circ.mat <- function(gen){
   n <- length(gen)+1
   sel <- gen
   for (i in 1:(n-2))
    sel <- c(sel,gen[(n-i):(n-1)],gen[1:(n-i-1)])
    matrix(sel,n-1,n-1,byrow=1)
}

williamson <- function(A,B,C,D){rbind(
  cbind(A, B, C, D),
  cbind(-B, A, D, -C),
  cbind(-C, -D, A, B),
  cbind(-D, C, -B, A))
}

normalize.col.first <- function(mat){
    hilf <- mat[,1]==-1
    mat[hilf,] <- -mat[hilf,]
    mat[,-1]
}

normalize.row.last <- function(mat){
    hilf <- mat[nrow(mat),]==1
    mat[,hilf] <- -mat[,hilf]
    mat
}

des.recode <- function (var, recodes, as.factor.result, char) 
{
    recode.list <- rev(strsplit(recodes, ";")[[1]])
    is.fac <- is.factor(var)
    if (missing(as.factor.result)) 
        as.factor.result <- is.fac
    if (missing(char)) char <- FALSE
    result <- var
    if (is.fac) 
        result <- as.character(result)

    for (term in recode.list) {
            set <- eval(parse(text = strsplit(term, "=")[[1]][1]))
        if (!char)
            target <- eval(parse(text = strsplit(term, "=")[[1]][2]), 
                envir=parent.frame(), enclos=sys.frame(0))
        else 
        target <- strsplit(term, "=")[[1]][2]
        for (val in set) {
                if (is.na(val)) 
                  result[is.na(var)] <- target
                else result[var == val] <- target
        }
    }
    if (as.factor.result) result <- as.factor(result)
    result
}
permutations <- function(n){
   ## from package e1071
    if (n == 1) 
        return(matrix(1))
    else if (n < 2) 
        stop("n must be a positive integer")
    z <- matrix(1)
    for (i in 2:n) {
        x <- cbind(z, i)
        a <- c(1:i, 1:(i - 1))
        z <- matrix(0, ncol = ncol(x), nrow = i * nrow(x))
        z[1:nrow(x), ] <- x
        for (j in 2:i - 1) {
            z[j * nrow(x) + 1:nrow(x), ] <- x[, a[1:i + j]]
        }
    }
    dimnames(z) <- NULL
    z
}

invperm <- function(perm){
        sort(perm,index.return=TRUE)$ix
    }

reord <- function(hilf, perm){
    ## reorder matrix of binary numbers
    ## generating factors are isomorphic with binary numbers
    ## A=1, B=10, C=100, D=1000, usw.
    ##     AB=A+B=11 usw.

    ## column numbers for reordered generating factors can be obtained by 
    ##     switching digit positions

    ## reord does this and prepares the resulting matrix for calculating the column numbers
    ## with package sfsmisc
    aus <- hilf[nrow(hilf):1,,drop=FALSE][perm,,drop=FALSE][nrow(hilf):1,,drop=FALSE]
    class(aus) <- "basedInt"
    attr(aus,"base") <- 2
    aus
  }


getNext <- function(perm){
   ## function for next permutation in lexicographical order
   ## adapted from http://www.cut-the-knot.org/do_you_know/AllPerm.shtml
   ##     provided by Alexander Bogomolny, based on Dijkstra 1997 p.71
    N <- length(perm)
    i <- N

    while (perm[i-1] >= perm[i] & i>2) i <- i-1
 
    j <- N+1

    while (perm[j-1] <= perm[i-1] & j>2) {
         j <- j-1
       }

   ## swap values at positions (i-1) and (j-1)
    perm[c(i-1, j-1)] <- perm[c(j-1, i-1)]

    i <- i+1; j <- N+1

    while (i < j)
    {
      perm[c(i-1, j-1)] <- perm[c(j-1, i-1)]
      i <- i+1; j <- j-1
    }
    perm
}
#' @export 
plot.GFD <- function (x, ...) {
  
  object <- x
  dots <- list(...)
  a <- object$plotting
  b <- object$Descriptive
  fac.names <- a$fac_names
  exist <- hasArg(factor) 
   
  if(length(fac.names) != 1){
    if(!exist){
      print("Please choose the factor you wish to plot (for interaction type something like group1:group2) and confirm by pressing 'Enter'")
      Faktor <- scan("", what="character")
      while(length(Faktor)==0){
        print("Please enter the name of the factor you wish to plot!")
        Faktor <- scan("", what="character")
      }
      } else {
       Faktor <- dots$factor
      } 
    x.label <- ""
  } else {
    Faktor <- fac.names
    x.label <- fac.names
  }
    
  match.arg(Faktor, fac.names)

  # default values
  args <- list(plot.object = a, descr.object = b, factor = Faktor,
               lwd =2, ylab = "Means", xlab = x.label, col = 1:length(fac.names), pch = 1:18, legendpos = "topright")
  
  args[names(dots)] <- dots
  
  do.call(plotting, args = args)
}

#' @export
print.GFD <- function(x, ...) {
  a <- x$input
  cat("Call:", "\n")
  print(a$formula)
  cat("\n", "Wald-Type Statistic (WTS):", "\n", sep = "")
  print(x$WTS)
  cat("\n", "ANOVA-Type Statistic (ATS):", "\n", sep = "")
  print(x$ATS)
}

#' @export
summary.GFD <- function (object, ...) {
  a <- object$input
  cat("Call:", "\n")
  print(a$formula)
  cat("\n", "Descriptive:", "\n", sep = "")
  print(object$Descriptive)
  cat("\n", "Wald-Type Statistic (WTS):", "\n", sep = "")
  print(object$WTS)
  cat("\n", "ANOVA-Type Statistic (ATS):", "\n", sep = "")
  print(object$ATS)
}
#' Print if not CRAN
#'
#' Small function to print a plot if the R session is interactive or in a travis build
#'
#' @param p plot to be displayed
#' @export
print_if_interactive <- function(p) {
  if (interactive() || nzchar(Sys.getenv("CAN_PRINT"))) {
    print(p)
  }
}


#' Require packages
#'
#' Requires packages or yells at user... loudly
#'
#' @param pkgs vector of character values
#' @author Barret Schloerke \email{schloerke@@gmail.com}
#' @keywords internal
require_pkgs <- function(pkgs) {
  for (pkg in pkgs) {
    if (! require(pkg, character.only = TRUE)) {
      stop(str_c("please install the package '", pkg, "'.  install.packages('", pkg, "') "))
    }
  }
}


str_c <- function (..., sep = "", collapse = NULL) {
  paste(..., sep = sep, collapse = collapse)
}

str_detect <- function(string, pattern, ...) {
  grepl(pattern, string, ...)
}

# str_replace <- function(string, pattern, replacement) {
#   sub(pattern, replacement, string)
# }

ifnull <- function(a, b) {
  if (!is.null(a)) {
    a
  } else {
    b
  }
}


hf <- function(field) {
  eval(parse(text = read.dcf(".helper_functions", fields = field)))
}
## ************************************************************************
## 
## 
## 
## (c) Xiaobei Zhao
## 
## Mon Aug 25 18:08:55 EDT 2014 -0400 (Week 34)
## 
## 
## Reference: 
## 
## 
## ************************************************************************

##' Convert a BedGraph fiel to a vector of depth-like signals
##'
##' 
##' @title Convert a BedGraph fiel to a vector of depth-like signals
##' @param inFpath character, the path of a bedgraph file
##' @param chr character, the chromosome 
##' @param start numeric, the start position (0-base)
##' @param end numeric, the end position
##' @param reverse logical, whether a reverse strand
##' @return numeric
##' @author Xiaobei Zhao
bedgraph.to.depth <- function(inFpath,chr,start,end,reverse=FALSE){
  x0 <- read.table(inFpath,header=FALSE)
  x <- x0[as.character(x0[,1])==chr & x0[,2]>=start & x0[,3]<=end, ]
  v <- unlist(mapply(rep,x[,4],x[,3]-x[,2]))
  pos <- unlist(mapply(seq,x[,2]+1,x[,3]))
  ret <- rep(0,end-start)
  names(ret) <- seq(start+1,end)
  ret[as.character(pos)] <- v
  if (reverse) {
    ret <- rev(ret)
  }
  return(ret)
}
#basic finite difference 
# use the numDeriv package
#' Used to extract content from a GET request and collapse to a data.frame
#'
#' @param ... Pass through arguments
#'
#' @return data.frame
GETcontent<-function(...){
  resp<-get(...)
  code<-httr::status_code(resp)
  content<-httr::content(resp ,as="text"
                         ,encoding="utf-8")
  if(code >200) res<-data.frame(name=NA)
  if(code==200) res<-jsonlite::fromJSON(content)
  return(res)
}

get <- ratelimitr::limit_rate(
  httr::GET,
  ratelimitr::rate(n = 1, period = 1.6)
)
put_labels_to_coefficients <-function(beta, labels){
  
  beta_ <- as.data.frame(beta)
  
  names(beta_)<- labels
  
  beta_
}

is_there_parameter <-function(parameters, par_name)
{
  sum(match(names(parameters),par_name,nomatch=0))
}
#define function row.any and col.any
row.any<-function (x)
{
  apply(x, 1, any)
}
row.all<-function (x)
{
  apply(x, 1, all)
}

col.any<-function (x)
{
  apply(x, 2, any)
}
col.all<-function (x)
{
  apply(x, 2, all)
}

remove.na.rows <- function(x)
{
  x[!row.any(is.na(x)),]
}
# Utilities ############################################

# Attribute used while printing the model expression
expr <- function(obj){
  return(attr(obj,'expr'))
}

'expr<-' <- function(obj, value){
  attr(obj,'expr') <- value
  return(obj)
}

latex.tab.content <- function(d){
  nrows <- dim(d)[[1]]
  ncols <- dim(d)[[2]]
  
  
  printRow <- function(rd){
    if(is.na(rd[[1]])){
      row <- ''; 
    }else{        
      row <- paste(rd[[1]])
    }
    for(j in 2:ncols){
      if(is.na(rd[[j]])){
        row <- paste(row,'&')
      }else if(is.numeric(rd[[j]])){
        row <- paste(row,sprintf(' & %.2e',rd[[j]]))
      }else{
        
        row <- paste(row,sprintf(' & %s',rd[[j]]))
      }
    }
    cat(paste(row,' \\\\\n'))
  }
  
  printRow(colnames(d))
  for(i in 1:nrows){
    cat(rownames(d)[[i]],' & ')
    printRow(d[i,])
  }
}




group.by.d_start <- function(d){
  d$d_start <- round(d$d_start,2)
  
  evals <- levels(d$eval_name)  
  
  df <- data.frame(d_start <- unique(d$d_start))
  
  nrows <- dim(df)[[1]]
  for(ev in evals){    
    col <- matrix(0,nrows,1)
    colnames(col) <- ev
    for(row in 1:nrows){
      mask <- (abs(d$d_start - df$d_start[[row]])<0.01 & d$eval_name == ev)      
      col[[row]] <- mean(d$d_stop[mask])      
    }
    
    df <- cbind(df,col)
  }
  
  return(df)
}


group.by.samplesPerDim <- function(d){
  
  evals <- levels(d$eval_name)  
  
  df <- data.frame(SamplesPerDim = unique(d$SamplesPerDim))
  
  nrows <- dim(df)[[1]]
  
  for(ev in evals){    
    col <- matrix(0,nrows,1)
    sdCol <- matrix(0,nrows,1)
    colnames(col) <- ev
    colnames(sdCol) <- paste(ev,'_sd')
    for(row in 1:nrows){
      mask <- (d$SamplesPerDim == df$SamplesPerDim[[row]] & d$eval_name == ev)      
      col[[row]] <- mean(d$d_stop[mask])      
      sdCol[[row]] <- sd(d$d_stop[mask])
    }
    
    df <- cbind(df,col,sdCol)    
  }
  
  return(df)
}
# maps a function and return a named list with the NULL results removed
filter_map <- function(x, f, simplify = FALSE)
    Filter(Negate(is.null), sapply(x, f, simplify = simplify))

# create metadata bundle for images
img_metadata <- function(width, height) {
    if (is.null(width) && is.null(height))
        return(NULL)
    
    metadata <- list()
    if (!is.null(width))  metadata$width  <- width
    if (!is.null(height)) metadata$height <- height
    metadata
}

# add an "isolate" flag to <html>-containing data, or the unchanged metadata
isolate_full_html <- function(data, metadata = NULL) {
    if (!('text/html' %in% names(data)) || !isTRUE(grepl('<html.*>', data[['text/html']], ignore.case = TRUE)))
        return(metadata)
    
    if (is.null(metadata)) metadata <- list()
    if (is.null(metadata[['text/html']])) metadata[['text/html']] <- list()
    
    metadata[['text/html']]$isolated <- TRUE
    metadata
}
#' geomean
#'
#' function for the geometric mean of a vector
#' @param x a numeric vector
#' @keywords internal
geomean <- function(x){
  return(exp(mean(log(x))))
}

#' checkNames
#'
#' checks if elements of namesVector exist in column names of x
#' @param x a dataframe
#' @param namesVector a vector of strings
#' @return a list where the first element is either TRUE if all
#' strings in namesVector exist in the column names of x,
#' otherwise FALSE. If FALSE, then checkNames returns a second
#' element with an error message that contains a list of the
#' names not contained in the column of x.
#' @keywords internal
checkNames <- function(x, namesVector){
  goodNames <- colnames(x)
  badNames <- namesVector[!(namesVector %in% goodNames)]

  if(length(badNames >= 1)){
    err <- paste("The specified name(s) -", paste(badNames, collapse = ", "),
                  "- are not column names of the input data frame. Check the
                 names given to the pvar, qvar, pervar and prodID arguments.")
    return(list(result=FALSE,message=err))
  }
  else {
    return(list(result=TRUE))
  }
}
err <- function(n, maxit) {
  if (n == 0)
    msg <- ""
  if (n < 0) {
    msg <-
      paste(
        "convergence for ",-n, "th lambda value not reached after maxit=",
        maxit, " iterations; solutions for larger lambdas returned",
        sep = ""
      )
    n <- -1
    msg <- paste("From KERE fortran code -", msg)
  }
  list(n = n, msg = msg)
}

cvcompute <- function(mat, foldid, nlams) {
  ###Computes the weighted mean and SD within folds, and
  #   hence
  #   the se of the mean
  nfolds <- max(foldid)
  outmat <- matrix(NA, nfolds, ncol(mat))
  good <- matrix(0, nfolds, ncol(mat))
  mat[is.infinite(mat)] <- NA
  for (i in seq(nfolds)) {
    mati <- mat[foldid == i,]
    outmat[i,] <- apply(mati, 2, mean, na.rm = TRUE)
    good[i, seq(nlams[i])] <- 1
  }
  N <- apply(good, 2, sum)
  list(cvraw = outmat, N = N)
}

ercls <- function(r, omega) {
  abs(omega - (r < 0)) * r ^ 2
}

error.bars <- function(x, upper, lower, width = 0.02,
                       ...) {
  xlim <- range(x)
  barw <- diff(xlim) * width
  segments(x, upper, x, lower, ...)
  segments(x - barw, upper, x + barw, upper, ...)
  segments(x - barw, lower, x + barw, lower, ...)
  range(upper, lower)
}
# Copyright 2012 Jan van der Laan
#
# This file is part of LaF.
#
# LaF is free software: you can redistribute it and/or modify it under the terms
# of the GNU General Public License as published by the Free Software
# Foundation, either version 3 of the License, or (at your option) any later
# version.
#
# LaF is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
# A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along with
# LaF.  If not, see <http://www.gnu.org/licenses/>.

# =============================================================================
# Check if a file can be opened for reading. This function is more robust than
# using file.access.
.file_readable <- function(filename) {
    tryCatch({
            con <- file(filename, "r")
            close(con)
            return(TRUE)
        }, error = function(e) {}, warning = function(w) {})
    return(FALSE)
}
chunkRanges <- function(a, n, i = NULL) {
    if (n > a) {
        stop(paste("Cannot split", a, "into", n, "chunks. Reduce the number of chunks."))
    }
    k <- as.integer(a / n)
    r <- as.integer(a %% n)
    range <- function(i, k, r) {
        c((i - 1L) * k + min(i - 1L, r) + 1L, i * k + min(i, r))
    }
    if (!is.null(i)) {
        range(i, k, r)
    } else {
        sapply(seq_len(n), range, k, r)
    }
}
# Generate an matrix of uniformly distributed values in the interval (0,1) with
# the same dimension as M
randM <- function(M) {
  matrix(stats::runif(prod(dim(M))),
         ncol = ncol(M))
}

# Denormalize population
# X is a matrix of row vectors
denormalize_population <- function(X, problem){
  # Denormalize population
  LL <- matrix(rep(problem$xmin, nrow(X)),
               ncol  = ncol(X),
               byrow = TRUE)
  UL <- matrix(rep(problem$xmax, nrow(X)),
               ncol  = ncol(X),
               byrow = TRUE)
  return(LL + X * (UL - LL))
}



# Check if a numeric value is within certain bounds
is_within <- function(x, xmin = 0, xmax = 1, strict = c(FALSE, FALSE)){
  if(length(strict) == 1) strict <- rep(strict, 2)
  out <- is.numeric(x) &
    ifelse(strict[1],
           all(x >  xmin),
           all(x >= xmin)) &
    ifelse(strict[2],
           all(x <  xmax),
           all(x <= xmax))
  return(out)
}

# Check if two numeric values are coprime
is_coprime <- function(x, y){
  a <- x
  b <- y
  while (b != 0) {
    if (a == 1 || b == 1)
      return(TRUE)
    t <- b
    b <- a %% b
    a <- t
  }
  return(FALSE)
}

# Get estimate of 'ideal' point (minP)
getminP <- function(X){
  apply(X, MARGIN = 2, FUN = min, na.rm = TRUE)
}



# Get estimate of 'nadir' point (maxP)
getmaxP <- function(X){
  apply(X, MARGIN = 2, FUN = max, na.rm = TRUE)
}
printf <- function(msg, ...) { cat(sprintf(msg, ...)) }

`%notin%` <- Negate(`%in%`)

#' Print summary from \code{manifold.optim} results
#'
#' Print results
#' @param x A \code{ManifoldOptim} object output by \code{manifold.optim}.
#' @param ... Not currently used
print.ManifoldOptim <- function(x, ...)
{
	cat("-----", "ManifoldOptim result", "-----\n")
	cat("xopt: <length ", length(x$xopt), ">\n", sep = "")
	cat("fval:", x$fval, "\n")
	cat("normgf:", x$normgf, "\n")
	cat("normgfgf0:", x$normgfgf0, "\n")
	cat("iter:", x$iter, "\n")
	cat("num.obj.eval:", x$num.obj.eval, "\n")
	cat("num.grad.eval:", x$num.grad.eval, "\n")
	cat("nR:", x$nR, "\n")
	cat("nV:", x$nV, "\n")
	cat("nVp:", x$nVp, "\n")
	cat("nH:", x$nH, "\n")
	cat("elapsed:", x$elapsed, "\n")

	if (nchar(x$message) > 0) {
		cat("NOTE:", x$message, "\n")
	}
	# head(x$funSeries)
	# head(x$gradSeries)
	# head(x$timeSeries)

	return(invisible(x))
}

#' Compute the trace of a square matrix
#'
#' @param X A matrix
Trace <- function(X)
{	
	if (!is.matrix(X)) stop("Argument to Trace is not a matrix")
	stopifnot(nrow(X) == ncol(X))
	return(sum(diag(X))) 
}

#' Orthonormalize the columns of a matrix
#'
#' @param u A matrix
orthonorm <- function(u) 
{
	if (is.null(u)) return(NULL)
	if (!(is.matrix(u))) u <- as.matrix(u)
	if (sum(is.nan(u) > 0)) stop("Matrix contains NaNs")
	if (sum(is.na(u) > 0)) stop("Matrix contains NAs")
	dd <- dim(u); n <- dd[1]; p <-dd[2]
	
	if (prod(abs(La.svd(u)$d) > 1e-08) == 0) stop("collinear vectors in orthonorm")
	if (n < p)
	{
		warning("There are too many vectors to orthonormalize in orthonorm.")
		u <- as.matrix(u[, 1:p])
		n <- p
	}
	v <- u
	if (p > 1)
	{
		for (i in 2:p)
		{
			coef.proj <- c(crossprod(u[, i], v[, 1:(i - 1)]))/diag(crossprod(v[, 1:(i - 1)]));
			v[, i] <- u[, i] - matrix(v[, 1:(i - 1)], nrow = n) %*% matrix(coef.proj, nrow = i - 1)
		}
	}
	coef.proj <- 1/sqrt(diag(crossprod(v)))
	return(t(t(v) * coef.proj))
}
#' Pipe operator
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @importFrom magrittr %>%
#' @export
#' @usage lhs \%>\% rhs
NULL


#' Double Pipe operator
#'
#' @name %<>%
#' @rdname doublepipe
#' @keywords internal
#' @importFrom magrittr %<>%
#' @export
#' @usage lhs \%<>\% rhs
NULL

#' with Pipe operator
#'
#' @name %$%
#' @rdname dollarpipe
#' @keywords internal
#' @importFrom magrittr %$%
#' @export
#' @usage lhs \%$\% rhs
NULL

#' findType finds KOs/compounds ID in metabolic graph
#'
#' @param graph graph object
#' @param type either find Cpds or KOs
#'
#' @return vector which nodes are of the certain type
#' @export
findtype <- function(graph, type=c("c", "k")){
    if(type == "c"){
        which(grepl("cpd", V(graph)$name))
    }else{
        which(grepl("ko", V(graph)$name))
    }
}

#' findpython finds the path to the executable
#'
#' Code taken from R package gdata
#'
#' @param python full path to python executable
#' @param verbose print extra information
#' @export
findPython <- function(python, verbose = "FALSE")
{
  errorMsg <- "python executable not found. Use python= argument to specify the correct path."

  if (missing(python))
    {
      python = "python"
    }

  python = Sys.which(python)
  if (python=="" || python=="python")
    stop(errorMsg)

  if (.Platform$OS == "windows") {
    if (length(grep("rtools", tolower(python))) > 0) {
      python.ftype <- shell("ftype python", intern = TRUE)
      if (length(grep("^python=", python.ftype)) > 0) {
        python <- sub('^python="([^"]*)".*', "\\1", python.ftype)
      }
    }
      }

  if (verbose) cat("Using python at", python, "\n")

  python
}
#' Summary function - display head and tail in a single data.frame
#' The original code for this function was first written for 'psych' R package
#' here we have modified it a bit
#' @param x A matrix or data frame or free text
#' @param hlength The number of lines at the beginning to show
#' @param tlength The number of lines at the end to show
#' @param digits Round off the data to digits
#' @param ellipsis separate the head and tail with dots
#' @keywords internal
head_tail <- function(x, hlength = 4, tlength = 4, digits = 4, ellipsis = TRUE){
  if (is.data.frame(x) | is.matrix(x)) {
    if (is.matrix(x)) x = data.frame(unclass(x))
    nvar <- dim(x)[2]
    dots <- rep("...", nvar)
    h    <- data.frame(head(x, hlength))
    t    <- data.frame(tail(x, tlength))
    for (i in 1:nvar) {
      if (is.numeric(h[1, i])) {
        h[i] <- round(h[i], digits)
        t[i] <- round(t[i], digits)
      } else {
        dots[i] <- NA
      }
    }
    out <- if (ellipsis) rbind(h, ... = dots, t) else rbind(h, t)
  } else {
    h <- head(x, hlength)
    t <- tail(x, tlength)
    out <- paste(paste(h, collapse = " "), "...   ...", paste(t, collapse = " "))
  }
  return(out)
}
`.DebugPrint` <-
function (x) {
    if (isTRUE(getOption("debug.MuMIn"))) {
		fun <- asChar(sys.call(sys.parent())[[1L]])
		name <- substitute(x)
		cat(sprintf("<%s> ~ ", fun))
		if(is.language(name)) cat(asChar(name), "= \n")
        print(x)
    }
}
	
`.Debug` <- 
function(expr) {
	if(isTRUE(getOption("debug.MuMIn"))) {
		eval.parent(substitute(expr))
	}
}

`srcc` <- function() {
	ret <- eval(expression(source("clipboard", local = TRUE)), .GlobalEnv)
	return(if(ret$visible) ret$value else invisible(ret$value))
}
# convert list of org.apache.mahout.cf.taste.recommender.RecommendedItem to an R list
.org.apache.mahout.cf.taste.recommender.RecommendedItem_list_to_Rlist <- function(x){  
  listsize <- x$size()  
  result <- list()
  result$items <- numeric(length = listsize)
  result$values <- numeric(length = listsize)
  i <- 0L
  while(i < listsize){
    entry <- x$get(i)    
    result$items[i+1] <- entry$getItemID()
    result$values[i+1] <- entry$getValue()
    i <- i+1L
  }
  result
}
#' util_rescale
#'
#' Linearly rescale element values in a raster to a range between 0 and 1
#'
#' @param x [\code{Raster* object}]
#'
#' @return Raster* object with values ranging from 0-1
#'
#' @details Rasters generated by \code{nlm_*} functions are scaled between 0 and 1 as default, this option can be set to \code{FALSE} if needed.
#'
#' @keywords internal
#'

util_rescale <- function(x) {
  rescaled_NLM <-
    (x - raster::cellStats(x, "min")) /
      (raster::cellStats(x, "max") - raster::cellStats(x, "min"))

  return(rescaled_NLM)
}
### Format and print.

.format_TextDocument <-
function(x, ...)
    c(sprintf("<<%s>>", class(x)[1L]),
      sprintf("Metadata:  %d", length(meta(x))))

.print_via_format <-
function(x, ...) 
{
    writeLines(format(x, ...))
    invisible(x)
}

### Get and set metadata.

.get_meta_if_attr <-
function(x, tag = NULL, ...)
{
    m <- attr(x, "meta")
    if(is.null(tag)) m else m[[tag]]
}

.set_meta_if_attr <-
function(x, tag = NULL, ..., value)    
{
    if(is.null(tag))
        attr(x, "meta") <- value
    else
        attr(x, "meta")[[tag]] <- value
    x
}

.get_meta_if_slot <-
function(x, tag = NULL, ...)
    if(is.null(tag)) x$meta else x$meta[[tag]]

.set_meta_if_slot <-
function(x, tag = NULL, ..., value)
{
    if(is.null(tag))
        x$meta <- value
    else
        x$meta[[tag]] <- value
    x
}
.document_id <-
function(a)
{
    ## Determine the first non-missing id of a document annotation in a,
    ## or the next available id if there if there is no such id.
    id <- a$id[a$type == "document"]
    if(length(id))
        id <- id[!is.na(id)]
    if(length(id))
        id[1L]
    else
        next_id(a$id)
}
#' @title remove whitespace
#' @description remove whitespaces from any data
#' @param x input data
#' @return data without whitespaces
#' @author Sagar Ganapaneni (sagar123)

# define global variables:
utils::globalVariables(c('Distance_data_master', 
                  'TO_Distance', 'TO_id', 'day', 'flag', 
                  'latitude', 'longitude', 'metric', 'state',
                  'value', 'weekStart'))

trim <- function (x) {
  # to avoid scentific notation
  options(scipen = 999)
  gsub("^\\s+|\\s+$", "", x)
}
# TODO: Add comment
# 
# Author: cws
###############################################################################


reset_random_seed <- function(seed){
	if (seed < 0) stop("Seed must be a positive integer")
	.Call("reset_random_seed", seed, PACKAGE = "NetSim")
}

get_random_seed <- function(){
	.Call("get_random_seed", PACKAGE = "NetSim")
}

as.igraph.NetSimNetwork <- function(x, mode = c("directed", "undirected"), ...){
	if (!require(igraph))
		stop("Library igraph needs to be installed. Try 'install.packages(\"igraph\")'")
	iGraph <- igraph::graph.adjacency(as.matrix(x), mode = mode[1], diag = FALSE)
	return(iGraph)
}
# util

my.cov = function(X){
  n = nrow(X)
  stats::cov(X) * (n-1) / n
}

my.scale = function(X){
  n = nrow(X)
  scale(X) / sqrt((n-1) / n)
}

cov.check = function(S){
  # library(lpSolve)
  p = nrow(S)
  result = lpSolve::lp("min", rep(0,p), rbind(S, rep(1,p)), rep("=",p+1), c(rep(0,p),1))
  result
}

ord2num = function(v){ # ordered to numeric matrix
  if(!is.ordered(v)) stop("class not match.")
  n = length(v)
  q = nlevels(v)
  if(q <= 1) stop("too few levels.")
  lv = levels(v)
  Y = matrix(0, n, q-1) # contrast
  for(j in 2:q){
    w = (v == lv[j])
    Y[w,1:(j-1)] = 1
  }
  Y
}

ord.example = function(q, n=NULL){
  f = ordered(1:q)
  if(is.null(n)) return(f)
  f[sample(1:q, n, replace=TRUE)]
}

ogi.numeric = function(X){ # data.frame to matrix
  n = nrow(X)
  p = ncol(X)
  Z = matrix(NA, n, 0)
  idx = numeric(0)
  for(i in 1:p){
    if(is.numeric(X[,i])){
      Z = cbind(Z, X[,i])
      idx = c(idx, i)
      next
    }
    if(is.ordered(X[,i])){
      Y = ord2num(X[,i])
      Z = cbind(Z, Y)
      idx = c(idx, rep(i, ncol(Y)))
      next
    }
    stop("class not match.")
  }
  attr(Z, "index") = idx
  Z
}
## Functions to allow the rest of the functions


## Styles
VersionMajor <- R.Version()$major
VersionMinor <- R.Version()$minor

warningstyle <- crayon::make_style(WarningStyle = rgb(1,0.2,0), bg = FALSE)
errorstyle <- crayon::make_style(ErrorStyle = "red", bg = FALSE)
successstyle <- crayon::make_style(SucessStyle = rgb(0,1,0), bg = FALSE)



##Order your models
OrderModels <- function(summary_table,column, desc=FALSE){

ifelse(desc==TRUE,
         {order_summary <- dplyr::arrange(summary_table, desc(get(column)))},
                        {order_summary <- dplyr::arrange(summary_table, get(column))})
return(order_summary)
}
OrderThresholds <- function(summary_table,column){
  if(length(column)>1){
    column <- "success_rate"
  }
  switch(column,
    "success_rate"= {order_summary <- dplyr::arrange(summary_table, dplyr::desc(get(column)))},
    "error_ti" ={order_summary <- dplyr::arrange(summary_table, get(column))},
    "error_tii" ={order_summary <- dplyr::arrange(summary_table, get(column))}
  )
  return(order_summary)
}

threshold <- function(quantile,y, yhat,categories){

  current_threshold <- min(as.numeric(y)) + (max(as.numeric(y))-min(as.numeric(y)))*quantile

  CutR <- ifelse(yhat >= current_threshold, categories[2], categories[1] )
  mc_threshold <- MC(y=y, yhat =  CutR)
  Success_rate_threshold <- (sum(diag(mc_threshold)))/sum(mc_threshold)
  error_tI_threshold <- sum(mc_threshold[upper.tri(mc_threshold, diag = FALSE)])/sum(mc_threshold)
  error_tII_threshold <- sum(mc_threshold[lower.tri(mc_threshold, diag = FALSE)])/sum(mc_threshold)
  return(list(data.frame(threshold=current_threshold,
                         success_rate=Success_rate_threshold,
                         ti_error=error_tI_threshold,
                         tii_error=error_tII_threshold),mc_threshold))
}
# Singular Value Decomposition of a Matrix
svd.triplet<-function (X, row.w = NULL, col.w = NULL, ncp = Inf) 
{
  if (is.null(row.w)) 
    row.w <- rep(1/nrow(X), nrow(X))
  if (is.null(col.w)) 
    col.w <- rep(1, ncol(X))
  ncp <- min(ncp, nrow(X) - 1, ncol(X))
  row.w = row.w/sum(row.w)
  X = sweep(X, 2, sqrt(col.w), FUN = "*")
  X = sweep(X, 1, sqrt(row.w), FUN = "*")
  if (ncol(X) < nrow(X)) {
    svd.usuelle <- svd(X)
    U <- svd.usuelle$u[, 1:ncp, drop = FALSE]
    V <- svd.usuelle$v[, 1:ncp, drop = FALSE]
    if (ncp > 1) {
      mult <- sign(apply(V, 2, sum))
      mult[mult == 0] <- 1
      U <- sweep(U, 2, mult, FUN = "*")
      V <- sweep(V, 2, mult, FUN = "*")
    }
    U <- sweep(as.matrix(U), 1, sqrt(row.w), FUN = "/")
    V <- sweep(as.matrix(V), 1, sqrt(col.w), FUN = "/")
  }
  else {
    svd.usuelle <- svd(t(X))
    U <- svd.usuelle$v[, 1:ncp, drop = FALSE]
    V <- svd.usuelle$u[, 1:ncp, drop = FALSE]
    mult <- sign(apply(V, 2, sum))
    mult[mult == 0] <- 1
    V <- sweep(V, 2, mult, FUN = "*")
    U <- sweep(U, 2, mult, FUN = "*")
    U <- sweep(U, 1, sqrt(row.w), FUN = "/")
    V <- sweep(V, 1, sqrt(col.w), FUN = "/")
  }
  vs <- svd.usuelle$d[1:min(ncol(X), nrow(X) - 1)]
  num <- which(vs[1:ncp] < 1e-15)
  if (length(num) == 1) {
    U[, num] <- U[, num] * vs[num]
    V[, num] <- V[, num] * vs[num]
  }
  if (length(num) > 1) {
    U[, num] <- sweep(U[, num], 2, vs[num], FUN = "*")
    V[, num] <- sweep(V[, num], 2, vs[num], FUN = "*")
  }
  res <- list(vs = vs, U = U, V = V)
  return(res)
}

# Returns the number of levels of a factor.
nb.level<-function(fact){
  return(length(levels(factor(fact))))
}
#' detect if a filepath is for a directory
#' @param x vector of file paths
#' @export
is_dir <- function(x) {
  isTRUE(file.info(x)$isdir)
}

#' get the basename of a filepath, minus any extensions
#' @param .x filepath
#' @export
#' @rdname basename_sans_ext
#' @importFrom tools file_path_sans_ext
basename_sans_ext <- function(.x) {
  basename(file_path_sans_ext(.x))
}
#' Pipe operator
#'
#' See \code{magrittr::\link[magrittr]{\%>\%}} for details.
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @export
#' @importFrom magrittr %>%
#' @usage lhs \%>\% rhs
NULL
## -----------------------------------------------------------------------
## print formating
## -----------------------------------------------------------------------

## maximum string width in a vector strings
.max.width <- function (strvec)
{
    smax <- 0
    for (i in strvec)
        if (nchar(i) > smax)
            smax <- nchar(i)
    smax
}

## -----------------------------------------------------------------------

## print a number of white spaces
.print.spaces <- function (n = 1)
{
    for (i in seq_len(n)) cat(" ")
}

## -----------------------------------------------------------------------

## generate sort and sort.str
.generate.sort <- function (x)
{
    if (is(x, "db.data.frame")) {
        sort <- list(by = "", order = "", str = "")
    } else {
        sort <- x@.sort
    }
    ## if (sort$by != "")
    ##     sort.str <- paste(" order by ",
    ##                       paste("\"", sort$by, "\"",
    ##                             collapse = ", ", sep = ""),
    ##                       sort$order, sep = "")
    ## else
    ##     sort.str <- ""
    sort
}
#' Combine objects created by optimize.portfolio
#' 
#' This function takes a list of objects created by \code{\link{optimize.portfolio}}
#' and sets the class name attribute to 'opt.list' for use in generic functions
#' 
#' @param x a list of objects created by \code{\link{optimize.portfolio}}
#' @return an \code{opt.list} object
#' @export
combine.optimizations <- function(x){
  if(!is.list(x)) stop("x must be passed in as a list")
  for(i in 1:length(x)){
    if(!(inherits(x[[i]], "optimize.portfolio") | inherits(x[[i]], "optimize.portfolio.rebalancing"))){
      stop("All objects in x must be of class 'optimize.portfolio' or 'optimize.portfolio.rebalancing'")
    }
  }
  class(x) <- "opt.list"
  return(x)
}

#' Combine a list of portfolio objects
#' 
#' This function takes a list of objects created by \code{\link{portfolio.spec}}
#' and sets the class name attribute to 'portfolio.list' for use in generic functions
#' 
#' @param x a list of objects created by \code{\link{portfolio.spec}}
#' @return a \code{portfolio.list} object
#' @export
combine.portfolios <- function(x){
  if(!is.list(x)) stop("x must be passed in as a list")
  for(i in 1:length(x)){
    if(!inherits(x[[i]], "portfolio")) stop("All objects in x must be of class 'portfolio'")
  }
  class(x) <- c("portfolio.list", "portfolio")
  return(x)
}


###############################################################################
# R (http://r-project.org/) Numeric Methods for Optimization of Portfolios
#
# Copyright (c) 2004-2015 Brian G. Peterson, Peter Carl, Ross Bennett, Kris Boudt
#
# This library is distributed under the terms of the GNU Public License (GPL)
# for full details see the file COPYING
#
# $Id: utility.combine.R 3581 2015-01-07 13:12:49Z braverock $
#
###############################################################################
# funcao de verossimilhanca

lv_pn <- function(A,x){
  E <- 0; S <- 1;
  n <- length(x) ; z <- (x-E)/S
  n*(log(A)-log(S)-.5*log(2*pi))-.5*sum(z^2)+(A-1)*sum(log(pnorm(z)))
}



# funcao de densidade dpn
pn.d <- function(x, alpha ){
  sigma<- 1
  mu <- 0
  (alpha/sigma)*dnorm((x-mu)/sigma,0,1)*(pnorm((x-mu)/sigma,0,1))^(alpha-1)
}
##function to convert a graphNEL object to an igraph
##g: The graphNEL object to be converted
##keep.weights: a flag to indicate whether weights should be considered when performing the conversion (DEFAULT= FALSE)
.G2IG <- function(g, keep.weights=FALSE){
 if(any(unlist(edgeWeights(g))>1) & keep.weights)
    warning("When using this conversion the edge weight information will be ignored")
 ig <- igraph::igraph.from.graphNEL(g, weight = keep.weights)
 return(ig)
}

##helper function to check whether a graph is unweighted and undirected
##this mode is currently the only one supported by QuACN
.validateGraph <- function(g){
  return(!edgemode(g)=="directed" & !any(unlist(edgeWeights(g))>1))
}
nullfile <- function() {
  switch(.Platform$OS.type,
    windows="NUL",
    "/dev/null"
  )
}
## Using the following non-exported functions from 'tools':
##  * .get_vignette_metadata()
##  * vignette_is_tex()
##  * find_vignette_product()
import_tools <- function(name, mode = "function",
                         envir = getNamespace("tools")) {
  get(name, mode = mode, envir = envir)
}
fround <- function (x, digits) {
    format (round (x, digits), nsmall=digits)
}
  
pfround <- function (x, digits) {
    print (fround (x, digits), quote=FALSE)
}
 

m <- NULL

repath <- function(x) {
  n.part <- length(x[[1]])
  temp <- rep(NA, n.part)
  for (i in 1:n.part){
    if (nchar(x[[1]][i])> 8){
      temp[i] <- paste(substr(x[[1]][i], 1, 6), "~1/", sep="")
    }
    if (nchar(x[[1]][i])<=8){
      temp[i] <- paste(x[[1]][i],"/", sep="")
    }
  }
  return(temp)
}
    

win2unixdir <- function(windir){
  Dir <- substr(windir, 1, 3)
  tempdir <- substr(windir, 4, 1000)
  tempdir <- gsub(" ", "", tempdir)
  tempdir <- strsplit(tempdir, "/")
  n.part <- length(tempdir[[1]])
  if (n.part>0){
    tempdir <- repath(tempdir)
    path <- ""
    for (i in 1:n.part){
      path <- paste(path, tempdir[i], sep="")
    }
    newpath <- paste(Dir, path, sep="")
  }
  else {
    newpath <- Dir
  }
  return(c(newpath))
}


read.jagsdata <- function(file)
{
  e <- new.env()
  eval(parse(file), e)
  return(as.list(e))
}
encapsulate({
  # Given two named vectors, join them together, and keep only the last element
  # with a given name in the resulting vector. If b has any elements with the
  # same name as elements in a, the element in a is dropped. Also, if there are
  # any duplicated names in a or b, only the last one with that name is kept.
  merge_vectors <- function(a, b) {
    if ((!is.null(a) && length(a) > 1 && is.null(names(a))) ||
        (!is.null(b) && length(b) > 1 && is.null(names(b)))) {
      stop("merge_vectors: vectors must be either NULL or named vectors")
    }

    x <- c(a, b)
    drop_idx <- duplicated(names(x), fromLast = TRUE)
    x[!drop_idx]
  }

  # Check that all elements of a list are named.
  # NULL and empty lists return TRUE.
  all_named <- function(x) {
    if (length(names(x)) != length(x) || any(names(x) == "")) {
      return(FALSE)
    }
    TRUE
  }

  # Return all the functions in a list.
  get_functions <- function(x) {
    funcs <- vapply(x, is.function, logical(1))
    if (all(!funcs)) return(NULL)
    x[funcs]
  }

  # Return all the non-functions in a list.
  get_nonfunctions <- function(x) {
    funcs <- vapply(x, is.function, logical(1))
    if (all(funcs)) return(NULL)
    x[!funcs]
  }
})
RAM.pal <- function(cols.needed=20) {
  # color palette total of 40
  col.pal <- c(RColorBrewer::brewer.pal(12, "Set3"), RColorBrewer::brewer.pal(8, "Accent"), .ram.pal(20))
    
  if (cols.needed <= 40  ) {
    # need to manually construct a palette to use
    col.func <- function(n){col.pal[1:n]}
    values=col.func(cols.needed)
  } else {
    col.func  <-  grDevices::colorRampPalette(col.pal)
    values=col.func(cols.needed)
  }
  return(values)
}
#' converts to character with minimal loss of precision for numeric variables
#' @param x the value
#' @param ... passed to either format or as.character.
#' @export
as.char <- function(x,...){
  if(is.numeric(x))
    if(is.integer(x))
      ifelse(is.na(x),NA,format(x,trim=TRUE,scientific=FALSE,...))
  else
    ifelse(is.na(x),NA,format(x,trim=TRUE,scientific=FALSE,digits=15,...))
  else
    as.character(x,...)
}


orWaldCI <- function(tables, alpha = 0.05){
  # a = extract.counts(tables[[1]])
  a = tables[[1]][[1]]$table
  n00 = a[1,1]
  n01 = a[1,2]
  n10 = a[2,1]
  n11 = a[2,2]
  #
  #  Compute the odds ratio between two binary variables, x and y,
  #  as defined by the four numbers nij:
  #
  #    n00 = number of cases where x = 0 and y = 0
  #    n01 = number of cases where x = 0 and y = 1
  #    n10 = number of cases where x = 1 and y = 0
  #    n11 = number of cases where x = 1 and y = 1
  #
  OR <- (n00 * n11)/(n01 * n10)
  #
  #  Compute the Wald confidence intervals:
  #
  siglog <- sqrt((1/n00) + (1/n01) + (1/n10) + (1/n11))
  zalph <- qnorm(1 - alpha/2)
  logOR <- log(OR)
  loglo <- logOR - zalph * siglog
  loghi <- logOR + zalph * siglog
  #
  ORlo <- exp(loglo)
  ORhi <- exp(loghi)
  #
  # oframe <- data.frame(LowerCI = ORlo, OR = OR, UpperCI = ORhi, alpha = alpha)
  cat(sprintf("The odds ratio is %f. A 95%% confidence interval is (%f, %f).\n",
              OR,ORlo,ORhi))
  invisible()
}

.catchToList <- function(expr) {
  val <- NULL
  myWarnings <- NULL
  wHandler <- function(w) {
    myWarnings <<- c(myWarnings, w$message)
    invokeRestart("muffleWarning")
  }
  myError <- NULL
  eHandler <- function(e) {
    myError <<- e$message
    NULL
  }
  val <- tryCatch(withCallingHandlers(expr, warning = wHandler), error = eHandler)
  list(value = val, warnings = myWarnings, error=myError)
} 



.cut2 <- function(x, g){
  uni <- unique(x)
  if(length(uni) <= g)
    return(factor(x))
  else
    return(Hmisc::cut2(x, g=g))
}
#' @name replace_nas_with_explicit
## I'm intentionally not exporting this function.
#'
#' @title Create explicit factor level for missing values.
#'
#' @description Missing values are converted to a factor level.  This explicit assignment can reduce the chances that missing values are inadvertently ignored.  
#' It also allows the presence of a missing to become a predictor in models.
#'
#' @param scores An array of values, ideally either factor or character. Required
#' @param new_na_label The factor label assigned to the missing value.  Defaults to `Unknown`.
#' @param create_factor Converts `scores` into a factor, if it isn't one already.   Defaults to `FALSE`.
#' @param add_unknown_level Should a new factor level be created?  (Specify `TRUE` if it already exists.)   Defaults to `FALSE`.
#'
#' @return An array of values, where the `NA` values are now a factor level, with the label specified by the `new_na_label` value.
#'
#' @note
#' The `create_factor` parameter is respected only if `scores` isn't already a factor.  Otherwise, levels without any values would be lost.
#'
#' A `stop` error will be thrown if the operation fails to convert all the `NA` values.
#'
#' @author Will Beasley
#'
#' @examples
#' library(REDCapR) #Load the package into the current R session.

replace_nas_with_explicit <- function( scores, new_na_label="Unknown", create_factor=FALSE, add_unknown_level=FALSE) {

  if( create_factor & !is.factor(scores) ) {
    scores <- factor(scores)
  }

  if( add_unknown_level ) {
    if( !is.factor(scores) )
      stop("The `replace_nas_with_explicit()` function cannot add a level to `scores` when it is not a factor.  Consider setting `create_factor=TRUE`.")

    levels(scores) <- c(levels(scores), new_na_label)  #Add a new level called 'Unknown'
  }

  scores[is.na(scores)] <- new_na_label #"Unknown"

  if( any(is.na(scores)) )
    stop("The reassigned factor variable should not have any NA values.")

  return( scores )
}
#' Convert character strings to factors in a dataset
#'
#' Convert character strings to factors in a dataset
#'
#' @param x object of class data.frame
#' @param ... other parameters currently not used yet
#' @return a data.frame with the information in \code{x} where character columns are converted to factors
#' @export 
#' @examples
#' data(iris)
#' str(iris)
#' mydata <- factorise(iris)
#' str(mydata)
factorise <- function(x, ...){
  UseMethod(generic="factorise", object=x)
}

##' @S3method factorise data.frame
factorise.data.frame <- function(x, ...){  
  if(inherits(x, "data.frame")){
    tofactor <- sapply(x, FUN=function(x) inherits(x, "character"))
    tofactor <- tofactor[tofactor == TRUE]
    if(length(tofactor) == 0){
      return(x)
    }
  }
  x <- unclass(x)
  x <- as.data.frame(x, stringsAsFactors=TRUE)
  x
}



recoder <- function (x, from = c(), to = c()) {
  missing.levels <- unique(x)
  missing.levels <- missing.levels[!missing.levels %in% from]
  if (length(missing.levels) > 0) {
    from <- append(x = from, values = missing.levels)
    to <- append(x = to, values = missing.levels)
  }
  to[match(x, from)]
}
vlapply <- function(X, FUN, ..., USE.NAMES = TRUE) {
  vapply(X = X, FUN = FUN, FUN.VALUE = logical(1L), ..., USE.NAMES = USE.NAMES)
}

vcapply <- function(X, FUN, ..., USE.NAMES = TRUE) {
  vapply(X = X, FUN = FUN, FUN.VALUE = character(1L), ..., USE.NAMES = USE.NAMES)
}

stopc <- function(...) {
  stop(..., call. = FALSE, domain = NA)
}

warningc <- function(...) {
  warning(..., call. = FALSE, domain = NA)
}
empty_list_check <- function(x) {
    if (length(x) == 0 & is.list(x)) {
        return(NA)
    } else if (length(x) > 1) {
        return(paste(x, collapse = ","))
    } else {
        return(x)
    }
}
vlapply <- function(X, FUN, ..., USE.NAMES = TRUE) {
  vapply(X = X, FUN = FUN, FUN.VALUE = logical(1L), ..., USE.NAMES = USE.NAMES)
}

viapply <- function(X, FUN, ..., USE.NAMES = TRUE) {
  vapply(X = X, FUN = FUN, FUN.VALUE = integer(1L), ..., USE.NAMES = USE.NAMES)
}

vcapply <- function(X, FUN, ..., USE.NAMES = TRUE) {
  vapply(X = X, FUN = FUN, FUN.VALUE = character(1L), ..., USE.NAMES = USE.NAMES)
}

stopc <- function(...) {
  stop(..., call. = FALSE, domain = NA)
}

warningc <- function(...) {
  warning(..., call. = FALSE, domain = NA)
}

is_whole_number_vector <- function(x) {
  if (!is.numeric(x)) return(FALSE)
  is_value <- which(!is.na(x))
  isTRUE(all.equal(x[is_value] - trunc(x[is_value]), rep_len(0, length(is_value))))
}
vlapply <- function(X, FUN, ..., USE.NAMES = TRUE) {
  vapply(X = X, FUN = FUN, FUN.VALUE = logical(1L), ..., USE.NAMES = USE.NAMES)
}

viapply <- function(X, FUN, ..., USE.NAMES = TRUE) {
  vapply(X = X, FUN = FUN, FUN.VALUE = integer(1L), ..., USE.NAMES = USE.NAMES)
}

vcapply <- function(X, FUN, ..., USE.NAMES = TRUE) {
  vapply(X = X, FUN = FUN, FUN.VALUE = character(1L), ..., USE.NAMES = USE.NAMES)
}

stopc <- function(...) {
  stop(..., call. = FALSE, domain = NA)
}

warningc <- function(...) {
  warning(..., call. = FALSE, domain = NA)
}

is_whole_number_vector <- function(x) {
  if (!is.numeric(x)) return(FALSE)
  is_value <- which(!is.na(x))
  isTRUE(all.equal(x[is_value] - trunc(x[is_value]), rep_len(0, length(is_value))))
}
# Copyright (c) 2015-present, Facebook, Inc.
# All rights reserved.
#
# This source code is licensed under the BSD-style license found in the
# LICENSE file in the root directory of this source tree. An additional grant
# of patent rights can be found in the PATENTS file in the same directory.

check.status.code <- function(response) {
  status <- httr::status_code(response)
  if (status >= 400 && status < 500) {
    text.content <- httr::content(response, as = "text", encoding='UTF-8')
    if (is.null(text.content) || !nzchar(text.content)) {
      httr::stop_for_status(status)
    }
    stop('Received error response (HTTP ', status, '): ', text.content)
  }
}

response.to.content <- function (response)  {
  text.content <- httr::content(response, as = "text", encoding='UTF-8')
  return(jsonlite::fromJSON(text.content, simplifyVector = FALSE))
}

wait <- function () {
  # sleep 50 - 100 ms
  Sys.sleep(stats::runif(n = 1, min = 50, max = 100) / 1000)
}

get.state <- function (content) {
  if (is.null(content[['stats']])
      || is.null(content[['stats']][['state']])
  ) {
    stop('No state information in content')
  }
  return(content[['stats']][['state']])
}

stop.with.error.message <- function (content) {
  query.id <- content[['id']]
  message <- content[['error']][['message']]
  stop("Query ", query.id, " failed: ", message)
}
vlapply <- function(X, FUN, ..., USE.NAMES = TRUE) {
  vapply(X = X, FUN = FUN, FUN.VALUE = logical(1L), ..., USE.NAMES = USE.NAMES)
}

vcapply <- function(X, FUN, ..., USE.NAMES = TRUE) {
  vapply(X = X, FUN = FUN, FUN.VALUE = character(1L), ..., USE.NAMES = USE.NAMES)
}

stopc <- function(...) {
  stop(..., call. = FALSE, domain = NA)
}

warningc <- function(...) {
  warning(..., call. = FALSE, domain = NA)
}

#' @importFrom memoise memoise
warning_once <- memoise(warningc)
#' @export
print.account <- function(x, ...){
  cat("Sauce Labs Account:\n")
  cat("SauceLabs username:", strsplit(x[["request"]]$options$userpwd, ":")[[1]][1], "\n")
}
#############################################################################
#   Copyright (c) 2014 Christophe Dutang
#
#   This program is free software; you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation; either version 2 of the License, or
#   (at your option) any later version.
#
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with this program; if not, write to the
#   Free Software Foundation, Inc.,
#   59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
#
#############################################################################


summary2 <- function(x, na.rm=FALSE)
{
    if(length(x) <= 5)
        return(x)
    else
        return(summary(x, na.rm=na.rm))
}


summary3 <- function(x, na.rm=FALSE)
{
    c(quantile(x), mean=mean(x))
}
#' Unlist is the same as unlist, but doesn't recurse all the way to
#' preserve the type. This function is not well optimised.
#' 
#' @param obj is a list to be flatten
#' @importFrom methods is
Unlist <- function(obj) {
  ret <- list()
  for (i in seq_along(obj)) {
    if (is(obj[[i]], "list") &&
        is.null(names(obj[[i]]))) {
      ret <- append(ret, Unlist(obj[[i]]))
    } else {
      ret <- append(ret, obj[i])
    }
  }
  ret
}
.getImageDistr <- function(f, distr){ 
    if (is(distr, "DiscreteDistribution"))
        return(DiscreteDistribution(prob=d(distr)(support(distr)), supp=f(support(distr))))
    if(is(try(return(f(distr)), silent = TRUE), "try-error")){
        rl <- function(n){ 
            xr <- r(distr)(n) 
            f(xr) 
        }

        n <- 10^getdistrOption("RtoDPQ.e")+1
        u <- seq(0,1,length=n+1); u <- (u[1:n]+u[2:(n+1)])/2
        qd <- q(distr)
        y <- f(qd(u))
    
        wmdn <- getdistrOption("warn.makeDNew")
        on.exit(distroptions(warn.makeDNew=wmdn))
        distroptions(warn.makeDNew=FALSE)
        
        if(length(unique(c(rl(10000),y)))==10000+length(y)){
           DPQnew <- RtoDPQ(r=rl, y=y)
           return(AbscontDistribution(r = rl, d = DPQnew$d, p = DPQnew$p, 
                                      q = DPQnew$q, .withArith = TRUE, 
                                      .withSim = TRUE, withgaps = FALSE))
        
        }else
           return(UnivarLebDecDistribution(r = rl, y = y))
    }
}
#' A \code{gettextRcmdr} Wrapper Function
#'
#' This function is a \code{gettextRcmdr} wrapper function for this package.
#'
#' @param ... arguments passed to gettext function
#' @seealso \code{\link[Rcmdr:Rcmdr.Utilities]{Rcmdr.Utilities}}
#'
#' @rdname util-gettextKmg2
#' @keywords documentation
#' @export
gettextKmg2 <- function(...) {

  gettext(..., domain = "R-RcmdrPlugin.KMggplot2")

}
#' Select Non Factor Variables
#'
#' This is a function to select non-factor variables for the \code{Rcmdr} package.
#'
#' @seealso \code{\link[Rcmdr:Rcmdr.Utilities]{Rcmdr.Utilities}}
#'
#' @rdname util-nonFactors
#' @keywords hplot
#' @export
nonFactors <- function() {

  setdiff(Variables(), Factors())

}



#' Check Non Factor Variables in The Active Dataset
#'
#' This is a function to check the active dataset has more than or equal to \code{n} non-factor variables.
#'
#' @param n Numeric: the target number of \code{n}.
#' @return
#' \describe{
#' \item{result}{Boolean; the active dataset has or does not have more than or equal to \code{n} non-factor variables.}
#' }
#' @seealso \code{\link[Rcmdr:Rcmdr.Utilities]{Rcmdr.Utilities}}
#'
#' @rdname util-nonFactorsP
#' @keywords hplot
#' @export
nonFactorsP <- function (n = 1) {

  activeDataSetP() && length(setdiff(listVariables(), listFactors())) >= n

}
#' Listing the last command
#'
#' This function lists the last command is executed by \code{RcmdrPlugin.KMggplot2}
#'
#' @rdname util-lastcom
#' @keywords documentation
#' @export
lastcom <- function() {
  
  if (exists(".lastcom", envir = .GlobalEnv)){
    cat(get(".lastcom", envir = .GlobalEnv))
  } else {
    stop("object '.lastcom' not found")
  }
  
}
## We would like to do this at the C++ level too, alas file-system operations
## are still very dependent on the operating system.  C++17 is going to help,
## but it is not yet widely enough available (and certainly not on CRAN anytime
## soon). Boost has functions in its filesystem module, but those require
## linking with the system and filesystem libraries so they cannot be used in
## header-only mode from BH

.checkPath <- function(filename) dir.exists(dirname(filename))
#' @title Strip white space
#' @description Strip white space (spaces only) from the beginning and end of a character.
#' @param x character to strip white space from
#' @return a character with white space stripped
stripWhite <- function(x) {
	sub('([ ]+$)', '', sub("(^[ ]+)", '', x, perl=TRUE), perl=TRUE)
}

#' @title Extract Rd tags
#' @description Extract Rd tags from Rd object
#' @param Rd Object of class \code{Rd}
#' @return character vector with Rd tags
RdTags = function(Rd) {
  res <- sapply(Rd, attr, "Rd_tag")
  if (!length(res)) 
    res <- character()
  res
}

#' @title Make first letter capital
#' @description Capitalize the first letter of every new word. Very simplistic approach.
#' @param x Character string
#' @return character vector with capitalized first letters
simpleCap <- function(x) {
	s <- strsplit(x, " ")[[1]]
	paste(toupper(substring(s, 1,1)), substring(s, 2), sep="", collapse=" ")
}
# utility function for combining two fgh lists by adding their
# corresponding elements; useful for adding log-prior and log-likelihood
regfac.merge <- function(fgh1, fgh2, fgh=2) {
  if (fgh==0) return (fgh1+fgh2)
  return (list(f=fgh1$f+fgh2$f, g=fgh1$g+fgh2$g, h=fgh1$h+fgh2$h))
}
is_windows <- function() {
  identical(.Platform$OS.type, "windows")
}

is_osx <- function() {
  Sys.info()["sysname"] == "Darwin"
}

is_linux <- function() {
  identical(tolower(Sys.info()[["sysname"]]), "linux")
}

mecab_installed <- function() {
  mecabLibs <- getOption("mecab.libpath")
  
  if (is_windows() && mecabLibs != "") {
    file.exists(file.path(mecabLibs, "mecab.exe"))
  } else {
    return(FALSE)
  }
}

check_input <- function(x) {
  check_character <- is.character(x) |
    if (is.list(x)) {
      check_list <- all(vapply(x, is.character, logical(1))) &
        all(vapply(x, length, integer(1)) == 1L)
    } else {
      check_list <- FALSE
    }
  if (!(check_character | check_list))
    stop("Input must be a character vector of any length or a list of character\n",
         "  vectors, each of which has a length of 1.")
}
.eq <-function(x,y = 0*x, tol = 1e-7) abs(x-y)<tol

.getDistr <- function(L2Fam){
        slots <- slotNames(L2Fam@distribution@param)
        slots <- slots[slots != "name"]
        nrvalues <- length(slots)
        if (nrvalues > 0) {
            values <- numeric(nrvalues)
            for (i in 1:nrvalues) 
                values[i] <- attributes(attributes(L2Fam@distribution)$param)[[slots[i]]]

            paramstring <- paste("(", paste(values, collapse = ", "), ")", sep = "")
        }else{
            paramstring <- NULL
        }
        distr <- paste(class(L2Fam@distribution)[1], paramstring, sep = "")
}
#' detect file encoding for inputted file 
#' @param file to read from, or a \code{\link{connection}} which will be opened if necessary, and if so closed at the end of the function call.
#' @param n integer. The (maximal) number of lines to read. Negative values indicate that one should read up to the end of input on the connection.
#' @param default default encoding if fail to expect.
#' @return encoding name
#' @examples 
#' big5encfile <- file.path(system.file(package="Ruchardet"),"tests","big5.txt") 
#' detectFileEncoding(big5encfile) 
#' \dontrun{
#' detectFileEncoding("http://www.ppomppu.co.kr/")
#' detectFileEncoding("http://freesearch.pe.kr")
#' }
#' @export 
detectFileEncoding <- function(file, n=-1, default=getOption("encoding")){

  if (is.character(file)) {
      file <- file(file, "rt")
      on.exit(close(file))
  }
  if (!inherits(file, "connection")) 
      stop("'file' must be a character string or connection")
  if (!isOpen(file, "rt")) {
      open(file, "rt")
      on.exit(close(file))
  }
  encs <- detectEncoding(paste0(readLines(file, warn=FALSE, n=n),collapse=""))
  if(encs == ''){
    warning("can't expect encoding, will return 'default' encoding")
    encs <- default
  }
  return(encs)
}
#############################################################################
##
##  Utility functions
##
#############################################################################

## --------------------------------------------------------------------------
## Copies from non-exported functions in utils-3.4.1
##

my.getHelpFile <- function (file) 
{
    path <- dirname(file)
    dirpath <- dirname(path)
    if (!file.exists(dirpath)) 
        stop(gettextf("invalid %s argument", sQuote("file")), 
             domain = NA)
    pkgname <- basename(dirpath)
    RdDB <- file.path(path, pkgname)
    if (!file.exists(paste0(RdDB, ".rdx"))) 
        stop(gettextf("package %s exists but was not installed under R >= 2.10.0 so help cannot be accessed", 
                      sQuote(pkgname)), domain = NA)
    my.fetchRdDB(RdDB, basename(file))
}

my.fetchRdDB <- function (filebase, key = NULL) 
{
    fun <- function(db) {
        vals <- db$vals
        vars <- db$vars
        datafile <- db$datafile
        compressed <- db$compressed
        envhook <- db$envhook
        fetch <- function(key) lazyLoadDBfetch(vals[key][[1L]], 
                                               datafile, compressed, envhook)
        if (length(key)) {
            if (!key %in% vars) 
                stop(gettextf("No help on %s found in RdDB %s", 
                              sQuote(key), sQuote(filebase)), domain = NA)
            fetch(key)
        }
        else {
            res <- lapply(vars, fetch)
            names(res) <- vars
            res
        }
    }
    res <- lazyLoadDBexec(filebase, fun)
    if (length(key)) 
        res
    else invisible(res)
}

# ---------------------------------------------------------------------------
# weighted scale functions
# @param x vector to scale
# @param w weight
# @return scaled vector
wtScale <-function(x,w) {
  xc=x-sum(w*x)
  v=sum(xc^2*w)
  xcr=xc/sqrt(v)
  return(xcr)                                   
}

# utils functions
# @param x vector to center
# @param w weight
# @return centered vector
wtCenter=function(x,w) {
  xc=x-sum(w*x)
  return(xc)
}

checkLossFunction <- function(type) {
  if(!type %in% c("auc","likelihood","aic","aicc","bic","mspe"))
    stop("Unknown loss function!")
}

# returns string w/o leading or trailing whitespace
trim <- function (x) gsub("^\\s+|\\s+$", "", x)
# Compute the usual unbiased estimate of the variance in a linear model.
estimate_noise <- function(X, y, intercept = TRUE) {
  n = nrow(X)
  if (intercept)
    X = cbind(rep(1,n), X)
  p = ncol(X)
  stopifnot(n > p)

  fit = lm.fit(X, y)
  sqrt(sum(fit$residuals^2) / (n-p))
}

# A variant of the built-in function 'scale' that using L2-normalization for
# the scaling.
normalize <- function(X, center = TRUE, scale = TRUE) {
  X = as.matrix(X)
  if (center) {
    means = colMeans(X, na.rm = TRUE)
    X = sweep(X, 2, means)
  }
  if (scale) {
    scales = apply(X, 2, function (x) sqrt(sum(x^2)))
    X = sweep(X, 2, scales, "/")
  }
  X
}

# Generate a random synthetic model and data. Used for testing.
random_problem <- function(n, p, k=NULL, amplitude=3, sigma=1) {
  if (is.null(k))
    k = max(1, as.integer(p/5))

  X = matrix(rnorm(n*p), n, p)
  nonzero = sample(p, k)
  beta = amplitude * (1:p %in% nonzero)
  y = X %*% beta + rnorm(n, sd = sigma)
  list(X = X, y = y, beta = beta)
}

# Evaluate an expression with the given random seed, then restore the old seed.
with_seed <- function(seed, expr) {
  seed.old <- if (exists('.Random.seed')) .Random.seed else NULL
  set.seed(seed)
  on.exit({
    if (is.null(seed.old)) {
      if (exists('.Random.seed'))
        rm(.Random.seed, envir=.GlobalEnv)
    } else {
      .Random.seed <<- seed.old
    }
  })
  expr
}
# From SamplerCompare, (c) 2010 Madeleine Thompson

# util.R is a place where assorted utility functions find a home.

# Not currently used; draws n rows uniformly from the unit sphere in R^p.
# Read http://en.wikipedia.org/wiki/Hypersphere for more.

rsphere <- function(n,p) {
  r <- runif(n)^(1/p)
  x <- array(rnorm(n*p), c(n,p))
  x <- x / sqrt(rowSums(x^2)) * r
  return(x)
}

# Sooner or later, every program I write gets a logsumexp function.
# Sometimes two.

logsumexp <- function(x) {
  m <- max(x)
  if (is.na(m) || m==-Inf)
    return(m)
  return(m+log(sum(exp(x-m))))
}

# Returns the two-norm of the argument vector.  Another function I
# use all the time.

twonorm <- function(x) sqrt(sum(x^2))
# return a character vector of functions defined in .GlobalEnv
parent_env_fun <- function(){
    nms <- ls(envir = parent.frame(2L))
    is_fun <- sapply(nms, function(x, envir) is.function(get(x, envir=envir)),
                     envir = parent.frame(2L))
    return(nms[is_fun])
}

load_packages <- function(packages){
    if(!is.null(packages))
        for(pack in packages)
            library(substitute(pack), character.only = TRUE)
    invisible()
}

get_packages <- function(packages){
    sapply(packages, function(x) as.character(packageVersion(x)))
}

# base-code borrowed and modified from pbapply
timeFormater <- function(time, decimals = TRUE){
    dec <- time - floor(time)
    time <- floor(time - dec)
    dec <- round(dec, 2)
    sec <- round(time %% 60)
    if(decimals) sec <- sec + dec
    time <- floor(time / 60)
    minutes <- floor(time %% 60)
    time <- floor(time / 60)
    days <- floor(time / 24)
    time <- floor(time %% 24)
    hours <- floor(time %% 60)
    resTime <- ""
    if (days > 0)
        resTime <- sprintf("%02id ", days)
    if (hours > 0 || days > 0)
        resTime <- paste(resTime, sprintf("%02ih ", hours), sep = "")
    if (minutes > 0 || hours > 0 || days > 0)
        resTime <- paste(resTime, sprintf("%02im ", minutes), sep = "")
    resTime <- if(decimals) paste0(resTime, sprintf("%.2fs", sec))
    else paste0(resTime, sprintf("%02is", sec))
    resTime
}

print_progress <- function(row, trow, time1, time0, stored_time, progress){
    if(progress) cat('\n')
    cat(sprintf('\rDesign row: %i/%i;   Started: %s;   Total elapsed time: %s \n',
                row, trow, date(), timeFormater(sum(stored_time))))
    invisible()
}
RECYCLEWARNING <- NULL
.onLoad <- function(libname, pkgname){
  RECYCLEWARNING <<- gettext(tryCatch( (1:2)+(1:3),warning=function(w) w$message ))
}

.onAttach <- function(libname, pkgname) {
  	pkgEnv = pos.to.env(match('package:SoundexBR', search()))
  	packageStartupMessage('')
}




#' @encoding latin1
#' @title ASCII Characters Table
#'
#' @description To detect ASCII characters, we may need to specify them literally. This function helps identifying what character is in ascii format and what is not.
#'
#' @param x A string whose characters is to be checked against.
#'
#' @return Returns \code{TRUE} if ASCII character and \code{FALSE} otherwise.
#'
#' @author Daniel Marcelino, \email{dmarcelino@@live.com}
#'
#' @export
ascii.table <- function(x){
  charclass <- paste0("[^]"
, "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
, "0123456789"
, " !\"#$%&'()*+,./:;<=>?@[\\^_`{|}~-"
, "]")
  !grepl(charclass,x)
}
markup <- function(x)
  gsub("<", "&lt;", gsub(">", "&gt;", gsub("&", "&amp;", x)))

catSDML <- function(...) cat(..., append=TRUE, sep="")

etagsSDML <- function(x, ...)
{
  info <- attr(x, "info")
  for (i in 1:length(x)) {
    inf <- if (!is.null(info) && !is.na(info[i]))
      paste(" info=\"", info[i], "\"", sep="")
    else ""
    
    if (is.na(x[i]) && !is.nan(x[i]))
      catSDML("<na", markup(inf), "/>", ...)
    else
      if (is.logical(x))
        catSDML("<", if (x[i]) "T" else "F", markup(inf), "/>", ...)
      else
        tags(x[i], "e", inf, ...)
    
    if((i!=length(x)) & ((i %% 5)==0))
      catSDML("\n", ...)
  }
}

cetagsSDML <- function(x, ...)
{
  info <- attr(x, "info")
  for (i in 1:length(x)) {
    inf <- if (!is.null(info) && !is.na(info[i]))
      paste(" info=\"", info[i], "\"", sep="")
    else ""
    
    if (is.na(x[i]) && !is.nan(x[i]))
      catSDML("<na", markup(inf), "/>", ...)
    else {
      catSDML("<ce", markup(inf), ">", ...)
      tags(Re(x[i]), "r", ...)
      tags(Im(x[i]), "i", ...)
      catSDML("</ce>", ...)
    }
    
    if((i!=length(x)) & ((i %% 3)==0))
      catSDML("\n", ...)
  }
}

tags <- function(x, s, info = "", ...) {
  if (is.nan(x))
    catSDML("<", s, markup(info), "><nan/></", s, ">", ...)
  else if (x == Inf)
    catSDML("<", s, markup(info), "><posinf/></", s, ">", ...)
  else if (x == -Inf)
    catSDML("<", s, markup(info), "><neginf/></", s, ">", ...)
  else
    catSDML("<", s, markup(info), ">", markup(x), "</", s, ">", ...)
}

getAttrSDML <- function(x)
{
	if (!is.null(x$attributes))
	{
		return(x$attributes)
	}
	return(NULL)
}
### Typical 'prior.params' vector: c(A=0.25, C=0.25, G=0.25, T=0.25)
### This is taken from Biostrings package matchPWM.R.
### Just to get rid of the node during the build.
DNA_BASES <- c("A", "C", "G", "T")

normargPriorParams <- function(prior.params)
{
    if (!is.numeric(prior.params))
        stop("'prior.params' must be a numeric vector")
    if (length(prior.params) != length(DNA_BASES) ||
        !setequal(names(prior.params), DNA_BASES))
        stop("'prior.params' elements must be named A, C, G and T")
    ## Re-order the elements.
    prior.params <- prior.params[DNA_BASES]
    if (any(is.na(prior.params)) || any(prior.params < 0))
        stop("'prior.params' contains NAs and/or negative values")
    prior.params
}

normargMat = function(x){
    if (is.null(rownames(x)))
        stop("invalid Matrix 'mat': no row names")
    if (!all(DNA_BASES %in% rownames(x)))
        stop("invalid Matrix 'mat': row names must contain A, C, G and T")
    if (any(duplicated(rownames(x))))
        stop("invalid Matrix 'mat': duplicated row names")
    if (ncol(x) == 0L)
        stop("invalid Matrix 'mat': no columns")
    if (any(is.na(x)) || any(x < 0L))
        stop("invalid Matrix 'mat': values cannot be NA or negative")
    if (any(x[!(rownames(x) %in% DNA_BASES), ] != 0L))
        stop("invalid Matrix 'mat': IUPAC ambiguity letters are represented")
    x <- x[DNA_BASES, , drop = FALSE]
    x
}
## Get *subset* of inverse of sparse matrix Q.
## Subset is guarantied to contain pattern of Q.
## Q: Sparse positive definite matrix.
## L: Cholesky factor of Q.
## diag: Return just diagonal of inverse ?
solveSubset <- function(Q,
                        L = Matrix::Cholesky(Q, super=TRUE, perm=TRUE),
                        diag = FALSE) {
    stopifnot( is(L, "dCHMsuper") )
    invQ <- .Call("tmb_invQ", L, PACKAGE = "TMB")
    iperm <- Matrix::invPerm(L@perm + 1L)
    if (diag) {
        invQ <- diag(invQ)[iperm]
    } else {
        invQ <- invQ[iperm, iperm, drop=FALSE]
    }
    invQ
}
# other function used in the package

## format cat output
format_cat<-function(x) format(as.character(sprintf("%.7g", x)),width =8,justify="left")


## check range of values
check.range <- function(q,q.set) {q[q<=max(q.set) & q>=min(q.set)]}
##' show both head and tail in summary with ellipsis in between
##'
##' @param x object to summarize
##' @param k number of elements taken from head and tail
##' @return calls cat on value
##' @export
headtail <- function(x, k=3) {
  out <- capture.output(x); n <- length(out)
  val <- paste(c(out[1:(k+1)], "   ...", out[(n-k):n]), collapse="\n")
  cat(val, "\n")
  invisible()
}


## headtail.matrix <- function(x, k=3) {
##   headtail.data.frame(x, k)
## }



## confint for htest object
##' confint for htest objects
##'
##' @param object an htest object
##' @param parm ignored
##' @param level ignored
##' @return a confidence interval
##'
##' @export
confint.htest <- function(object, parm, level, ...) {
  x <- object
  tmp <- x$conf.int
  transform <- list(...)$transform
  if(!is.null(transform))
    tmp <- transform(tmp)
  cat(sprintf("(%.2f, %.2f) with %d percent confidence",
              tmp[1], tmp[2], 
              floor(100*attr(tmp, "conf.level"))))
  invisible()
}
##
####################################################################################################################################
### Filename:    utility.R
### Description: Function 'sim_power' for performing a power simulation and 'insert_row' to add a row in a data.frame
###
###
###
###
####################################################################################################################################


#' @keywords internal
sim_power <- function(x1,x2,nsim,n1,n2) {

  simpower <- 0
  cat("Simulation:\n")

  for(i in 1:nsim){
    if(i%%1000==0){
      cat(paste(i, "/", nsim, "\n"))
    }
    z1 <- sample(x1, size = ceiling(n1), prob = NULL, replace = TRUE)
    z2 <- sample(x2, size = ceiling(n2), prob = NULL, replace = TRUE)
    df = data.frame(grp = as.factor(c(rep(1,ceiling(n1)), rep(2,ceiling(n2)))), z = c(z1,z2) )

    if(rank.two.samples(z~grp, data = df, wilcoxon = "asymptotic", info = FALSE, shift.int=FALSE, alternative = "two.sided")$Wilcoxon$p.Value <= 0.05){
      simpower <- simpower + 1
    }
  }
  cat("\n")
  return (simpower)
}


#' @keywords internal
insert_row <- function(df, newrow, r) {
  df[seq(r+1,nrow(df)+1),] <- df[seq(r,nrow(df)),]
  df[r,] <- newrow
  return(df)
}
#https://stackoverflow.com/questions/37773469/r-random-distribution-with-predefined-min-max-mean-and-sd-values
rgbeta <- function(n, mean, var, min = 0, max = 1)
{
  dmin <- mean - min
  dmax <- max - mean

  if (dmin <= 0 || dmax <= 0)
  {
    stop(paste("mean must be between min =", min, "and max =", max))
  }

  if (var >= dmin * dmax)
  {
    stop(paste("var must be less than (mean - min) * (max - mean) =", dmin * dmax))
  }

  # mean and variance of the standard beta distributed variable
  mx <- (mean - min) / (max - min)
  vx <- var / (max - min)^2

  # find the corresponding alpha-beta parameterization
  a <- ((1 - mx) / vx - 1 / mx) * mx^2
  b <- a * (1 / mx - 1)

  # generate standard beta observations and transform
  x <- stats::rbeta(n, a, b)
  y <- (max - min) * x + min

  return(y)
}


# Broken-stick function
#https://alstatr.blogspot.com/2014/12/principal-component-analysis-on-imaging.html
brStick <- function (x) {
  m <- 0
  out <- matrix(NA, ncol = 2, nrow = length(x))
  colnames(out) <- c("% of Variability", "B-Stick Threshold")
  for (i in 1:length(x)) {
    for (k in i:length(x)) {
      m <- m + ((1 / length(x)) * (1 / k))
    }
    out[i, ] <- c((x[i] / sum(x)) * 100, m * 100)
    m <- 0
  }
  return(max(which(out[, 1] > out[, 2])))
}
dudi.type <- function(x){
  ## Test the different types of dudi
  ##      typ=1 no modification (PCA on original variable)
  ##      typ=2 ACM 
  ##      typ=3 normed and centred PCA 
  ##      typ=4 centred PCA 
  ##      typ=5 normed and non-centred PCA 
  ##      typ=6 COA 
  ##      typ=7 FCA 
  ##      typ=8 Hill-smith
  ##      typ=9 Decentred PCA
  if(!is.call(x))
    stop("Argument x should be a 'call' object")
  x <- match.call(eval(x[[1]]),call = x) ## fill arguments names
  call.list <- as.list(x)
  dudi.name <- deparse(call.list[[1]])
  call.list <- modifyList(formals(dudi.name), call.list[-1]) ## fill with default for unused arguments
  
  if (dudi.name == "dudi.pca") {
    call.list$scale <- eval(call.list$scale)
    call.list$center <- eval(call.list$center)
    
    if(!(is.logical(call.list$center)))
      typ <- 9
    if (!call.list$center & !call.list$scale) typ <- 1
    if (!call.list$center & call.list$scale) typ <- 5
    if (call.list$center & !call.list$scale) typ <- 4
    if (call.list$center & call.list$scale) typ <- 3
  } else if (dudi.name == "dudi.fpca") {
    typ <- 4
  } else if (dudi.name == "dudi.coa") {
    typ <- 6
  } else if (dudi.name == "dudi.fca") {
    typ <- 7
  } else if (dudi.name == "dudi.acm") {
    typ <- 2
  } else if (dudi.name == "dudi.hillsmith") {
    typ <- 8
  } else stop ("Not yet available")
  return(typ)
}


adegraphicsLoaded <- function() {
    ## check if adegraphics is loaded
    "package:adegraphics"%in%search()
}
    
messageScannf <- function(oldCall, myNf) {
  newcall <- as.list(oldCall)
  newcall$scannf <- FALSE
  newcall$nf <- myNf
  message("\nYou can reproduce this result non-interactively with: \n", c(as.call(newcall)), "\n")
}
dudi.type <- function(x){
  ## Test the different types of dudi
  ##      typ=1 no modification (PCA on original variable)
  ##      typ=2 ACM 
  ##      typ=3 normed and centred PCA 
  ##      typ=4 centred PCA 
  ##      typ=5 normed and non-centred PCA 
  ##      typ=6 COA 
  ##      typ=7 FCA 
  ##      typ=8 Hill-smith
  ##      typ=9 Decentred PCA
  if(!is.call(x))
    stop("Argument x should be a 'call' object")
  x <- match.call(eval(x[[1]]),call = x) ## fill arguments names
  call.list <- as.list(x)
  dudi.name <- deparse(call.list[[1]])
  call.list <- modifyList(formals(dudi.name), call.list[-1]) ## fill with default for unused arguments
  
  if (dudi.name == "dudi.pca") {
    call.list$scale <- eval(call.list$scale)
    call.list$center <- eval(call.list$center)
    
    if(!(is.logical(call.list$center)))
      typ <- 9
    if (!call.list$center & !call.list$scale) typ <- 1
    if (!call.list$center & call.list$scale) typ <- 5
    if (call.list$center & !call.list$scale) typ <- 4
    if (call.list$center & call.list$scale) typ <- 3
  } else if (dudi.name == "dudi.fpca") {
    typ <- 4
  } else if (dudi.name == "dudi.coa") {
    typ <- 6
  } else if (dudi.name == "dudi.fca") {
    typ <- 7
  } else if (dudi.name == "dudi.acm") {
    typ <- 2
  } else if (dudi.name == "dudi.hillsmith") {
    typ <- 8
  } else stop ("Not yet available")
  return(typ)
}


adegraphicsLoaded <- function() {
    ## check if adegraphics is loaded
    "package:adegraphics"%in%search()
}
    
messageScannf <- function(oldCall, myNf) {
  newcall <- as.list(oldCall)
  newcall$scannf <- FALSE
  newcall$nf <- myNf
  message("\nYou can reproduce this result non-interactively with: \n", c(as.call(newcall)), "\n")
}
escape_vars <- function(names) {
  if (length(names) == 0)
    return(names)
  names <- vapply(names, function(name) {
    if (make.names(name) != name) {
      name <- gsub('\\', '\\\\', name, fixed=TRUE)
      name <- gsub('`',  '\\`',  name, fixed=TRUE)
      name <- paste0('`', name, '`')
    }
    name
  }, FUN.VALUE='', USE.NAMES=FALSE)
  names
}

# decompose functions from jmvcore

decomposeTerm <- function(term) {

    chars <- strsplit(term, '')[[1]]
    components <- character()
    componentChars <- character()
    inQuote <- FALSE

    i <- 1
    n <- length(chars)

    while (i <= n) {
        char <- chars[i]
        if (char == '`') {
            inQuote <- ! inQuote
        }
        else if (char == '\\') {
            i <- i + 1
            char <- chars[i]
            componentChars <- c(componentChars, char)
        }
        else if (char == ':' && inQuote == FALSE) {
            component <- paste0(componentChars, collapse='')
            components <- c(components, component)
            componentChars <- character()
        }
        else {
            componentChars <- c(componentChars, char)
        }
        i <- i + 1
    }

    component <- paste0(componentChars, collapse='')
    components <- c(components, component)

    components
}


print_legend <- function(x) {
  sig_symbols <- as.character(attr(x, "sig_symbols"))
  if(length(sig_symbols) > 0 & !all(sig_symbols == rep("", 4))) {
    sleg <- attr(stats::symnum(0, cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1), 
                               symbols = rev(c(" " , stringr::str_trim(sig_symbols)))), "legend")
    width <- getOption("width")
    
    if(width < nchar(sleg)) {
      sleg <- strwrap(sleg, width = width - 2, prefix = "  ")
    } 
    
    cat("---\nSignif. codes:  ", sleg, sep = "", fill = getOption("width") + 4 + max(nchar(sleg, "bytes") - nchar(sleg)))
  }
}
`%||%` <- function(x, y) ifelse(is.null(x), y, x)

#' Empty Answer
#'
#' Utility function used to queue a job for an app that has no questions
#'
#' @examples
#' \dontrun{
#' job <- queue_job(app, answer = empty_answer())
#' }
#'
#' @export
empty_answer <- function() build_answers(list())
#' Pipe operator
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @export
#' @importFrom magrittr %>%
#' @usage lhs \%>\% rhs
NULL
## anytime: Use Boost Date_Time to convert date(time) data to POSIXt
##
## Copyright (C) 2015 - 2017  Dirk Eddelbuettel
##
## This file is part of anytime.
##
## anytime is free software: you can redistribute it and/or modify it
## under the terms of the GNU General Public License as published by
## the Free Software Foundation, either version 2 of the License, or
## (at your option) any later version.
##
## anytime is distributed in the hope that it will be useful, but
## WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
## GNU General Public License for more details.
##
## You should have received a copy of the GNU General Public License
## along with anytime.  If not, see <http://www.gnu.org/licenses/>.

getTZ <- function() {
    .pkgenv$tz
}

setTZ <- function(tz) {
    assign("tz", tz, envir=.pkgenv)
}

isRStudio <- function() {
    .pkgenv$isRStudio
}
# Create a docx file and open it
apa_to_docx <- function(fun, x, ...)
{
  tmp <- tempfile("to_apa", fileext = ".md")
  sink(tmp)
  do.call(fun, list(x, format = "rmarkdown", ...))
  sink()
  outfile <- render(tmp, output_format = "word_document", quiet = TRUE)

  sys_open(outfile)
}

# Open a file with standard application on different operating systems
sys_open <- function(filename)
{
  sys <- Sys.info()[['sysname']]

  if (sys == "Windows")
  {
    shell(paste0("\"", filename, "\""))
  }
  else if (sys == "Linux")
  {
    system(paste0("xdg-open \"", filename, "\""))
  }
  else if (sys == "Darwin")
  {
    system(paste0("open \"", filename, "\""))
  }
}
# Dispose OP enum values
APNG_DISPOSE_OP_NONE <- 0
APNG_DISPOSE_OP_BACKGROUND <- 1
APNG_DISPOSE_OP_PREVIOUS <- 2

# Blend OP enum values
APNG_BLEND_OP_SOURCE <- 0
APNG_BLEND_OP_OVER <- 1

# Convert a raw array of length 4 to an int
int_from_4_bytes <- function(raw) {
    if (length(raw) == 0){
        return(0)
    }
    return(sum(as.integer(raw) * c(0x01000000, 0x010000, 0x0100, 1)))
}

# Convert an int to a 4 byte raw array
int_to_4_bytes <- function(i) {
    hh <- bitShiftR(bitAnd(i, 0xff000000), 24)
    hl <- bitShiftR(bitAnd(i, 0xff0000), 16)
    lh <- bitShiftR(bitAnd(i, 0xff00), 8)
    ll <- bitAnd(i, 0xff)
    return(as.raw(c(hh, hl, lh, ll)))
}

# Convert an int to a 2 byte raw array
int_to_2_bytes <- function(i) {
    h <- bitShiftR(bitAnd(i, 0xff00), 8)
    l <- bitAnd(i, 0xff)
    return(as.raw(c(h, l)))
}

# Convert an int to a 1 byte raw array
int_to_1_byte <- function(i) {
    return(as.raw(c(i)))
}
is.badval <- function(x)
{
  is.na(x) || is.nan(x) || is.infinite(x)
}

is.annoying <- function(x)
{
  length(x) != 1 || is.badval(x)
}

is.string <- function(x)
{
  is.character(x) && !is.annoying(x)
}

is.inty <- function(x)
{
  abs(x - round(x)) < 1e-10
}

is.zero <- function(x)
{
  abs(x) < 1e-10
}

is.negative <- function(x)
{
  x < 0
}



check.is.posint <- function(x)
{
  if (!is.numeric(x) || is.annoying(x) || !is.inty(x) || is.negative(x) || is.zero(x))
  {
    nm <- deparse(substitute(x))
    stop(paste0("argument '", nm, "' must be a positive integer"), call.=FALSE)
  }
  
  invisible(TRUE)
}

check.is.flag <- function(x)
{
  if (!is.logical(x) || is.annoying(x))
  {
    nm <- deparse(substitute(x))
    stop(paste0("argument '", nm, "' must be TRUE or FALSE"), call.=FALSE)
  }
  
  invisible(TRUE)
}

check.is.string <- function(x)
{
  if (!is.string(x))
  {
    nm <- deparse(substitute(x))
    stop(paste0("argument '", nm, "' must be a single string"), call.=FALSE)
  }
  
	invisible(TRUE)
}

check.is.string.or.null <- function(x)
{
  if (!is.null(x) && !is.string(x))
  {
    nm <- deparse(substitute(x))
    stop(paste0("argument '", nm, "' must be a single string or NULL"), call.=FALSE)
  }
  
  invisible(TRUE)
}
is_Wave <- function(x){
  identical(suppressWarnings(as.character(class(x))), "Wave")
}

# get random string
grs <- function(){
  paste(sample(c(1:10, letters, LETTERS), size = 12, replace = TRUE), collapse = "")
}

# how long is a wav?
duration <- function(wav){
  stopifnot(is_Wave(wav))
  length(wav@left) / wav@samp.rate
}

# get from list
# list, name of element, default
gfl <- function(l, n, d){
  if(is.null(l[[n]])){
    d
  } else {
    l[[n]]
  }
}

#' @importFrom purrr map_chr compose
string_tirm <- function(s){
  str_rev <- function(t){
    paste(rev(strsplit(t, NULL)[[1]]), collapse = "")
  }
  
  str_trim_right <- function(x){
    sub("\\s+$", "", x)
  }
  
  str_trim_left <- function(x){
    x <- str_rev(x)
    x <- str_trim_right(x)
    str_rev(x)
  }
  
  lr <- compose(str_trim_left, str_trim_right)
  map_chr(s, lr)
}

# get text from html comments in an Rmd
parse_html_comments <- function(path){
  lines_ <- readLines(path, warn = FALSE)
  starts <- grep("<!--", lines_)
  ends <- grep("-->", lines_)
  
  if(length(starts) != length(ends)){
    stop("There's a comment open/close mismatch.")
  }
  
  result <- rep(NA, length(starts))
  
  for(i in seq_along(starts)){
    if(starts[i] == ends[i]){ # Single line
      result[i] <- lines_[starts[i]]
    } else {                  # Multiple lines
      result[i] <- paste(string_tirm(lines_[starts[i]:ends[i]]), collapse = " ")
    }
    result[i] <- sub("<!--", "", result[i])
    result[i] <- sub("-->", "", result[i])
  }
  
  string_tirm(result)
}

# split a big string into equal-ish sized pieces
#' @importFrom purrr map
split_up_text <- function(text){
  pieces <- ceiling(nchar(text)/1500)
  words <- strsplit(text, " ")[[1]]
  chunks <- split(words, ceiling(seq_along(words)/(length(words)/pieces)))
  map(chunks, paste, collapse = " ")
}
convertz <- function(z, bigz){
    if (bigz){
        return(gmp::as.bigz(z))
    } else if (abs(z) < .Machine$integer.max) {
        return(as.integer(round(z)))
    } else {
        stop("integer overflow, consider using big integer")
    }
}

as_uint_array <- function(a) {
    .Call("as_uint_array", PACKAGE = "arrangements", a)
}
checkMeasure = function(measure, desc) {
  if (missing(measure))
    measure = desc$performance_measures[1]
  else
    assertChoice(measure, choices = desc$performance_measures)
  return(measure)
}

# throws an exception if one tries to calculate the logarithm of non-negative values
checkLogarithm = function(log, x, col) {
  if (log) {
    if (!missing(col))
      x = x[, col]
    if ((any(!is.na(x) & x <= 0)))
      stop("Cannot compute logarithm of <= 0 value! ")
  }
}

# put vector in, get vector of stats out
getStatistics = function(x) {
  # we drop name for quantiles
  funs = list(
    obs = function(x) length(x),
    nas = function(x) sum(is.na(x)),
    min = function(x) min(x, na.rm = TRUE),
    qu_1st = function(x) as.numeric(quantile(x, 0.25, na.rm = TRUE)),
    med = function(x) median(x, na.rm = TRUE),
    mean = function(x) mean(x, na.rm = TRUE),
    qu_3rd  = function(x) as.numeric(quantile(x, 0.75, na.rm = TRUE)),
    max = function(x) max(x, na.rm = TRUE),
    sd = function(x) sd(x, na.rm = TRUE),
    coeff_var = function(x) sd(x, na.rm = TRUE) / mean(x, na.rm = TRUE)
  )
  sapply(funs, function(f) f(x))
}

removeConstScenFeats = function(feats) {
  iid = feats$instance_id
  task = makeClusterTask(data = dropNamed(feats, "instance_id"))
  task = removeConstantFeatures(task, na.ignore = TRUE, show.info = TRUE)
  cbind(instance_id = iid, getTaskData(task))
}
#' Get the dimensions of an object
#' 
#' Get the dimensions of an object, retuning the length if that object has no
#' \code{dim} attribute.
#' @param x Any object.
#' @return A integer vector of non-negative values.
#' @seealso \code{\link[base]{NROW}}, \code{\link[base]{dim}}
#' @examples
#' # For data frames and matrices, DIM is the same as dim.
#' DIM(sleep) 
#' # For vectors (and other objects without a dim attribute), DIM is the 
#' # same as length.
#' DIM(1:10)
#' DIM(list(x = 1:10))
#' @export
DIM <- function(x)
{
  dim_x <- dim(x)
  if(is.null(dim_x)) length(x) else dim_x
}

#' Get the number of elements
#' 
#' Gets the number of elements in an object.
#' @param x Any object.
#' @return A non-negative integer of the number of elements.
#' @note For atomic objects, the number of elements is the product of the
#' dimensions, as calculated by \code{\link{DIM}}.  For recursive objects,
#' the number of elements is the sum of the number of elements of each of
#' their atomic components.
#' @seealso \code{\link{DIM}}
#' @examples
#' n_elements(1:10)
#' n_elements(NULL)
#' n_elements(data.frame(x = 1:5, y = rnorm(5)))
#' n_elements(list(1:5, list(1:3, list(1:7))))
#' n_elements(var) # depends upon the length of the body
#' @export
n_elements <- function(x)
{
  if(is.recursive(x))
  {
    sum(vapply(x, n_elements, integer(1)))
  } else
  {
    as.integer(prod(DIM(x)))
  }  
}
#' Convert a character vector to a list of integer vectors
#'
#' Split strings by character, then convert to numbers
#' @param x Input to convert.
#' @return A list of numeric vectors.
#' @examples
#' \dontrun{
#' character_to_list_of_integer_vectors(c("123", "4567a"))
#' }
#' @seealso \code{\link[base]{strsplit}} and \code{\link[base]{as.integer}}.
#' @importFrom assertive.base coerce_to
#' @export
character_to_list_of_integer_vectors <- function(x)
{
  x <- coerce_to(x, "character")
  names(x) <- x
  lapply(strsplit(x, ""), as.integer)
}
"%||%" <- function(a, b) if (is.null(a)) b else a
#' @importFrom rlang lang splice

try_catch_builder <- function(arg, fun, ...){
  a <- lang(fun, splice(list(arg)))
  lang("try_catch", splice(list(expr = a, ...)))
}

try_catch_df_builder <- function(arg, fun, ...){
  a <- lang(fun, splice(list(arg)))
  lang("try_catch_df", splice(list(expr = a, ...)))
}
## Translate the fail argument from what the user selects to what failed pixels
## should be set to.
translate_fail <- function(arr, fail) {
  stopifnot(length(fail) == 1)
  if (is.na(fail)) return(NA)
  if (is.numeric(fail)) {
    stopifnot(fail >= 0)
  } else if (is.character(fail)) {
    fail <- filesstrings::match_arg(fail, c("saturate", "zero"),
                                   ignore_case = TRUE)
  }
  if (fail == "zero") {
    fail <- 0
  } else if (fail == "saturate") {
    mx <- max(arr, na.rm = TRUE)
    bits_per_sample <- 8
    if (mx > 2 ^ 16 - 1) {
      bits_per_sample <- 32
    } else if (mx > 2 ^ 8 - 1) {
      bits_per_sample <- 16
    }
    fail <- 2 ^ bits_per_sample - 1
  }
  fail
}

eval_text <- function(string) {
  checkmate::assert_scalar(string)
  checkmate::assert_character(string)
  eval(parse(text = string))
}
"%:::%" <- function(p, f) {
  get(f, envir = asNamespace(p))
}

yes_no <- function(x) {
  if (isTRUE(x)) {
    crayon::green(clisymbols::symbol$tick)
  } else {
    crayon::red(clisymbols::symbol$cross)
  }
}

fix_windows_nl <- function(x) {
  gsub("\r\n", "\n", x)
}
#' @export
print.aws_cloudtrail <- function(x, ...) {
    cat("Name:    ", x[["Name"]], "\n")
    cat("Arn:     ", x[["TrailARN"]], "\n")
    cat("Bucket:  ", x[["S3BucketName"]], "\n")
    cat("Region:  ", x[["HomeRegion"]], "\n")
    cat("SNSTopic:", x[["SnsTopicARN"]], "\n")
    invisible(x)
}

get_trailname <- function(x, ...) {
    UseMethod("get_trailname")
}

get_trailname.default <- function(x, ...) {
    x
}

get_trailname.aws_cloudtrail <- function(x, ...) {
    x[["Name"]]
}
check_truncation <- function(truncation) {
    if (isTRUE(truncation)) {
        message("Response is truncated")
    }
}

get_aliasname <- function(x) {
    if (inherits(x, "iam_alias")) {
        x[["AliasName"]]
    } else {
        x
    }
}

get_groupname <- function(x) {
    if (inherits(x, "iam_group") | inherits(x, "iam_policy")) {
        x[["GroupName"]]
    } else {
        x
    }
}

get_keyid <- function(x) {
    if (inherits(x, "iam_key")) {
        x[["AccessKeyId"]]
    } else {
        x
    }
}

get_username <- function(x) {
    if (inherits(x, "iam_user") | inherits(x, "iam_policy")) {
        x[["UserName"]]
    } else {
        x
    }
}

get_policyname <- function(x) {
    if (inherits(x, "iam_policy")) {
        x[["PolicyName"]]
    } else {
        x
    }
}

get_profilename <- function(x) {
    if (inherits(x, "iam_instance_profile")) {
        x[["InstanceProfileName"]]
    } else {
        x
    }
}

get_rolearn <- function(x) {
    if (inherits(x, "iam_role")) {
        x[["Arn"]]
    } else {
        x
    }
}

get_rolename <- function(x) {
    if (inherits(x, "iam_role") | inherits(x, "iam_policy")) {
        x[["RoleName"]]
    } else {
        x
    }
}
print.aws_lambda_function <- function(x, ...) {
    print(str(x))
    return(invisible(x))
}

#' @rdname get_function_name
#' @title Get name of Lambda function
#' @description Extracts an AWS Lambda function's name
#' @param x An object of class \dQuote{aws_lambda_function}.
#' @param \dots Additional arguments passed to methods
#' @export
get_function_name <- function(x, ...) {
    UseMethod("get_function_name")
}

#' @rdname get_function_name
#' @export
get_function_name.character <- function(x, ...) {
    x
}

#' @rdname get_function_name
#' @export
get_function_name.aws_lambda_function <- function(x, ...) {
    x[["FunctionName"]]
}
#
#   This function is a slightly modified version of
#   function setCores in package spMC version 0.2.2
#   written by Luca Sartore <drwolf85@gmail.com>
#
setCores <- function(n, reprt = TRUE) {
  # Set number of CPU cores which will be used by the package
  #
  #     n number of CPU cores

  if (!missing(n)) {
    if (is.numeric(n)) {
      n <- as.integer(ceiling(n))
      n <- .C(C_setNumThreads, n = as.integer(n))$n
    }
  }
  n <- 0L
  crTot <- 0L
  n <- .C(C_getNumThreads, n = as.integer(n))$n
  if (n <= 1L) {
  } else {
    crTot <- .C(C_getNumCores, n = as.integer(crTot))$n
    if(reprt) {
    cat("  Total CPU cores available: ", crTot,"  CPU cores in use: ", n, ".\n", sep = "")
    }
  }
  invisible(n)
}
# utils 
# Functions for internal use. 
# 

#' return markdown with image and link. 
#' 
#' for internal use. used within licencebuilder
#'
#' @param imagelink link to image file
#' @param referlink link to where to send to on click
#' @param name what to call the button
#'
#' @return markdown
licencepaste<- function(imagelink, referlink, name= "Licence"){
    paste0("[![", name,"]","(",imagelink, ")]","(",referlink,")")
}
# tests
utils::globalVariables(".")
#BAIRT
#Bayesian Analysis of Item Response Theory Models
#Autor: Javier Martinez <martinezjavier243@gmail.com>
#
#utility functions for check.plot
#
###############################################################################
###############################################################################
.major.fun <- function(x, major = 1.1) {


    a <- rep(NA, length(x))

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

        if (x[i] > major) {
            a[i] = i
        }

    }

    return(a[!is.na(a)])

}

###############################################################################
###############################################################################
.scalec <- function(x, c = seq(0, 1, 0.25)) {


    v <- rep(0, length(x))

    h <- length(c) - 1

    for (j in 1:h) {

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

            if (c[j] <= x[i] && x[i] < c[j + 1])
                (v[i] = j)
        }

    }

    return(v)

}

###############################################################################
###############################################################################
.int <- function(x) {

    a <- rep(NA, length(x) - 1)

    for (i in 1:(length(x) - 1)) {

        a[i] <- paste("[", x[i], ",", x[i + 1], ")")

    }

    return(a)

}
pathOfScript <- function() {
  tryCatch({
      # Works when using source
      dirname(normalizePath(parent.frame(3)$ofile))
    },
    error = function(e) {
      args <- commandArgs()
      # Works when using R CMD BATCH
      t1 <- which(args == '-f')
      if ( length(t1) > 0 ) {
        if ( length(t1) > 1 ) stop("error: too many -f arguments")
        return(dirname(normalizePath(args[t1+1])))
      }
      # Works when using Rscript
      t1 <- grep("^--file=",args)
      if ( length(t1) > 0 ) {
        if ( length(t1) > 1 ) stop("error: too many --file= arguments")
        return(dirname(normalizePath(substring(args[t1],8,nchar(args[t1])))))
      }
      return(getwd())
    }
  )
}
#' Format object size
#'
#' This function is modified copy of the utils:::format.object_size function which is not exported. 
#' The main difference is that it returns values.
#' 
#' @param x a number
#' @param units a unit
#' @param standard a standard
#' @param digits number of digits
#' @param ... anything else
#'
format_object_size <- function (
  x, units = "b", standard = "auto", digits = 1L, ...) {

    known_bases <- c(legacy = 1024, IEC = 1024, SI = 1000)
    known_units <- list(
      SI = c("B", "kB", "MB", "GB", "TB", "PB", "EB", "ZB", "YB"),
      IEC = c("B", "KiB", "MiB", "GiB", "TiB", "PiB", "EiB", "ZiB", "YiB"),
      legacy = c("b", "Kb", "Mb", "Gb", "Tb", "Pb"),
      LEGACY = c("B", "KB", "MB", "GB", "TB", "PB")
      )

    units <- match.arg(units, c("auto", unique(unlist(known_units),
        use.names = FALSE)))
    standard <- match.arg(standard, c("auto", names(known_bases)))
    if (standard == "auto") {
        standard <- "legacy"
        if (units != "auto") {
            if (grepl("iB$", units))
                standard <- "IEC"
            else if (grepl("b$", units))
                standard <- "legacy"
            else if (units == "kB")
                stop("For SI units, specify 'standard = \"SI\"'")
        }
    }
    base <- known_bases[[standard]]
    units_map <- known_units[[standard]]
    if (units == "auto") {
        power <- if (x <= 0)
            0L
        else min(as.integer(log(x, base = base)), length(units_map) -
            1L)
    }
    else {
        power <- match(toupper(units), toupper(units_map)) -
            1L
        if (is.na(power))
            stop(gettextf("Unit \"%s\" is not part of standard \"%s\"",
                sQuote(units), sQuote(standard)), domain = NA)
    }
    unit <- units_map[power + 1L]
    if (power == 0 && standard == "legacy")
        unit <- "bytes"

    paste0( round(x = x / base ^ power, digits = digits), " ", unit)

}
#' Pipe operator
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @importFrom magrittr %>%
#' @usage lhs \%>\% rhs
#' @export
NULL

#' Compound_pipe
#'
#' @name %<>%
#' @rdname compound_pipe
#' @keywords internal
#' @importFrom magrittr %<>%
#' @usage lhs \%<>\% rhs
#' @export
NULL


#' @title urlExists
#' @description A utility function to run a tryCatch on a URL.
#' @param target url
#' @export
urlExists <- function(target) {
    tryCatch({
        con <- url(target)
        a  <- capture.output(suppressWarnings(readLines(con)))
        close(con)
        TRUE;
    },
    error = function(err) {
        occur <- grep("cannot open the connection", capture.output(err));
        if(length(occur) > 0) FALSE;
    }
    )
}
#' Check whether a text value is present.
#'
#' \code{isTextValue} is a utility function returns TRUE only when a text value
#' is present.  NULL, NA, character(0) and "" all return FALSE.
#'
#' @param value The value to check.
#' @return TRUE if a non-blank text value is present.

isTextValue <- function(value) {
  if(is.null(value)) return(FALSE)
  l <- length(value)
  if(l==0) return(FALSE)
  else if(l==1) {
    if(is.na(value)) return(FALSE)
    if(nchar(value)==0) return(FALSE)
    else return(TRUE)
  }
  else {
    if(sum(nchar(value), na.rm=TRUE)==0) return(FALSE)
    else return(TRUE)
  }
}

#' Check whether a numeric value is present.
#'
#' \code{isNumericValue} is a utility function returns TRUE only when a numeric value
#' is present.  NULL, NA, numeric(0) and integer(0) all return FALSE.
#'
#' @param value The value to check.
#' @return TRUE if a numeric value is present.

isNumericValue <- function(value) {
  if(is.null(value)) return(FALSE)
  l <- length(value)
  if(l==0) return(FALSE)
  else {
    if(length(value[is.na(value)])>0) return(FALSE)
    if(is.numeric(value)) return(TRUE)
    else return(FALSE)
  }
}

#' Check whether a text value is present in another text value.
#'
#' \code{containsText} is a utility function returns TRUE if one text value is
#' present in another.  Case sensitive.  If textToSearch is a vector, returns
#' TRUE if any element contains textToFind.
#'
#' @param textToSearch The value to be searched.
#' @param textToFind The value to find.
#' @return TRUE if the textToFind value is found.

containsText <- function(textToSearch, textToFind) {
  if(!isTextValue(textToSearch)) return(FALSE)
  if(!isTextValue(textToFind)) return(FALSE)
  r <- regexpr(textToFind, textToSearch, fixed=TRUE)
  return((length(r[r!=-1]))>0)
}
getProb <- function(vals, percent_lift = 0) {
  mean((100 * vals > percent_lift))
}

getCredInt <- function(vals, prop = .9) {
  crit <- (1 - prop) / 2
  quantile(vals, c(crit, 1 - crit))
}

getLift <- function(A_samples, B_samples) {
  (A_samples - B_samples) / B_samples
}

coalesce <- function(n) ifelse(is.na(n) | is.nan(n), 0, n)

# Expected loss from switching from B to A
getPostError <- function(A_samples, B_samples, f = function(a, b) (a-b)/b) {
  BoverA <- B_samples > A_samples
  loss <- f(B_samples, A_samples)
  coalesce(mean(BoverA) * mean(loss[BoverA]))
}

isClosed <- function(distribution) grepl("C", distribution)

removeGenericArgs <- function(vec) {
  vec[!vec %in% c('A_data', 'B_data', 'n_samples')]
}

funcLooper <- function(inputs, funcs) {
  for(func in funcs) do.call(func, inputs)
}

getDistPlotFunc <- function(dist) {
  eval(parse(text = paste0('plot', dist)))   
}
getSubclasses <- function(className){
  class <- getClass(className)
    
  subclasses <- names(class@subclasses)
  index <- sapply(subclasses,function(x){!getClass(x)@virtual})
  
  names <- subclasses[index]  
  
  if(!class@virtual){
    names <- c(className,names)    
  }
  
  return(names)
}

mise <- function(model1,model2,discreteApproximation = TRUE){
  
  if(is(model1,"BoundedDensity") & is(model2,"BoundedDensity")){
  
    if(discreteApproximation){
    
      if(!any(getdataPointsCache(model1) != getdataPointsCache(model2))){
        sum((getdensityCache(model1)-getdensityCache(model2))^2)/length(getdensityCache(model1))
      }
      else{
        stop("DataPointsCache must be the same for both models when discreteApproximation = TRUE. Use discreateApproximation == FALSE instead")
      }
      
    }
    else{ # no discrete approximation
      dif <- function(x,model1,model2){
        (density(model1,x) - density(model2,x))^2
      }
      integrate(dif,lower=0,upper=1,model1=model1,model2=model2)
    }
        
  }
  else{
    stop("model1 and model2 must be BoundedDensity objects. See getSumclasses(\"BoundedDensity\") to see all the allowed classes")
  }
  
}
# Capture unevaluated dots
dots <- function(...) {
    eval(substitute(alist(...)))
}

# Capture unevaluated dots with names
named_dots <- function(...) {
    args <- dots(...)
    nm <- names(args)
    deparse2 <- function(e) {
        res <- deparse(e, 500L)
        res <- gsub("^\\s+", "", res)
        res <- gsub("([^{}])$", "\\1;", res)
        res <- paste(res, collapse = " ")
        res <- gsub(";( [{}]|$)", "\\1", res)
        res
    }
    deparsed <- vapply(args, deparse2, character(1L), USE.NAMES = FALSE)
    ifelse(is.null(nm), nm <- deparsed, nm[nm == ""] <- deparsed[nm == ""])
    names(args) <- nm
    args
}

# Check if a package is installed
is_installed <- function(pkg) {
    nzchar(system.file(package = pkg))
}

# Grouped summary stats for the benchmark object
summarise <- function(x, cols, fun, relative) {
    res <- lapply(split(x$time, x$expr), fun)
    res <- structure(
        cbind(names(res), as.data.frame(do.call(rbind, res))),
        class = c("summaryBenchmark", "data.frame"),
        names = c("expr", "n.eval", cols),
        row.names = c(NA, -length(res)),
        units = attr(x, "units")
    )
    if (nrow(res) > 1L && !is.null(relative)) {
        nm <- names(res)
        if (is.numeric(relative))
            relative <- nm[relative]
        relative <- match.arg(relative, cols)
        res$relative <- signif(res[[relative]] / min(res[[relative]]), 3)
    }
    res
}
# bigKRLS is authored by Pete Mohanty and Robert Shaffer

# the below RStudio version control code is adapted from Dirk Eddelbuettel's library(anytime) 
# and https://github.com/eddelbuettel/anytime/blob/ef8b1e52b80a99e96f46232dfe29180686327887/R/init.R#L49-L52
# in light of this helpful discussion: 
# http://stackoverflow.com/questions/43247649/rcpparmadillo-bigmemory-crashes-windows-rstudio-but-no-other-gui-os-type
# mistakes are of course ours 

# bigKRLS requires R 3.3.0 or newer, which is taken care of by the package description
# the code below enables an analogous check on RStudio version


RStudio_outdated <- function(){
  .pkgenv$RStudio_outofdate
}

check_platform <- function(){
  
  problem <- RStudio_outdated()
  if(is.null(problem)){
    problem <- if(.Platform$GUI == "RStudio"){
      threshold <- if(.Platform$OS.type == "unix") "1.0.136" else "1.1.129"
      !(Sys.getenv("RSTUDIO", unset="0") == "1" &&
          exists("RStudio.Version") &&
          eval(parse(text=paste0("RStudio.Version()$version ",  " >= ", "\"", threshold, "\""))))
    } else FALSE
  }
  
  if(problem){
    if(.Platform$OS.type == "unix"){
      stop("\n\nFor your operating system (OSX or Unix), bigKRLS requires RStudio 1.0.136 or higher. To use bigKRLS, switch to RGui or download the current RStudio from:\n\n      https://www.rstudio.com/products/rstudio/download/ \n\n") 
    }else{
      stop("\n\nFor your operating system (Windows), bigKRLS requires RStudio 1.1.129 or higher. To use bigKRLS, switch to RGui or download the current RStudio from:\n \n      https://www.rstudio.com/products/rstudio/download/ \n\n")  
    }  
  }
}
dots <- function(...) {
  eval(substitute(alist(...)))
}

named_dots <- function(...) {
  args <- dots(...)

  nms <- names2(args)
  missing <- nms == ""
  if (all(!missing)) return(args)

  deparse2 <- function(x) paste(deparse(x, 500L), collapse = "")
  defaults <- vapply(args[missing], deparse2, character(1), USE.NAMES = FALSE)

  names(args)[missing] <- defaults
  args
}

as_df <- function(x) {
  class(x) <- "data.frame"
  attr(x, "row.names") <- c(NA_integer_, -length(x[[1]]))

  x
}

timer <- function() {
  start <- proc.time()[[3]]
  function() {
    proc.time()[[3]] - start
  }
}

"%||%" <- function(x, y) if(is.null(x)) y else x

names2 <- function(x) {
  names(x) %||% rep("", length(x))
}

# Given a string and a separator, split the string at the rightmost
# occurrence of the separator and return the two parts.
rsplit_one <- function(str, sep) {
  assert_that(is.string(str), is.string(sep))
  parts <- strsplit(str, sep, fixed = TRUE)[[1]]
  right <- parts[length(parts)]
  if (length(parts) > 1) {
    left <- paste0(parts[-length(parts)], collapse = sep)
  } else {
    left <- NULL
  }
  list(left = left, right = right)
}

bq_progress <- function(..., quiet = NA) {
  delay <- if (isFALSE(quiet)) 0 else 1
  quiet <- if (is.na(quiet)) !interactive() else FALSE

  if (quiet) {
    list(
      tick = function(...) {},
      update = function(...) {}
    )
  } else {
    progress <- progress::progress_bar$new(..., show_after = delay)
    progress$tick(0)
    progress
  }

}
isFALSE <- function(x) identical(x, FALSE)


size_units <- function(x) {
  i <- floor(log2(x) / 10)
  unit <- c("", "kilo", "mega", "giga", "tera", "peta", "exa", "zetta", "yotta")[i + 1]

  structure(x, i = i, unit = unit, class = "size")
}
#' @export
format.size <- function(x, ...) {
  if (x == 0) return("0 bytes")

  y <- x * 1024 ^ -attr(x, "i")
  sprintf("%.1f %sbytes", y, attr(x, "unit"))
}
#' Shortcut to add a suffix value to axis labels
#'
#' @param x A character of length one.
#'
#' @export
#' @seealso prefix
#' @importFrom htmlwidgets JS
#'
# @examples
suffix <- function(x) {
  if (length(x) != 1)
    stop("'x' must be of length one")
  htmlwidgets::JS(
    sprintf("function(x) {return x + '%s';}", x)
  )
}

#' Shortcut to add a prefix value to axis labels
#'
#' @param x A character of length one.
#'
#' @export
#' @seealso suffix
#' @importFrom htmlwidgets JS
#'
# @examples
prefix <- function(x) {
  if (length(x) != 1)
    stop("'x' must be of length one")
  htmlwidgets::JS(
    sprintf("function(x) {return '%s' + x;}", x)
  )
}
fast_intersect <- function(x, y) {
  if (length(x) > length(y)) {
    intersect(y, x)
  } else {
    intersect(x, y)
  }
}
pretty_message <- function(x, ..., width = getOption("width")){
  newx <- if(nchar(x) > width - 7){
    paste0(substr(x, 1, width - 7), "...")
  }else{
    x
  }
  message(newx, ...)
}

match_platform <- function(file, platform, platformregex){
  platind <- vapply(platformregex, grepl, logical(length(file)),
                    x= file, perl = TRUE)
  plat <- if(is.null(dim(platind))){
    if(sum(platind) > 1){
      stop("File matches more than one platform. Check regex.")
    }
    ifelse(length(platform[platind]) > 0, platform[platind], NA)
  }else{
    if(any(rowSums(platind) > 1)){
      stop("File matches more than one platform. Check regex.")
    }
    apply(platind, 1, function(x){
      ifelse(length(platform[x]) > 0, platform[x], NA)
    })
  }
  invisible(plat)
}

get_os <- function (){
  if (.Platform$OS.type == "windows") {
    "win"
  }
  else if (Sys.info()["sysname"] == "Darwin") {
    "mac"
  }
  else if (.Platform$OS.type == "unix") {
    "unix"
  }
  else {
    stop("Unknown OS")
  }
}

#' @name parse_version
#' @rdname parse_version
#' @importFrom semver parse_version
#' @keywords internal
#' @export
semver::parse_version

#' @name render_version
#' @rdname render_version
#' @importFrom semver render_version
#' @keywords internal
#' @export
semver::render_version

#' @name set_version
#' @rdname set_version
#' @importFrom semver set_version
#' @keywords internal
#' @export
semver::set_version

#' @name reset_version
#' @rdname reset_version
#' @importFrom semver reset_version
#' @keywords internal
#' @export
semver::reset_version

#' @name increment_version
#' @rdname increment_version
#' @importFrom semver increment_version
#' @keywords internal
#' @export
semver::increment_version
# wrap vector in double quotes
dquote <- function(x) {
  shQuote(x, type = "cmd")
}

# validate supplied IDs
# PMID format:
#   - see PMC-ids.csv.gz from https://www.ncbi.nlm.nih.gov/pmc/pmctopmid
check_id <- function(id, type) {
  pattern <- switch(type,
      go = "^GO:[0-9]{7}$",
    kegg = "^[a-z]{3,4}[0-9]{5}$",
  pubmed = "^[0-9]{3,8}$",
  entrez = "^[0-9]{1,9}$",
    cran = "^[[:alpha:]][\\w\\.]+(?<!\\.)$",
    bioc = "^[[:alpha:]][\\w\\.]+(?<!\\.)$"
  )
  valid <- grepl(pattern, id, perl = TRUE)
  if (all(valid)) {
    return(id)
  } else {
    invalid <- id[!valid]
    n <- length(invalid)
    if (n == 1) {
      stop(invalid, " is not a valid ", type, " identifier", call. = FALSE)
    } else {
      stop(n, " of the supplied ", type,
           " idenfitiers are invalid including:\n",
           paste0(" -", invalid, "\n")[seq_len(min(10, n))], call. = FALSE)
    }
  }
}

# substitute data tags (e.g., "<var>") for requested values
#' @importFrom memoise memoise
sub_var <- memoise::memoise(
  function(x, id, db) {

    is.datatag <- isTRUE(grepl("^<[a-z]+>$", x))
    if (is.null(x) | !is.datatag) return(x)
    field <- gsub("[<>]", "", x)

    switch(db,
      pubmed = query_pubmed(id, field),
      entrez = query_entrez(id, field),
      go     = query_go(id, field)
    )
  }
)

# check for R base packages
is_base_pkg <- function(x) {
  x %in% c("base", "compiler", "datasets", "grDevices", "graphics", "grid",
           "methods", "parallel", "profile", "splines", "stats", "stats4",
           "tcltk", "tools", "translations", "utils")
}
#'@importFrom httr GET user_agent stop_for_status content
query <- function(key, params, ...){
  url <- paste0("http://api.wordnik.com:80/v4/", params, "&api_key=", key)
  result <- httr::GET(url, httr::user_agent("Birdnik - the wordnik client for R - https://github.com/Ironholds/birdnik"))
  httr::stop_for_status(result)
  return(httr::content(result))
}

clean_bools <- function(bool){
  if(bool == TRUE){
    return("true")
  } else if(bool == FALSE){
    return("false")
  }
  stop(sprintf("'%s' is not a valid value", bool))
}

compress_vector <- function(vector){
  return(paste(vector, collapse = ","))
}

clean_dicts <- function(dicts){
  if(length(dicts) == 1 && dicts %in% c("all", "")){
    return(dicts)
  }
  if(all(dicts %in% c("ahd", "century", "wiktionary", "wordnet", "webster"))){
    return(compress_vector(dicts))
  }
  stop("Invalid dictionaries provided")
}

clean_types <- function(types){
  if(length(types) == 1 && types == "all"){
    return("")
  }
  if(all(types %in% c("ahd", "IPA", "arpabet", "gcide-diacritical"))){
    return(compress_vector(types))
  }
  stop("Invalid pronunciation types provided")
}
getCovBlocks <- function(cov, ranefStructure) {
  index <- 0
  result <- list()
  for (i in 1:ranefStructure$numFactors) {
    result[[i]] <- as.matrix(cov[index + 1:ranefStructure$numCoefPerFactor[i],
                                 index + 1:ranefStructure$numCoefPerFactor[i]])
    index <- index + ranefStructure$numRanefPerFactor[i]
  }

  return(result)
}

## from lme4
namedList <- function(...) {
  result <- list(...)
  substituteNames <- sapply(substitute(list(...)), deparse)[-1]
  if (is.null(resultNames <- names(result))) resultNames <- substituteNames
  if (any(noNames <- resultNames == "")) resultNames[noNames] <- substituteNames[noNames]
  setNames(result, resultNames)
}

is.formula <- function(term) is.language(term) && term[[1]] == '~'

#quoteInNamespace <- function(name, character.only = FALSE) {
#  result <- quote(a + b)
#  result[[1]] <- as.symbol(":::")
#  result[[2]] <- as.symbol("blme")
#  
#  result[[3]] <- if (character.only) name else match.call()[[2]]
#  result
#}
is_raw_list <- function(x) {
  if (!is.list(x))
    return(FALSE)

  raw <- vapply(x, is.raw, logical(1))
  null <- vapply(x, is.null, logical(1))

  if (!all(raw | null))
    return(FALSE)

  TRUE
}

`%||%` <- function(x, y) if (is.null(x)) y else x
#' Pipe operator
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @importFrom magrittr %>%
#' @usage lhs \%>\% rhs
#' @export
NULL

#' Compound_pipe
#'
#' @name %<>%
#' @rdname compound_pipe
#' @keywords internal
#' @importFrom magrittr %<>%
#' @usage lhs \%<>\% rhs
#' @export
NULL


#' @title urlExists
#' @description A utility function to run a tryCatch on a URL.
#' @param target url
#' @importFrom utils capture.output
#' @export urlExists
urlExists <- function(target) {  
    tryCatch({  
        con <- url(target)  
        a  <- capture.output(suppressWarnings(readLines(con)))  
        close(con)  
        TRUE;  
    },  
    error = function(err) {  
        occur <- grep("cannot open the connection", capture.output(err));  
        if(length(occur) > 0) {
            close(con)
            FALSE;
        }  
    })  
}  

#' Internal function to cast the first letter of a word to upper-case.
#' @param x A word or string to capatalize
#' @param ... additional arguments.
#' @keywords internal
#' @export
firstupper <- function(x) {
    substr(x, 1, 1) <- toupper(substr(x, 1, 1))
    x
}
# convert a set of arcs to a (real) edge list.
arcs2elist = function(arcs, nodes, weights = NULL, nid = TRUE, sublist = TRUE,
    parents = FALSE) {

  .Call(call_arcs2elist,
        arcs = arcs,
        nodes = nodes,
        weigths = weights,
        nid = nid,
        sublist = sublist,
        parents = parents)

}#ARCS2ELIST

# convert an edge list into an arc set.
elist2arcs = function(elist) {

  .Call(call_elist2arcs,
        elist = elist)

}#ELIST2ARCS
# check whether the cluster is running.
isClusterRunning = function(cl) {

  tryCatch(any(unlist(parallel::clusterEvalQ(cl, TRUE))),
    error = function(err) { FALSE })

}#ISCLUSTERRUNNING

# check the status of the snow/parallel cluster.
check.cluster = function(cluster) {

  if (is.null(cluster))
    return(TRUE)
  if (!is(cluster, supported.clusters))
    stop("cluster is not a valid cluster object.")
  check.and.load.package("parallel")
  if (!isClusterRunning(cluster))
    stop("the cluster is stopped.")

}#CHECK.CLUSTER

# get the number of slaves.
nSlaves = function(cluster) {

  length(cluster)

}#NSLAVES

slaves.setup = function(cluster) {

  # set the test counter in all the cluster nodes.
  parallel::clusterEvalQ(cluster, library(bnlearn))
  parallel::clusterEvalQ(cluster, reset.test.counter())

}#SLAVE.SETUP

# smart parSapply() that falls back to standard sapply(), but with defaults to
# simplify = FALSE.
smartSapply = function(cl, ..., simplify = FALSE, USE.NAMES = TRUE) {

  if (is.null(cl))
    sapply(..., simplify = simplify, USE.NAMES = USE.NAMES)
  else
    parallel::parSapply(cl = cl, ..., simplify = simplify, USE.NAMES = USE.NAMES)

}#SMARTSAPPLY
# check whether a graph is completely directed (has no undirected arcs).
is.dag = function(arcs, nodes) {

  if (nrow(arcs) == 0)
    return(TRUE)

  .Call(call_is_dag,
        arcs = factor(arcs),
        nnodes = length(nodes))

}#IS.DAG

# alias of is.dag for readable code.
is.pdag = function(arcs, nodes) !is.dag(arcs, nodes)

# generic is.acyclic backend (calls the right one for the graph at hand).
is.acyclic = function(arcs, nodes, return.nodes = FALSE, directed = FALSE,
    debug = FALSE) {

  .Call(call_is_pdag_acyclic,
        arcs = arcs,
        nodes = nodes,
        return_nodes = return.nodes,
        directed = directed,
        debug = debug)

}#IS.ACYCLIC.BACKEND

# compute the sample size / CPT cells ratio.
obs.per.cell = function(x, y, z = NULL, data) {

  opc = 0
  ndata = nrow(data)
  nlx = nlevels(data[, x])
  nly = nlevels(data[, y])

  # return +Inf for continuous data to bypass countermeasures
  # thought for sparce discrete data.
  if (data.type(data) == "continuous")
    return(Inf)

  if (is.null(z) || (length(z) == 0)) {

    opc = ndata / (nlx * nly)

  }#THEN
  else if (is.character(z)) {

    if (length(z) == 1)
      opc = ndata / (nlx * nly * nlevels(data[, z]))
    else if (length(z) > 1)
      opc = ndata / (nlx * nly *
        prod(sapply(z, function(col) { nlevels(data[, col]) } )))

  }#THEN
  else if (is.factor(z)) {

    opc = ndata / (nlx * nly * nlevels(z))

  }#ELSE

  return(opc)

}#OBS.PER.CELL
# print an underlined label in the plot.
underlined = function(x, y, label, col){

  text(x, y, label, col = col, font = 2)
  sw = strwidth(label)
  sh = strheight(label)
  lines(x + c(-sw/2, sw/2), rep(y - 1.5*sh/2, 2), col = col)

}#UNDERLINED

# compute the largest possible expansion factor for which a string fits the box.
largest.cex = function(node, height, width, hfrac = 0.7, wfrac = 0.9) {

  # fit vertically.
  guess  = hfrac * height / strheight(node, cex = 1)
  best = optimize(f = function(x) abs(strheight(node, cex = x) - hfrac * height),
           interval = guess * c(0.5, 2), tol = 0.025)$minimum

  # fit horizonally.
  best = best * min(wfrac * width / strwidth(node, cex = best), 1)

  return(best)

}#LARGEST.CEX

# created a lighter tint of a given colour.
lighter.colour = function(col, offset = 0.25) {

  rgb = col2rgb(col)[, 1]
  do.call("rgb", as.list((rgb + (255 - rgb) * offset) / 255))

}#LIGHTER.COLOUR
# convert a set of arcs to a (real) adjacency matrix.
arcs2amat = function(arcs, nodes) {

  .Call(call_arcs2amat,
        arcs = as.character(arcs),
        nodes = as.character(nodes))

}#ARCS2AMAT

# convert an adjacency matrix back to a set of arcs.
amat2arcs = function(a, nodes) {

  .Call(call_amat2arcs,
        amat = a,
        nodes = nodes)

}#AMAT2ARCS
# advanced cat which correctly handles ini-like and short line widths.
wcat = function(header, value) {

  # measure the number of available columns.
  columns = options("width")
  # prepare the string to be printed.
  string = paste(header, value, sep = " ")

  # blatantly ignore any line width shorter than 45, trying to support
  # that case is a losing proposition.
  if ((columns >= nchar(string)) || columns < 45) {

    # if there are enough columns print the string as is.
    cat(string, "\n")

  }
  else {

    # if there are not enough columns print the header on one row
    # (left-aligned) and the value on the following line (right-aligned).
    cat(header, "\n", sprintf(paste("%", columns, "s", sep = ""), value), "\n")

  }

}#WCAT

# advanced cat handles model strings and short line widths.
fcat = function(modelstr) {

  # measure the number of available columns.
  columns = options("width")

  if ((columns >= nchar(modelstr)) || columns < 45) {

    cat("  ", modelstr, "\n")

  }#THEN
  else {

    cat(paste(strsplit(modelstr, "\\]")[[1]], "]", sep = ""),
      fill = TRUE, sep = "", labels = "  ")

  }#ELSE

}#FCAT
##' Get optimal number of neighbors for bnnSurvival by cross validation
##' 
##' @title Get optimal number of neighbors
##' @param formula Formula
##' @param data Data 
##' @param k Number of neighbors
##' @param ... Further arguments passed to bnnSurvival 
##' @return Optimal k
##' @importFrom prodlim Hist
##' @importFrom pec pec
get_best_k <- function(formula, data, k, ...) {

  ## Use 5-fold cross validation
  K_cross <- 5

  ## Split data
  n <- nrow(data)
  folds <- split(sample(n, n), cut(1:n, K_cross, labels = FALSE))

  ## Compute integrated Brier score for each fold
  ibs <- sapply(folds, function(fold) {
    dat_test <- data[fold, ]
    dat_train <- data[-fold, ]

    ## Models
    models <- lapply(k, bnnSurvival, formula = formula, data = dat_train, ...)

    ## Compute integrated Brier score
    fitpec <- pec::pec(models, formula, dat_test, times = sort(unique(dat_train$time)),
                  cens.model = 'marginal', reference = FALSE)
    return(pec::crps(fitpec)[,1])
  })

  ## Return best k
  k[which.min(rowMeans(ibs))]
}
fix_columns <- function(data) {
  # Removes first 2 columns from numbers - that have empty column name
  data <- data[, names(data) != ""]

  # Makes column names lowercase and changes spaces to _
  names(data) <- tolower(names(data))
  names(data) <- gsub("\\s", "_", names(data))
  names(data) <- gsub("\\.", "", names(data))

  names(data) <- gsub("thtr", "theater", names(data))
  names(data) <- gsub("^change$", "percent_change", names(data))
  return(data)

}

numeric_cleaner <- function(x) {
  # Removes everything but numbers and the negative sign,
  # then makes numeric.
  suppressWarnings(as.numeric(gsub("[^[:digit:]|\\-]", "", x)))
}

mojo_site <- function(page){
  page <- rvest::html_nodes(page, "center td tr+ tr td~ td+ td")
  page <- rvest::html_text(page)
  dim(page) <- c(9, length(page) / 9)
  page <- t(page)
  page <- data.frame(page, stringsAsFactors = FALSE)

  names(page) <- c("movie", "distributor", "gross",
                   "percent_change", "remove", "theaters",
                   "per_theater", "total_gross", "days")
  page$remove <- NULL
  return(page)
}

numbers_site <- function(page){
  page <- rvest::html_nodes(page, paste0("#page_filling_chart >",
                                           " center:nth-child(2) > table"))
  page <- rvest::html_table(page)
  page <- page[[1]]
  return(page)
}
#' Pipe operator
#'
#' See \code{\link[magrittr]{\%>\%}} for more details.
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @export
#' @importFrom magrittr %>%
#' @usage lhs \%>\% rhs
NULL
# Copyright (C) 2016, 2017 Ioannis Kosmidis

#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 or 3 of the License
#  (at your option).
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  http://www.r-project.org/Licenses/

unless_null <- function(x, if_null) {
    if (is.null(x)) {
        if_null
    }
    else {
        x
    }
}
generate_infor_st_ed <- function(group_index,
                                 time_points,
                                 inforColumn){
  infor_st <- 1 + (group_index - 1)*(time_points + inforColumn)
  infor_ed <- (inforColumn)*group_index + (group_index - 1)*time_points
  return(c(infor_st, infor_ed))
}


generate_hour_label <- function(group,
                                hour,
                                sample_index){
  hour_label <- NULL
  for (t in hour) {
    if (t == 0) {
      next
    }
    label <- t
    if (t < 10) {
      label <- paste("0", t, sep="")
    }
    hour_label <- append(hour_label,
                         paste(label, "hr_",group[sample_index], sep=""))
  }
  return(hour_label)
}


generate_fig_log10_matrix <- function(exp_data,
                                      label){
  exp_data <- t(exp_data)    # Inverse
  exp_data <- factor(exp_data)
  exp_data <- as.numeric(as.character(exp_data))    # exp_data for fig
  exp_data <- log10(exp_data)

  gene_number <- length(exp_data[[1]])
  label_data <- rep(label, gene_number)

  fig_data <- data.frame(exp=exp_data, label=factor(label_data))
  # fig_data <- fig_data[!is.infinite(fig_data[,1]),]
  return(fig_data)
}


parse_rm_hr_infor <- function(model){
  check <- gsub("Delete_","",model)
  check <- gsub("hr","",check)
  check <- as.numeric(strsplit(check,"_")[[1]])
  return(check)
}
######################################################################
# print the installed version of R/broman
######################################################################
#  bromanversion
#'
#' Installed version of R/broman
#'
#' Print the version number of the currently installed version of R/broman.
#'
#' @export
#' @return
#' A character string with the version number of the currently installed
#'   version of R/broman.
#'
#' @examples
#' bromanversion()
#'
#' @keywords
#' print
bromanversion <-
    function()
{
    version <- unlist(utils::packageVersion("broman"))

    # make it like #.#-#
    paste(c(version,".","-")[c(1,4,2,5,3)], collapse="")
}
.id <- function(x){
  paste0("#", x)
}

.class <- function(x){
  paste0(".", x)
}

# @param tag htmltools tag
# @param name character, the name of the tag must be in this vector
# @param class an attribute
# @param ... other names args checked as attributes
#
.tag_validate <- function(tag, name = NULL, class = NULL, ...){

  list_attrib <- list(...)

  # ensure we have a shiny tag
  if (!inherits(tag, "shiny.tag")){
    stop("tag is not a shiny.tag - tag must be generated using htmltools or shiny")
  }

  # if a name argument is provided
  if (!is.null(name)){
    # ensure that the name of the tag is among the provided name(s)
    if (!(tag$name) %in% name){
      stop("tag needs to be one of: ", paste(name, collapse = ", "))
    }
  }

  # if class is provided
  if (!is.null(class)){
    class_observed <- htmltools::tagGetAttribute(tag, "class")
    if (!identical(class_observed, class)){
      stop("class is: ", class_observed, ", needs to be: ", class)
    }
  }

  # for each additional attribute
  fn_validate <- function(name, value, tag){
    value_observed <- htmltools::tagGetAttribute(tag, name)
    if (!identical(value_observed, value)){
      stop("attribute ", name, " is: ", value_observed, ", needs to be: ", value)
    }
  }

  if (length(list_attrib) > 0){
    purrr::walk2(names(list_attrib), list_attrib, fn_validate, tag)
  }

  # make it pipeable (just in case)
  tag
}


# we will be able to get rid of this code
get_class <- function(tag){

  x <- htmltools::tagGetAttribute(tag, "class")
  x <- stringr::str_trim(x)
  x <- stringr::str_split(x, " ")

  x[[1]]
}
.id <- function(x){
  paste0("#", x)
}

.class <- function(x){
  paste0(".", x)
}

# @param tag htmltools tag
# @param name character, the name of the tag must be in this vector
# @param class an attribute
# @param ... other names args checked as attributes
#
.tag_validate <- function(tag, name = NULL, class = NULL, ...){

  list_attrib <- list(...)

  # ensure we have a shiny tag
  if (!inherits(tag, "shiny.tag")){
    stop("tag is not a shiny.tag - tag must be generated using htmltools or shiny")
  }

  # if a name argument is provided
  if (!is.null(name)){
    # ensure that the name of the tag is among the provided name(s)
    if (!(tag$name) %in% name){
      stop("tag needs to be one of: ", paste(name, collapse = ", "))
    }
  }

  # if class is provided
  if (!is.null(class)){
    class_observed <- htmltools::tagGetAttribute(tag, "class")
    if (!identical(class_observed, class)){
      stop("class is: ", class_observed, ", needs to be: ", class)
    }
  }

  # for each additional attribute
  fn_validate <- function(name, value, tag){
    value_observed <- htmltools::tagGetAttribute(tag, name)
    if (!identical(value_observed, value)){
      stop("attribute ", name, " is: ", value_observed, ", needs to be: ", value)
    }
  }

  if (length(list_attrib) > 0){
    purrr::walk2(names(list_attrib), list_attrib, fn_validate, tag)
  }

  # make it pipeable (just in case)
  tag
}


# we will be able to get rid of this code
get_class <- function(tag){

  x <- htmltools::tagGetAttribute(tag, "class")
  x <- stringr::str_trim(x)
  x <- stringr::str_split(x, " ")

  x[[1]]
}
#' Calculating distance between utility at tangency and at notch/kink point
#'
#' Ability (n) and elasticity (e) determine an agent's earnings and utility. This
#' function determines the tangency point of the agent's utility with the budget
#' line and returns the distance between the utility of earning at that point
#' and the utility of earning at the notch/kink point. This function is mostly
#' used to find the marginal buncher.
#'
#' @param n Ability of person (earnings with zero tax)
#' @param elas elasticity of earnings w.r.t.  net-of-tax rate
#' @param t1 Tax rate before notch/kink
#' @param t2 Tax rate after notch/kink
#' @param Tax height of notch (zero for pure kink)
#' @param zstar place of notch/kink (critical earning point)
#'
#' @return Absolute value of utility at tangency minus utility at kink/notch
#' point.
#'
#' @seealso \code{\link{util_calc}}
#'
#' @examples
#' util_equalizer(1200,0.2,0.1,0.3,100,1000)
#'
#' @export
#'

util_equalizer <- function(n,elas,t1,t2,Tax,zstar) {
  ## ---------------------------------------------------------------------------
  ## Error handling
  if (n < 0 | zstar < 0) {
    stop("Ability and zstar need to be non-negative")
  }
  ## ---------------------------------------------------------------------------
  # if earnings with t1 exceed zstar, tangency would be after the kink
  z <- n*((1-t1)^elas)
  if (z > zstar) {
    z <- n*((1-t2)^elas)
  }
  # utility at that earning:
  U_I <- util_calc(z,n,elas,t1,t2,Tax,zstar)
  #utility at notch
  U_N <- util_calc(zstar,n,elas,t1,t2,Tax,zstar)
  return(abs(U_I-U_N))
}
#' Calculating quasi-linear iso-elastic utility
#'
#' \deqn{u(z,n,elas,t1,t2,Tax,zstar) =}
#' \deqn{z * (1 - t1) + [z > zstar] * ((z - zstar)
#'  * (t2 - t1) - Tax) - n / (1 + (1 / elas)) * (z / n)^(1 + (1 / elas))}
#'
#' @param z Earnings
#' @param n Ability of person (earnings with zero tax)
#' @param elas elasticity of earnings w.r.t.  net-of-tax rate
#' @param t1 Tax rate before notch/kink
#' @param t2 Tax rate after notch/kink
#' @param Tax height of notch (zero for pure kink)
#' @param zstar place of notch/kink (critical earning point)
#'
#' @return The utility of earning sum z given other parameters.
#'
#' @examples
#' util_calc(900, 950, 0.2, 0.1, 0.2, 100, 1000)
#'
#' @export
#'


util_calc <- function(z, n, elas, t1, t2, Tax, zstar) {
  ## ---------------------------------------------------------------------------
  ## Error handling
  if (z < 0 | n < 0 | zstar < 0) {
    stop("Earnings, ability and zstar need to be non-negative")
  }
  ## ---------------------------------------------------------------------------
  # Utility for earnings below notch/kink threshold
  if (z <= zstar) {
    return(z - (t1 * z) - ((n/(1 + (1/elas))) * ((z/n)^(1 + (1/elas)))))
  }
  # Utility for earnings above notch/kink threshold
  return(z - t1 * zstar - (t2 * (z - zstar)) - Tax - ((n/(1 + (1/elas))) *
    ((z/n)^(1 + (1/elas)))))
}
#' @export
magrittr::`%>%`

#' @importFrom rlang sym
#'
case_id_ <- function(eventlog) sym(case_id(eventlog))
activity_id_ <- function(eventlog) sym(activity_id(eventlog))
activity_instance_id_ <- function(eventlog) sym(activity_instance_id(eventlog))
resource_id_ <- function(eventlog) sym(resource_id(eventlog))
timestamp_ <- function(eventlog) sym(timestamp(eventlog))
lifecycle_id_ <- function(eventlog) sym(lifecycle_id(eventlog))
# hidden utility functions ------------------------------------------------

na_to_zero <- function(x) {
  x[is.na(x)] <- 0
  as.matrix(x)
}

get_hard_cols <- function(x) {
  if (all(x==0)) {return(x)}
  if (sum(x==max(x)) > 1) {
    xx <- rep(0, length(x))
    xx[which(x==max(x))[1]] <- 1 # choose first one to break tie ####--->>> change to random
    return(xx)
  } else {
    return(ifelse(x==max(x),1,0))
  }
}
is.named <- function(x) {
  length(names(x)) == length(x) && all(names(x) != "")
}

set_envvar <- function(envs) {
  if (length(envs) == 0) return()

  stopifnot(is.named(envs))

  old <- Sys.getenv(names(envs), names = TRUE, unset = NA)
  set <- !is.na(envs)

  both_set <- set & !is.na(old)

  if (any(set))  do.call("Sys.setenv", as.list(envs[set]))
  if (any(!set)) Sys.unsetenv(names(envs)[!set])

  invisible(old)
}

with_envvar <- function(new, code) {
  old <- set_envvar(new)
  on.exit(set_envvar(old))
  force(code)
}

os_platform <- function() .Platform$OS.type

try_silently <- function(expr) try(expr, silent = TRUE)

enumerate <- function(x) {
  if (length(x) == 0) {
    ""
  } else if (length(x) == 1) {
    x
  } else {
    l <- length(x)
    paste0(paste(x[-l], collapse = ", "), " and ", x[[l]])
  }
}

strrep <- function(x, times) {
  x <- as.character(x)
  if (length(x) == 0L) return(x)
  r <- .mapply(
    function(x, times) {
      if (is.na(x) || is.na(times)) return(NA_character_)
      if (times <= 0L) return("")
      paste0(replicate(times, x), collapse = "")
    },
    list(x = x, times = times),
    MoreArgs = list()
  )

  unlist(r, use.names = FALSE)
}
#' @export
print.draft <- function(x, ...) {
    draft_table <- build_table(x, finish = FALSE)
    print(draft_table)
    invisible(x)
}

is_df <- function(data) {
    if (!is.data.frame(data))
        stop('Please supply a dataframe in the `data` arg.', call. = FALSE)
}

is_factor <- function(data, x) {
    if (!is.factor(data[[x]]))
        stop('Please use a factor variable for the header.', call. = FALSE)
}

is_draft <- function(data) {
    if (!'draft' %in% class(data))
        stop('Please use an objected created from `outline_table`.', call. = FALSE)
}

vars_type <- function(data, vars) {
    type <- sapply(data[vars], class)
    type <- gsub('integer', 'numeric', type)
    type <- gsub('character', 'factor', type)
    type <- unique(type)
    if (length(type) > 1) {
        stop('Please do not mix numeric and character/factor variables',
             ' in the ', type, '.', call. = FALSE)
    } else if (length(type) == 1) {
        return(type)
    }
}

vars_exist <- function(data, vars) {
    vars.want <- vars
    vars.have <- names(data)
    index <- vars.want %in% vars.have
    if (!any(index)) {
        vars <-
            paste(vars.want[which(!vars.want %in% vars.have)], separate = ', ')
        stop('The variables ',
             vars,
             ' do not exist in the dataset.',
             call. = FALSE)
    }
}
#' Standardize a vector
#'
#' @param y numeric vector
#' @export
standardized <- function(y) {
  y_mu <- mean(y, na.rm = T)
  y_sd <- sd(y, na.rm = T)
  stopifnot(!is.na(y_mu) && !is.nan(y_mu))
  stopifnot(!is.na(y_sd) && y_sd > 0)

  (y - y_mu) / y_sd
}

#' Destandardize a vector
#'
#' @param y_hat standardized numeric vector
#' @param y_mu a mean value of unstandarized vector
#' @param y_sd a standard deviation of unstandarized vector
#' @export
destandardized <- function(y_hat, y_mu, y_sd) {
  stopifnot(!is.na(y_mu) && !is.nan(y_mu))
  stopifnot(!is.na(y_sd) && y_sd > 0)

  y_hat * y_sd + y_mu
}
# Borrow functions from haven, automatically created by 'import_haven_utils.R'
labelled <-
function (x, labels) 
{
    if (!is.numeric(x) && !is.character(x)) {
        stop("`x` must be either numeric or a character vector", 
            call. = FALSE)
    }
    if (typeof(x) != typeof(labels)) {
        stop("`x` and `labels` must be same type", call. = FALSE)
    }
    if (is.null(labels)) {
        stop("`labels` must be a named vector", call. = FALSE)
    }
    structure(x, labels = labels, class = "labelled")
}
as_factor <-
function (x, ...) 
{
    UseMethod("as_factor")
}
as_factor.labelled <-
function (x, levels = c("labels", "values"), ordered = FALSE, 
    ...) 
{
    levels <- match.arg(levels)
    if (is.character(x)) {
        levs <- unname(attr(x, "labels"))
        labs <- switch(levels, labels = names(attr(x, "labels")), 
            values = levs)
        factor(x, levs, labels = labs, ordered = ordered)
    }
    else {
        labs <- attr(x, "labels")
        factor(match(x, labs), levels = unname(labs), labels = names(labs))
    }
}
as_factor.character <-
function (x, ...) 
{
    factor(x, ...)
}
`[.labelled` <-
function (x, ...) 
{
    labelled(NextMethod(), attr(x, "labels"))
}
################################################################################
# Miscellaneous subroutines. 

################################################################################
# Find whether all elements of a vector are equal. 
allEqual <- function(x) {
	if (!is.vector(x)) stop("x must be a vector") 
	isTRUE(all.equal(x, rep(x[1], length(x))))
}

# Find the smallest difference between any pair of values in a vector. 
minDifference <- function(x, allowZeroResult=FALSE) {  
	differences <- c(sort(x)[-1]) - c(sort(x)[-length(x)])
	if (allowZeroResult) {
		return(min(differences))
	} else {
		return(min(differences[differences!=0]))
	}
} 

# Find whether a factor has any unused levels.
hasUnusedLevels <- function(x) {
	if (!is.factor(x)) stop("x must be a factor")
	!identical(sort(levels(x)), sort(levels(droplevels(x))))
}

# Remove NAs from a vector. 
removeNAsFromVector <- function(x) {
	if (!is.vector(x)) stop("x must be a vector")
	as.vector(na.omit(x))  # or x[!is.na(x)]
}

################################################################################
# Set the S3 class of an object. "x <- setS3class(x, className)" is the same as 
# "class(x) <- className", but it works in S as well as R. This is partly based
# on the last few lines of survival:::summary.coxph and partly based on ?is.R.
setS3class <- function(x, className) {
	if (exists("is.R") && is.function(is.R) && is.R()) {
		# this code is being run in R
		class(x) <- className 
	} else { 
		# this code is being run in S
		oldClass(x) <- className
	}  
	return(x)
}
################################################################################
.mcga <- function(tbl) {

  x <- colnames(tbl)
  x <- tolower(x)
  x <- gsub("[[:punct:][:space:]]+", "_", x)
  x <- gsub("_+", "_", x)
  x <- gsub("(^_|_$)", "", x)
  x <- gsub("^x_", "", x)
  x <- make.unique(x, sep = "_")

  colnames(tbl) <- x

  tbl

}

to_num <- function(x) {
  x <- gsub("%", "", x, fixed=TRUE)
  x <- gsub(">", "", x, fixed=TRUE)
  x <- gsub("<", "", x, fixed=TRUE)
  x <- gsub(",", "", x, fixed=TRUE)
  x <- gsub(" ", "", x, fixed=TRUE)
  as.numeric(x)
}
char0_to_NA <- function(x) if (length(x) < 1) NA_character_ else x

isFALSE <- function(x) identical(x, FALSE)

isTOGGLE <- function(x) is.null(x) || isTRUE(x) || isFALSE(x)

isTRUE_v <- function(x) !is.na(x) & x

## https://twitter.com/kevin_ushey/status/710223546929119232
transpose <- function(list) do.call(Map, c(c, list))

## from
## https://github.com/hadley/purrr/blob/9534c29411f4ec262995498b0c2a78d0a619eae4/R/utils.R#L149-L155
## among other places
`%||%` <- function(x, y) if (is.null(x)) y else x

add_single_quotes <- function(x) {
  if (grepl("\\s+", x)) {
    x <- paste0("'", x, "'")
  }
  x
}

remove_single_quotes <- function(x) gsub("^'|'$", "", x)

rel_abs_format <- function(is_abs, rc_ref, fo = c("R1C1", "A1")) {
  fo <- match.arg(fo)
  if (fo == "A1") return(if (isTRUE_v(is_abs)) "$" else "")
  ## R1C1 case:
  if (isTRUE_v(is_abs)) return(rc_ref)
  ## unfortunate convention where R and C are used instead of R[0] and C[0]
  if (!is.na(rc_ref) && rc_ref == 0) "" else paste0("[", rc_ref, "]")
}

is_abs_ref <- function(x) {
  stopifnot(inherits(x, "ra_ref"))
  isTRUE(x$row_abs) && isTRUE(x$col_abs)
}

is_rel_ref <- function(x) {
  stopifnot(inherits(x, "ra_ref"))
  isFALSE(x$row_abs) && isFALSE(x$col_abs)
}

is_not_abs_ref <- function(x) {
  stopifnot(inherits(x, "ra_ref"))
  !isTRUE(x$row_abs) || !isTRUE(x$col_abs)
}

absolutize <- function(x) {
  stopifnot(inherits(x, "ra_ref"))
  x$row_abs <- x$col_abs <- TRUE
  x
}

relativize <- function(x) {
  stopifnot(inherits(x, "ra_ref"))
  x$row_abs <- x$col_abs <- FALSE
  x
}
CENSYS_API_URL <- "https://www.censys.io/api/v1/"

check_api <- function() {

  id <- Sys.getenv("CENSYS_API_ID")
  secret <- Sys.getenv("CENSYS_API_SECRET")

  if (id == "" | secret == "") {
    stop("Both CENSYS_API_ID and CENSYS_API_SECRET must be present in the R environment.")
  }

  return(httr::authenticate(id, secret))

}
#' Calculate the percentage change between two choroplethr dataframes.
#' 
#' Merges df1 and df2 on column named "region", and computes percentage change from
#' df1$value to df2$value. Result is in the new "value" column, and rounded to two
#' digits.
#' 
#' @param df1 A dataframe with columns named "region" and "value"
#' @param df2 A dataframe with columns named "region" and "value"
#' 
#' @examples
#' # load median age estimates from 2010 and 2015
#' data(df_state_age_2010)
#' data(df_state_age_2015)
#' 
#' df_age_diff = calculate_percent_change(df_state_age_2010, df_state_age_2015)
#' state_choropleth(df_age_diff, 
#'     title      = "Percent Change in Median Age, 2010-2015", 
#'     legend     = "Percent Change", 
#'     num_colors = 0)
#' 
#' @export
calculate_percent_change = function(df1, df2)
{
  stopifnot(c("region", "value") %in% colnames(df1))
  stopifnot(c("region", "value") %in% colnames(df2))
  
  # merge, calculate % change and round
  df = merge(df1, df2, by = "region")
  df$value = (df$value.y - df$value.x) / df$value.x * 100
  df$value = round(df$value, digits=2)
  
  df
}

#' Place two maps side by side
#' 
#' With an optional title. Especially useful for contrasting choropleth maps both with
#' and without a reference map underneath.
#' @param title An optional title
#' @param map1 The first map
#' @param map2 The second map
#' @importFrom gridExtra grid.arrange
#' @export
double_map = function(map1, map2, title = "")
{
  grid.arrange(map1, map2, ncol=2, top = title)
}
.create_unique_colname <- function(
  id = "id", # candidate name
  nm # vector containing the existing names
  ){
  new_id <- id
  k <- 0
  while(new_id %in% nm) {
    new_id <- paste(id, k, sep = "")
    k <- k + 1
  }
  id
}

.is.spatial <- function(x) {
  if (inherits(x, "Spatial") | inherits(x, "Raster"))
    res <- TRUE
  else
    res <- FALSE

  res
}
`%||%` <- function(l, r) if (is.null(l)) r else l

make_space <- function(len) {
  strrep(" ", len)
}

strrep <- function(x, ...) {
  res <- base::strrep(x, ...)
  Encoding(res) <- Encoding(x)
  res
}

is_utf8_output <- function() {
  opt <- getOption("cli.unicode", NULL)
  if (! is.null(opt)) {
    isTRUE(opt)
  } else {
    l10n_info()$`UTF-8` && !is_latex_output()
  }
}

is_latex_output <- function() {
  if (!("knitr" %in% loadedNamespaces())) return(FALSE)
  get("is_latex_output", asNamespace("knitr"))()
}

apply_style <- function(text, style, bg = FALSE) {
  if (identical(text, ""))
    return(text)

  if (is.function(style)) {
    style(text)
  } else if (is.character(style)) {
    crayon::make_style(style, bg = bg)(text)
  } else if (is.null(style)) {
    text
  } else {
    stop("Not a colour name or crayon style", call. = FALSE)
  }
}

vcapply <- function(X, FUN, ..., USE.NAMES = TRUE) {
  vapply(X, FUN, FUN.VALUE = character(1), ..., USE.NAMES = USE.NAMES)
}

viapply <- function(X, FUN, ..., USE.NAMES = TRUE) {
  vapply(X, FUN, FUN.VALUE = integer(1), ..., USE.NAMES = USE.NAMES)
}

ruler <- function(width = console_width()) {
  x <- seq_len(width)
  y <- rep("-", length(x))

  y[x %% 5 == 0] <- "+"
  y[x %% 10 == 0] <- crayon::bold(as.character((x[x %% 10 == 0] %/% 10) %% 10))

  cat(y, "\n", sep = "")
  cat(x %% 10, "\n", sep = "")
}

rpad <- function(x, width = NULL) {
  if (!length(x)) return(x)
  w <- nchar(x, type = "width")
  if (is.null(width)) width <- max(w)
  paste0(x, strrep(" ", pmax(width - w, 0)))
}

lpad <- function(x, width = NULL) {
  if (!length(x)) return(x)
  w <- nchar(x, type = "width")
  if (is.null(width)) width <- max(w)
  paste0(strrep(" ", pmax(width - w, 0)), x)
}
utility.coh <- 
function(aff,unaff) {
cohort <- c(aff,unaff)
n <- sum(cohort)
X1=aff[1];  X2=aff[2]; X3=aff[3]; X4=aff[4];
Y1=unaff[1];  Y2=unaff[2]; Y3=unaff[3]; Y4=unaff[4];
int.est <- X1/(X1 + Y1) - X2/(X2 + Y2) - X3/(X3 + Y3) + X4/(X4 + Y4)
uti.est <- (X2 + X4 + Y2 + Y4)/n*(1 - (X2 + X4 + Y2 + Y4)/n)*int.est
varuti.est <- VarUti.coh(cohort)
lower <- uti.est-qnorm(0.975)*varuti.est^0.5
upper <- uti.est+qnorm(0.975)*varuti.est^0.5
res <- NULL
res$Utility.coh <- c(Estimate=uti.est,Variance=varuti.est,Lower=lower,Upper=upper)
return (res)
}
utility.cc <- 
function(cases, contr, pD,pG) {
n1 <- sum(cases)
n0 <- sum(contr)
X1=cases[1];  X2=cases[2]; X3=cases[3]; X4=cases[4];
Y1=contr[1];  Y2=contr[2]; Y3=contr[3]; Y4=contr[4];
res <- NULL
if(pD[1]<1) {
q <- pD*n0/(1-pD)/n1
int.est <- q*(X1/(q*X1 + Y1) - X2/(q*X2 + Y2) - X3/(q*X3 + Y3) + X4/(q*X4 + Y4))
varint.est <- VarInt.cc.pD(pD,c(cases,contr))
}
if(pD[1]>1) {
XD=pD[1];YD=pD[2]
nD=XD+YD
q <- XD/nD*n0/(YD/nD)/n1
int.est <-  q*(X1/(q*X1 + Y1) - X2/(q*X2 + Y2) - X3/(q*X3 + Y3) + X4/(q*X4 + Y4))
varint.est <- VarInt.cc(c(cases,contr,pD))
}
if(pG[1]<1) {
  uti.est <- pG*(1-pG)*int.est
  varuti.est <- varint.est
}
if(pG[1]>1) {
  XG=pG[1]; YG=pG[2]
  nG=XG+YG
  uti.est <- XG/nG*(1-XG/nG)*int.est
  if(pD[1]<1) varuti.est <- VarUti.cc.pD(pD,c(cases,contr,pG))
  if(pD[1]>1) varuti.est <- VarUti.cc(c(cases,contr,pD,pG))
}
lower <- uti.est-qnorm(0.975)*varuti.est^0.5
upper <- uti.est+qnorm(0.975)*varuti.est^0.5
res <- NULL
res$Utility.cc <- c(Estimate=uti.est,Variance=varuti.est,Lower=lower,Upper=upper)
return (res)
}
#' Convert between paired results and the canonical contingency tables
#'
#' Group results by common clustering then tally the concordant and discordant
#' pairs.
#'
#' @param group List of grouping values
#' @param t1 pre-treatment measures
#' @param t2 post-treatment measures
#'
#' @return Contingency tables represented in the rows of a matrix
#'
#' @examples
#'
#' paired.to.contingency(list(obfuscation$subject, obfuscation$atom),
#'                       obfuscation$control, obfuscation$treatment)
#'
#' @export
paired.to.contingency <- function(group, t1, t2)
  stats::aggregate(t(mapply(.count.contingency.pair, t1, t2)), by=group, FUN=sum)

#' Convert between nested results and the canonical contingency tables
#'
#' Sum all concordant and discordant pairs from each nested group into a
#' contingency table.
#'
#' @param t1 lists of pre-treatment measures
#' @param t2 lists of post-treatment measures
#'
#' @return Contingency tables represented in the rows of a matrix
#'
#' @examples
#'
#' nested.to.contingency(thyroids$x.pet, thyroids$x.spect)
#'
#' @export
nested.to.contingency <- function(t1, t2)
  data.frame(t(apply(cbind(t1, t2), 1, function(x) .count.contingency(x[1], x[2]))))

# fill a vector [ak, bk, ck, dk] with the counts from matched pair data [t1, t2]
.count.contingency <- function(t1, t2)
  colSums(t(mapply(function(r1, r2) {.count.contingency.pair(r1, r2)}, unlist(t1), unlist(t2))))

# return the contingency table for a single matched pair of data
.count.contingency.pair <- function(r1, r2) {
  contingency <- c(ak = 0, bk = 0, ck = 0, dk = 0)
  idx <- 1 + 2*as.integer(!as.logical(r1)) + as.integer(!as.logical(r2))
  replace(contingency, idx, contingency[idx] + 1)
}

# test that a number is numerically integral, without regard to it's storage type
.is.whole <- function(x) all(is.numeric(x) & floor(x)==x)
#' Hierachical clustering
#' Convenient methods for hierachical clustering
#'
#' @param df data frame
#' @param method method to use, see \code{\link{hclust}}
#' @param metric distance metric to use, see \code{\link{dist}}
#' @param n number of clusters to retrieve, see \code{\link{cut}}
#' @keywords cluster
hierarchical <- function(df, method="complete", metric="euclidean", n=5) {
  if (metric == 'correlation') {
    df <- scale(as.matrix(df))
    metric <- "euclidean"
  }
  as.vector(cutree(hclust(dist(df, metric), method=method), n))
}

#' Clarify matrix
#' Clarify matrix ordering to minimize off diagonals
#'
#' @param a cluster assignments to reassign
#' @param b matrix b
#' @param method clarification method
#' @return vector of reassigned cluster a
#' @keywords manip
#' @seealso \code{\link[e1071]{matchClasses}}
#' @importFrom e1071 matchClasses
clarify <- function(a, b, method="greedy") {
  m <- matchClasses(table(a,b), method=method, verbose=FALSE)
  as.vector(m[a])
}


rescaler <- function(df, type = "sd") {
  f <- switch(type,
    rank = function(x, ...) rank(x, ...),
    var = , sd = function(x) (x - mean(x, na.rm = TRUE)) / sd(x, na.rm = TRUE),
    robust = function(x) (x - median(x, na.rm = TRUE)) / mad(x, na.rm = TRUE),
    I = function(x) x,
    range = function(x) (x - min(x, na.rm = TRUE)) / diff(range(x, na.rm = TRUE)))

  continuous <- vapply(df, is.numeric, logical(1))
  df[continuous] <- lapply(df[continuous], f)
  df
}

compact <- function(x) Filter(Negate(is.null), x)
#' Pipe operator
#'
#' See \code{magrittr::\link[magrittr]{\%>\%}} for details.
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @export
#' @importFrom magrittr %>%
#' @usage lhs \%>\% rhs
NULL
#' @importFrom utils installed.packages
get_root_path <- function(pkg){
  installed <- installed.packages()
  if(pkg %in% installed[,1]){
    root <- base::system.file(".", package = pkg)
  } else if(file.exists(file.path(pkg, "DESCRIPTION"))){
    root <- pkg
  } else {
    if(is.character(pkg)){
      root <- pkg # use pkg as guess anyway
#    } else {
#      root <- "." # stick with default
    }
  }
  root
}


## based on devtools::read_dcf
cm_read_dcf <- function(dcf) {

  fields <- colnames(read.dcf(dcf))
  as.list(read.dcf(dcf, keep.white = fields)[1, ])

}

## Like system.file, but pkg can instead be path to package root directory
get_file <- function(FILE, pkg = "."){
  f <- file.path(pkg, FILE)
  if(file.exists(f))
    f
  else {
    f <- system.file(FILE, package = pkg)
  }
}






is_IRI <- function(string){
  ## FIXME IRI can be many other things too,
  #see https://github.com/dgerber/rfc3987 for more formal implementation
  grepl("^http[s]?://", string)
}
#used in construct_formula() to form the rhs part of the formula
rhs_formula <- function(vars) {
 
 #length of names i.e. variables
 len <- length(vars)
 
 #construct coefs
 coefs <- paste0('param_', vars)
 
 #coef * variable pair
 coef_var <- paste(coefs, vars, sep = ' * ')
 
 #rhs of nls formula
 rhs_form <- paste(coef_var, collapse = ' + ')
 
 #add the names attribute
 attr(rhs_form, 'coefs') <- coefs
 
 rhs_form
 
}
#' Estimate the Temporal Autocorrelation of a Numeric Vector
#'
#' A wrapper for the \code{\link[stats]{acf}} function from the stats package that
#' extracts only the temporal autocorrelation at a lag of one timestep (which is
#' the type of temporal autocorrelation that this package simulates).
#'
#' @param x A numeric vector.
#' @param na.action The way the function will handle NAs in the vector. Set to \code{\link[stats]{na.pass}} by default.
#' @return A single numeric value: the estimate of the temporal autocorrelation with a lag of 1.
#' @examples
#' rednoise <- raw_noise(timesteps = 50, mu = 0.5, sigma = 0.2, phi = 0.3)
#' autocorrelation(rednoise)
#' @export
autocorrelation <- function(x, na.action = na.omit) {
    acf(x, plot = F, na.action = na.action)[[1]][2]
}
#' @useDynLib combiter, .registration = TRUE
#' @importFrom Rcpp sourceCpp
NULL
check_use <- function(use)
{
  match.arg(
    tolower(use),
    c("everything", "all.obs", "complete.obs", "pairwise.complete.obs")
  )
}



is.vec <- function(x)
{
  is.vector(x) && !is.list(x)
}



check.is.flag <- function(x)
{
  if (!(is.logical(x) && length(x) == 1 && (!is.na(x))))
  {
    nm <- deparse(substitute(x))
    stop(paste0("argument '", nm, "' must be TRUE or FALSE"))
  }
  
  invisible()
}



check_badvals <- function(x)
{
  .Call(R_check_badvals, x)
}
#  Copyright 2017 Patrick O. Perry.
#
#  Licensed under the Apache License, Version 2.0 (the "License");
#  you may not use this file except in compliance with the License.
#  You may obtain a copy of the License at
#
#      http://www.apache.org/licenses/LICENSE-2.0
#
#  Unless required by applicable law or agreed to in writing, software
#  distributed under the License is distributed on an "AS IS" BASIS,
#  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
#  See the License for the specific language governing permissions and
#  limitations under the License.


with_rethrow <- function(expr)
{
    parentcall <- sys.call(-1)
    eval(envir = parent.frame(),
        withCallingHandlers(expr,
            error = function(e, call = parentcall) {
                e$call <- call
                stop(e)
            },
            warning = function(w, call = parentcall) {
                w$call <- call
                warning(w)
                invokeRestart("muffleWarning")
            },
            message = function(m, call = parentcall) {
                m$call <- call
            }
        )
    )
}


with_package <- function(package, expr)
{
    if (!isNamespaceLoaded(package)) {
        if (!requireNamespace(package, quietly = TRUE)) {
            stop(sprintf("Failed attaching name space for package '%s'",
                         package))
        }
    }

    force(expr)
    expr
}
#' Add a first column to a data.frame
#' 
#' Add a first column to a data.frame. This is most commonly used toappend a
#' rowname column to create a cor_df.
#' 
#' @param df Data frame
#' @param ... Values to go into the column
#' @param var Label for the column. Default is "rowname"
#' @export
#' @examples 
#' first_col(mtcars, 1:nrow(mtcars))
first_col <- function(df, ..., var = "rowname") {
  stopifnot(is.data.frame(df))
  
  if (tibble::has_name(df, var))
    stop("There is a column named ", var, " already!")

  new_col <- tibble::tibble(...)
  names(new_col) <- var
  new_df <- c(new_col, df)
  dplyr::as_data_frame(new_df)
}

#' Number of pairwise complete cases.
#' 
#' Compute the number of complete cases in a pairwise fashion for \code{x} (and
#' \code{y}).
#' 
#' @inheritParams stats::cor
#' @return Matrix of pairwise sample sizes (number of complete cases).
#' @export
#' @examples
#' pair_n(mtcars)
pair_n <- function(x, y = NULL) {
  if (is.null(y)) y <- x
  x <- t(!is.na(x)) %*% (!is.na(y))
  class(x) <- c("n_mat", "matrix")
  x
}

#' Convert cor_df to original matrix.
#' 
#' Convert a correlation data frame to original matrix format.
#' 
#' @param x cor_df. See \code{\link{correlate}}.
#' @param diagonal Value (typically numeric or NA) to set the diagonal to.
#'   Default = 1.
#' @return Correlation matrix
#' @export
#' @examples
#' x <- correlate(mtcars)
#' as_matrix(x)
as_matrix <- function(x, diagonal = 1) {
  UseMethod("as_matrix")
}
is.numsca <- function(x) is.numeric(x) & (length(x) == 1)
is.numint <- function(x) is.integer(x) & (length(x) == 1)
is.numvec <- function(x) is.vector(x) & is.numeric(x)
is.nummat <- function(x) is.matrix(x) & is.numeric(x)
is.samelength <- function(x,y){
    if(is.nummat(x) & is.nummat(y))
        return(all(dim(x)==dim(y)))
    if(is.numvec(x) & is.nummat(y))
        return(length(x) == dim(y)[1])
    if(is.nummat(x) & is.numvec(y))
        return(dim(x)[1] == length(y))
    if(is.numvec(x) & is.numvec(y))
        return(length(x) == length(y))
    return(FALSE)
}
# Fit location-scale family----
fit_locationScale <- function(lambda, dist) {
    # Use method of moments
    muTW <- -1.2065335745820
    sigmaTW <- sqrt(1.607781034581)

    muS <- mean(log(dist))
    sigmaS <- stats::sd(log(dist))

    sigma1 <- sigmaS/sigmaTW
    mu1 <- muS - sigma1 * muTW

    TW <- (log(lambda) - mu1)/sigma1
    pvalue <- ref_dist(TW)

    return(pvalue)
}

# This may change to some other function in the future
ref_dist <- function(x) RMTstat::ptw(x, beta = 1, lower.tail = FALSE, log.p = FALSE)

# Compute test statistic----
compute_largest_root <- function(first_mat, second_mat) {
    first_mat_c <- scale(first_mat, center = TRUE, scale = FALSE)
    W <- crossprod(scale(second_mat, center = TRUE, scale = FALSE))

    svdRes <- corpcor::fast.svd(first_mat_c)
    Xp <- svdRes$v %*% diag(1/svdRes$d)
    C <- crossprod(Xp, W %*% Xp)
    svdC <- corpcor::fast.svd(C)
    Xpp <- svdC$u
    singWeights <- Xp %*% Xpp
    largestRoot <- max(crossprod(singWeights,  W %*% singWeights))

    return(largestRoot)
}

# Permutations----
permutation <- function(X, Y, nperm) {
    if (nrow(X) < nrow(Y)) {
        first_mat <- X
        second_mat <- Y
    } else {
        first_mat <- Y
        second_mat <- X
    }
    combined_data <- rbind(first_mat, second_mat)
    n1 <- nrow(first_mat)
    n2 <- nrow(second_mat)
    replicate(nperm, {
        indices <- sample(1:(n1 + n2), n1)
        first_mat_perm <- combined_data[indices,]
        second_mat_perm <- combined_data[which(!1:(n1 + n2) %in% indices),]
        compute_largest_root(first_mat_perm, second_mat_perm)
    })
}
# code that needed to be copied from ggplot2

# @keyword internal
is.waive <- function(x) inherits(x, "waiver")
format_iso_8601 <- function (date) {
  format(as.POSIXlt(date, tz = "UTC"), "%Y-%m-%dT%H:%M:%S+00:00")
}

pkgname_from_filename <- function(files) {
  vapply(strsplit(basename(files), "_", fixed = TRUE), "[[", "", 1)
}

#' @importFrom utils getFromNamespace

`%:::%` <- function(pkg, fun) {
  getFromNamespace(fun, asNamespace(pkg))
}

check_existing_files <- function(files) {

  miss <- ! file.exists(files)

  if (sum(miss) == 1) {
    stop("File does not exist: ", files[miss])

  } else if (sum(miss) > 1) {
    stop("Files do not exist: ", paste(files[miss], collapse = ", "))
  }
}

drop_nulls <- function(l) {
  l[ ! vapply(l, is.null, TRUE) ]
}
# Copyright (C) 2018 Ioannis Kosmidis

## firstup <- function(x) {
##     stri_trans_totitle(x, opts_brkiter = stri_opts_brkiter(type = "sentence"))
## }

split_and_replace <- function(string, base_patterns, replacement,
                              nparts = ceiling(length(base_patterns)/5), fixed_word = TRUE) {
    ns <- length(base_patterns)
    np <- floor(ns/nparts)
    u <- c(rep(np, nparts - 1), ns - np * (nparts - 1))
    parts <- rep(seq.int(nparts), u)
        if (fixed_word) {
            out <- lapply(split(base_patterns, parts), function(x) {
                paste0("(?i)\\b", x, "\\b", collapse = "|")
            })
        }
        else {
            out <- lapply(split(base_patterns, parts), function(x) {
                paste0("(?i)", x, collapse = "|")
            })
        }
    for (j in seq_along(out)) {
        string <- str_replace_all(string, out[[j]], replacement)
        }
    string
}
# archivos <- list.files("data/")
# 
# rutas <- paste("data/", archivos, sep= "")
# 
# #Calculando el numero de elementos
# n <- length(archivos)
# datos <- list()
# 
# for( i in 1:n) {
#   datos[[i]] <- readRDS(rutas[i])
# }
# 
# 
# # Ensamblaje de todas tablas -------------------------------------------------
# 
# library(data.table)
# # Funcion: rbindlist
# # Esta funcion sirve para juntar juntar una lista (tabla) una debajo de otra.
# 
# # Como sabemos datos, es una lista que contine data.frames.
# cropdatape <- rbindlist(datos)
# 
# saveRDS(tbem_tomate,"tabla_tomate.rds")
# 
# 
# fp <- file.choose()
# 
# datos <- readxl::read_excel(fp)
# datos <- as.data.frame(datos)
# datos$department <- as.factor(datos$department) 
# datos$month <- as.factor(datos$month)
# datos$harva <- as.numeric(datos$year)
# datos$crop <- as.factor(datos$crop)
# 
# cropdatape <- datos
# save(cropdatape, file = "data/cropdatape.rda")
# 
# # Data from 2014 use diferent units ---------------------------------------
# library(dplyr)
# cp14 <- filter(cropdatape, year == 2014)
# 
## Tranformando las variables 
# # sowa"       "harva"      "production" "yield" "pricePlot" 
# # yield = tn/ha --> 1000kg/ha (yield * 1000)
# # pricePlot =  Nuevos Soles/Tonelada --> nuevos.soles/1000kg (pricePlot/1000)
# 
# cp14$yield <- cp14$yield*1000
# cp14$pricePlot <- cp14$pricePlot/1000
# 
# 
# cp <- filter(cropdatape, year != 2014)
# res <- rbind(cp, cp14)
# cropdatape <- res
# 
# save(cropdatape, file = "data/cropdatape.rda")
# 
#
#' @useDynLib curl R_curl_version
#' @export
#' @rdname curl_options
#' @examples
#' # Curl/ssl version info
#' curl_version()
curl_version <- function(){
  .Call(R_curl_version);
}

#' @rdname curl_options
#' @format A data frame with columns:
#' \describe{
#' \item{name}{Symbol name}
#' \item{introduced,deprecated,removed}{Versions of libcurl}
#' \item{value}{Integer value of symbol}
#' \item{type}{If an option, the type of value it needs}
#' }
"curl_symbols"

#' Parse date/time
#'
#' Can be used to parse dates appearing in http response headers such
#' as \code{Expires} or \code{Last-Modified}. Automatically recognizes
#' most common formats. If the format is known, \code{\link{strptime}}
#' might be easier.
#'
#' @param datestring a string consisting of a timestamp
#' @useDynLib curl R_curl_getdate
#' @export
#' @examples
#' # Parse dates in many formats
#' parse_date("Sunday, 06-Nov-94 08:49:37 GMT")
#' parse_date("06 Nov 1994 08:49:37")
#' parse_date("20040911 +0200")
parse_date <- function(datestring){
  out <- .Call(R_curl_getdate, datestring);
  class(out) <- c("POSIXct", "POSIXt")
  out
}


#' @useDynLib curl R_split_string
split_string <- function(x, split = ":"){
  .Call(R_split_string, x, split)
}

trimws <- function(x) {
  sub("\\s+$", "", sub("^\\s+", "", x))
}
.apply_args <- function(fun, args, last = FALSE) {
    fmls <- formals(fun)
    arg_env <- attr(fun, 'arg_env')
    formals(fun) <- fmls[!names(fmls) %in% names(args)]
    if (last) {
        assign('args_end', append(args, arg_env$args_end), envir = arg_env)
    } else {
        assign('args', append(arg_env$args, args), envir = arg_env)
    }
    structure(fun, class = 'scaffold', arg_env = arg_env)
}

is_missing_arg <- function(x) identical(x, quote(expr = ))
getArgs <- function(added_env) {
    function() {
        env <- parent.frame()
        args <- names(formals(sys.function(sys.parent(1))))

        vals <- mget(args, envir = env)
        ellipsis <- names(vals) == '...'
        if (any(ellipsis)) {
            vals <- append(vals, eval(quote(list(...)), env), which(ellipsis))
            vals[ellipsis] <- NULL
        }
        vals <- vals[!vapply(vals, is_missing_arg, logical(1))]

        c(added_env$args, vals, added_env$args_end)
    }
}
what_expr <- function(expr) {
  if (is.call(expr)) {
    paste0(as.character(expr[[1]])[1], "()")

  } else {
    typeof(expr)
  }
}

## We need the tryCatch, because the string might contain invalid
## multi-byte characters. E.g.
## substring('\x93', 1, 10) and nchar('\x93') both fail

what_atomic <- function(expr) {
  if (is.character(expr)) {
    tryCatch(
      paste0("\"", substring(expr[1], 1, 10), "\""),
      error = function(e) "\"<string>\""
    )
  } else if (is.name(expr)) {
    as.character(expr)
  } else {
    "atomic"
  }
}
# remove leading/trailing blanks around all strings in data.frame cols
trim_df <- function(df, stringsAsFactors=FALSE) {
  data.frame(lapply(df, function (v) {
    if (is.character(v)) {
      trimws(v)
    } else {
      v
    }
  }), stringsAsFactors=stringsAsFactors)
}
.rawToString <- function(raw, ...) {
  # This approach drops all '\0', in order to avoid warnings
  # in rawToChar().  Note, it does not truncate the string after
  # the first '\0'.  However, such strings should never occur in
  # the first place.
  raw <- raw[raw != as.raw(0)]
  rawToChar(raw)
} # .rawToString()

.readRaw <- function(con, n=1L, ...) {
  readBin(con, what="raw", n=n)
}

.readByte <- function(con, n=1L, ...) {
  readBin(con, what="integer", n=n, size=1L, signed=FALSE)
}

.readUShort <- function(con, n=1L, ...) {
  readBin(con, what="integer", n=n, size=2L, signed=FALSE, endian="little")
}

.readInt <- function(con, n=1L, ...) {
  readBin(con, what="integer", n=n, size=4L, signed=TRUE, endian="little")
}

.readFloat <- function(con, n=1L, ...) {
  readBin(con=con, what="double", n=n, size=4L, signed=TRUE, endian="little")
}

.readString <- function(con, n, ...) {
  .rawToString(.readRaw(con, n=n))
}
`%||%` <- function(left, right){
  if (!is.null(left)){
    return(left)
  }
  right
}
# all non-exported / unused internal (utility) functions

# which.first
which.first <- function(x)
{
    if (!is.logical(x)) {
        stop("x not boolean")
    }
    match(TRUE, x)
}

# which.last
which.last <- function(x)
{
    if (!is.logical(x)) {
        stop("x not boolean")
    }
    length(x) - match(TRUE, rev(x)) +1
}

# trim
trim <- function(x) {
    # Removes whitespace at the beginning and end of strings
    # Assigning to x[] to retain the original dimensions, rownames and colnames
    x[] = gsub(" +$", "", x)
    x[] = gsub("^ +", "", x)
    x
}

# take (I don't see it being used anywhere)
take <- function(x, n=1)
{
    # returns the head of head, without the last n observations
    # convenient when inlining expressions
    # NROW, for vectors, returns the vector length, but we cater for non-table like lists also here
    # TO DO: allow taking along any dimension e.g. all but last column, rather than all but last row.
    if (is.list(x) && !is.data.frame(x)  && !is.data.table(x)) l = length(x)
    else l = NROW(x)
    if (l < n) stop("Cannot take ",n," from ",l)
    head(x, l-n)
}
# TODO: Implement take as UseMethod. Specific methods for each type.

# plus
"%+%" <- function(x,y)
UseMethod("%+%")

"%+%.default" <- function(x,y) paste(paste(x,collapse=","),paste(y,collapse=","),sep="")
# we often construct warning msgs with a msg followed by several items of a vector, so %+% is for convenience

require_bit64 = function() {
  # called in fread and print when they see integer64 columns are present
  if (!requireNamespace("bit64",quietly=TRUE))
    warning("Some columns are type 'integer64' but package bit64 is not installed. Those columns will print as strange looking floating point data. There is no need to reload the data. Simply install.packages('bit64') to obtain the integer64 print method and print the data again.")
}
"data.world-r
Copyright 2018 data.world, Inc.

Licensed under the Apache License, Version 2.0 (the \"License\");
you may not use this file except in compliance with the License.

You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an \"AS IS\" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied. See the License for the specific language governing
permissions and limitations under the License.

This product includes software developed at data.world, Inc.
https://data.world"

#' Return the current data.world version.
#' @return Current package version.
#' @keywords internal
sdk_version <- function() {
  is.nothing <- function(x)
    is.null(x)
  # nolint start
  if (!is.nothing(utils::sessionInfo()$otherPkgs$data.world)) {
    ret <- utils::sessionInfo()$otherPkgs$dwapi$Version
  } else {
    ret <- "X.X.X"
  }
  # nolint end
  ret
}

#' Return the data.world user-agent.
#' @return User-agent string.
#' @keywords internal
user_agent <- function() {
  ret <- sprintf("data.world-R - %s", sdk_version())
  ret
}

#' Extract the dataset key from URL or as provided.
#' @param tentative_key key or URL.
#' @return dataset key extracted form URL or as provided.
#' @keywords internal
extract_dataset_key <- function(tentative_key) {
  url <- httr::parse_url(tentative_key)
  return(url$path)
}
unzip_ <- function(path) {
  if (is.na(path)) return(NA)
  if (!file.exists(path)) stop("The file ", path, " does not exist", call. = FALSE)
  extracted_files <- utils::unzip(path, exdir = tempdir(), list = TRUE)
  if (nrow(extracted_files) == 1) {
    utils::unzip(path, exdir = tempdir())
    return(file.path(tempdir(), extracted_files[["Name"]]))
  } else {
    return(NA)
  }
}
first_row_to_header <- function(a_table){
  colnames(a_table) <- a_table[1, ]
  colnames(a_table) <- gsub(" ", ".", colnames(a_table))
  a_table <- a_table[-1, ]
  rownames(a_table) <- seq(nrow(a_table))
  a_table
}

is_rstudio_selection <- function(){
  context <- rstudioapi::getActiveDocumentContext()
  !all(context$selection[[1]]$range$start ==
         context$selection[[1]]$range$end)
}
#' @export
print.dataset_statement <- function(x, ...) {
    cat("Dataset:            ", x$title, "\n")
    cat("id:                 ", x$id, "\n")
    if (length(x$author) > 1) {
        cat("authors:\n", paste0(" ", x$author, collapse = "\n"), "\n")
    } else if (length(x$author) == 1) {
        cat("author:             ", x$author, "\n")
    }
    cat("files:              ", length(x$files), "\n")
    cat("updated:            ", format(strptime(x$updated, "%FT%H:%M:%OS")), "\n")
    cat("latestVersionState: ", x$latestVersionState, "\n")
    cat("locked:             ", x$locked, "\n")
    cat("isMinorUpdate:      ", x$isMinorUpdate, "\n\n")
    invisible(x)
}

parse_dataset_statement <- function(xml) {
    xmllist <- xml2::as_list(xml2::read_xml(xml))
    out <- list()
    out$id <- strsplit(xmllist$id[[1L]], "doi:", fixed = TRUE)[[1L]][2]
    out$edit_url <- xmllist$id[[1L]]
    out$title <- xmllist$title[[1L]]
    out$author <- unname(unlist(xmllist$author))
    out$updated <- xmllist[["updated"]][[1L]]
    if (any(names(xmllist) == "entry")) {
        out$files <- list()
        for (i in which(names(xmllist) == "entry")) {
            out$files[[length(out$files) + 1]] <- 
                list(id = regmatches(xmllist[[i]]$id[[1L]], regexpr("(?<=file/).+(?=/)", xmllist[[i]]$id[[1L]], perl = TRUE)),
                     url = xmllist[[i]]$id[[1L]], 
                     title = xmllist[[i]]$title[[1L]],
                     summary = xmllist[[i]]$summary[[1L]],
                     updated = xmllist[[i]]$updated[[1L]])
        }
    }
    for (i in which(names(xmllist) == "category")) {
        tmp <- xmllist[[i]][[1L]]
        if (tolower(tmp) %in% c("true", "false")) {
            tmp <- as.logical(tmp)
        }
        out[[unname(attributes(xmllist[[i]])[["term"]])]] <- tmp
        
    }
    structure(out, class = "dataset_statement")
}
#' @export
print.dataset_atom <- function(x, ...) {
    cat("ID: ", x$id, "\n", sep = "")
    cat("Generator: ", paste0(x$generator, collapse = " "), "\n", sep = "")
    cat("Treatment: ", x$treatment, "\n", sep = "")
    cat("Links:\n")
    for (i in seq_along(x$links)) {
        cat(" ", formatC(names(x$links))[i], ": ", unname(x$links[[i]]), "\n", sep = "")
    }
    cat("Citation: ", x$bibliographicCitation, "\n\n")
    invisible(x)
}

parse_atom <- function(xml){
    xmllist <- xml2::as_list(xml2::read_xml(xml))
    links <- lapply(xmllist[names(xmllist) == "link"], attr, "href")
    names(links) <- unlist(lapply(xmllist[names(xmllist) == "link"], attr, "rel"))
    names(links)[grep("statement$", names(links))] <- "statement"
    names(links)[grep("add$", names(links))] <- "add"
    xmlout <- list(id = xmllist$id[[1L]],
                   links = links,
                   bibliographicCitation = xmllist$bibliographicCitation[[1L]],
                   generator = attributes(xmllist$generator),
                   treatment = xmllist$treatment[[1]])
    xmlout$xml <- xml
    structure(xmlout, class = "dataset_atom")
}
wrap <- function(..., indent = 0) {
  x <- paste0(..., collapse = "")
  wrapped <- strwrap(
    x,
    indent = indent,
    exdent = indent + 2,
    width = getOption("width")
  )

  paste0(wrapped, collapse = "\n")
}

rule <- function(pad = "-", gap = 2L) {
  paste0(rep(pad, getOption("width") - gap), collapse = "")
}

named_rule <- function(..., pad = "-") {
  if (nargs() == 0) {
    title <- ""
  } else {
    title <- paste0(...)
  }
  paste0(title, " ", rule(pad = pad, gap = nchar(title) - 1))
}

# function for the thousand separator,
# returns "," unless it's used for the decimal point, in which case returns "."
'big_mark' <- function(x, ...) {
  mark <- if (identical(getOption("OutDec"), ",")) "." else ","
  formatC(x, big.mark = mark, ...)
}
dots <- function(...) {
  eval_bare(substitute(alist(...)))
}

deparse_trunc <- function(x, width = getOption("width")) {
  text <- deparse(x, width.cutoff = width)
  if (length(text) == 1 && nchar(text) < width) return(text)

  paste0(substr(text[1], 1, width - 3), "...")
}

all_apply <- function(xs, f) {
  for (x in xs) {
    if (!f(x)) return(FALSE)
  }
  TRUE
}

any_apply <- function(xs, f) {
  for (x in xs) {
    if (f(x)) return(TRUE)
  }
  FALSE
}

drop_last <- function(x) {
  if (length(x) <= 1L) return(NULL)
  x[-length(x)]
}

is.wholenumber <- function(x) {
  trunc(x) == x
}

deparse_all <- function(x) {
  x <- map_if(x, is_formula, f_rhs)
  map_chr(x, expr_text, width = 500L)
}

deparse_names <- function(x) {
  x <- map_if(x, is_formula, f_rhs)
  map_chr(x, deparse)
}

#' Provides comma-separated string out ot the parameters
#' @export
#' @keywords internal
#' @param ... Arguments to be constructed into the string
named_commas <- function(...) {
  x <- c(...)
  if (is_null(names(x))) {
    paste0(x, collapse = ", ")
  } else {
    paste0(names(x), " = ", x, collapse = ", ")
  }
}

commas <- function(...) paste0(..., collapse = ", ")

in_travis <- function() identical(Sys.getenv("TRAVIS"), "true")

named <- function(...) {
  x <- c(...)

  missing_names <- names2(x) == ""
  names(x)[missing_names] <- x[missing_names]

  x
}

unique_name <- local({
  i <- 0

  function() {
    i <<- i + 1
    paste0("zzz", i)
  }
})

succeeds <- function(x, quiet = FALSE) {
  tryCatch(
    {
      x
      TRUE
    },
    error = function(e) {
      if (!quiet)
        message("Error: ", e$message)
      FALSE
    }
  )
}

c_character <- function(...) {
  x <- c(...)
  if (length(x) == 0) {
    return(character())
  }

  if (!is.character(x)) {
    stop("Character input expected", call. = FALSE)
  }

  x
}

old_qq <- function() {
  utils::packageVersion("rlang") <= "0.1.6"
}
GetOrder2ParBeta_l <- function(Prior,l1,l2){
  L <- length(Prior)
  D_value <- 1/Prior[L]
  expBeta <- D_value * Prior
  if (l1==l2){
    res <- -(expBeta * expBeta[l1])*(D_value - 2*expBeta[l1])/(D_value^3)
    res[l1] <- expBeta[l1]*(D_value - expBeta[l1])*(D_value - 2*expBeta[l1])/(D_value^3)
  } else {
    res <- 2*(expBeta * expBeta[l1]*expBeta[l2])/(D_value^3)
    res[l1] <- expBeta[l1]*expBeta[l2]*(-D_value + 2*expBeta[l1])/(D_value^3)
    res[l2] <- expBeta[l1]*expBeta[l2]*(-D_value + 2*expBeta[l2])/(D_value^3)
  }
  res
}



GetParBeta_l <- function(Prior,ll){
  L <- length(Prior)
  D_value <- 1/Prior[L]
  expBeta <- D_value * Prior
  expBeta_l <- expBeta[ll]
  res <- -(expBeta_l * expBeta)/(D_value^2)
  res[ll] <- expBeta_l*(D_value - expBeta_l)/(D_value^2)
  res
}
#' @importFrom methods is

SolveMat <- function(Info){
	eps2 <- 10^(-10)
	varmatTemp <- try( solve(Info + diag( eps2 , ncol(Info) )) )
	if ( is(varmatTemp , "try-error") ){
	cat( "Singular model parameter covariance matrix\n")
	varmatTemp <- NA}
	varmatTemp
}
InvLogit <- function(x){
  return(exp(x)/(1 + exp(x)))
}

Logit <- function(x){
  return(log(x/(1 - x)))
}

#convert decimal into binary format
binary <- function(x) if (all(x<2)) x else paste(binary(x%/%2), x%%2, sep="")
#' Create empty status vector
#' 
#'
#' Every function in \code{\link[=deducorrect-package]{deducorrect}} returns the status of every row after treatment.
#' The status vector is an \code{ordered} factor with levels
#'
#' \tabular{ll}{
#'  \code{invalid}      \tab record is invalid but could not be corrected\cr
#'  \code{partial}    \tab record violates less edits then before entering the function\cr
#'  \code{corrected}    \tab record satisfies all edit restrictions after correction\cr
#'  \code{valid}        \tab record violates no edit restrictions\cr
#' }
#' where \code{invalid < partial < corrected < valid}
#' 
#'
#'
#' This function is \code{deducorrect} internal.
#'
#' @title Create empty status vector
#' @param n length of status vector
#' @param ini initial value, defaults to \code{NA}
#' @return an ordered factor with levels mentioned under details
#'
#' @example ../examples/status.R
#'
status <- function(n, ini=NA){
    st <- c("invalid", "partial", "corrected", "valid")
    if ( ! ini %in% c(st,NA) ){
        stop(paste("invalid status level, allowed are NA, ",paste(st,collapse=", ")))
    }
    return(ordered(rep(ini,n), levels=st))
}

# sensibly combine two status vectors
combineStatus <- function(x,y){
    z <- status(length(x))
    z[x == 'invalid'    & y == 'invalid'] <- 'invalid'
    z[x == 'partial'    | y == 'partial'] <- 'partial'
    z[x == 'corrected'  & y == 'corrected'] <- 'corrected'
    z[x == 'valid'      & y == 'valid'] <- 'valid'
    z
}


#' Get name of R user.
#'
#' This function returns the username.
#' 
#' This function is not exported.
#' 
#' @title Get name of R user. 
#' 
#' @return The username
#' @keywords internal
getUsername <- function(){
    name <- Sys.info()[["user"]]
    return(name)
}
map <- 
function (x, from, to, strict = TRUE, ...) 
{
  stopifnot(length(to) == length(from))
  res <- to[match(x, table = from)]
  if (!strict) 
    res[!(x %in% from)] <- x[!(x %in% from)]
  res
}
## problem is still that we have implicit arguments...
.vectorizeinputs <- function(e) {
    ## test function
    funcname <- e[[1]]
    e[[1]] <- NULL
    fvals <- formals(eval(funcname))
    fnames <- names(fvals)
    implicit <- setdiff(fnames, names(e))
    e <- as.list(e)
    ## e <- lapply(e, eval)
    for (i in names(e)) e[[i]] <- eval(e[[i]])
    ##    print(e)
    e <- as.data.frame(e)
    if (length(implicit) > 0) e <- cbind(e, fvals[implicit])
    ##    names(e)[names(e) == ""] <- implicit
    ## print(implicit)
    ## print(e)
    for (i in names(e)) assign(i, eval(e[[i]]),
                               envir=parent.frame())
}

.vectorizeinputs_keep <- function(x) {
    fname <- x[[1]]
    x[[1]] <- NULL
    x <- as.data.frame(as.list(x))
    for (i in names(x)) x[[i]] <- eval(x[[i]])
    for (i in names(x)) assign(i, x[[i]],
                                 envir=parent.frame())
}
## problem is still that we have implicit arguments...
.vectorizeinputs <- function(e) {
    ## test function
    funcname <- e[[1]]
    e[[1]] <- NULL
    fvals <- formals(eval(funcname))
    fnames <- names(fvals)
    implicit <- setdiff(fnames, names(e))
    e <- as.list(e)
    ## e <- lapply(e, eval)
    for (i in names(e)) e[[i]] <- eval(e[[i]])
    ##    print(e)
    e <- as.data.frame(e)
    if (length(implicit) > 0) e <- cbind(e, fvals[implicit])
    ##    names(e)[names(e) == ""] <- implicit
    ## print(implicit)
    ## print(e)
    for (i in names(e)) assign(i, eval(e[[i]]),
                               envir=parent.frame())
}

.vectorizeinputs_keep <- function(x) {
    fname <- x[[1]]
    x[[1]] <- NULL
    x <- as.data.frame(as.list(x))
    for (i in names(x)) x[[i]] <- eval(x[[i]])
    for (i in names(x)) assign(i, x[[i]],
                                 envir=parent.frame())
}
translate_parallel <- function(parallel) {
  checkmate::assert(checkmate::check_int(parallel),
                    checkmate::check_logical(parallel, len = 1))
  n_cores <- 1
  if (isTRUE(parallel)) {
    n_cores <- parallel::detectCores()
  } else if (is.numeric(parallel)) {
    n_cores <- parallel
    if (n_cores > parallel::detectCores()) n_cores <- parallel::detectCores()
  }
  n_cores
}

rand_seed <- function() sample.int(2 ^ 30, 1)

#' Apply a function to each pillar of a 3-dimensional array.
#'
#' Define a 'pillar' of a 3-dimensional array as pillar `i,j` off array
#' `arr` being `arr[i, j, ]`. This function applies a specified
#' function to each pillar.
#'
#' @param arr3d A 3-dimensional array.
#' @param FUN A function which takes a vector as input and, for a given input
#'   length, outputs a vector of constant length (can be 1).
#'
#' @return If `FUN` is returning length 1 vectors, a matrix whereby
#'   `mat[i, j] = FUN(arr3d[i, j, ])`. If FUN is returning vectors of
#'   length `l > 1`, a 3-dimensional array whereby \code{arr[i, j, ] =
#'   FUN(arr3d[i, j, ])}.
#' @export
apply_on_pillars <- function(arr3d, FUN) {
  apply(arr3d, c(1, 2), FUN) %>% {
    if (length(dim(.)) == 3) {
      aperm(., c(2, 3, 1))
    } else {
      .
    }
  }
}
zeit_get_url <- function(path, ..., key=zeit_key()) {
	#auth <- zeit_auth(key)
	#req <- GET("http://api.zeit.de/", path=path, auth, query=list(...))
	req <- GET("http://api.zeit.de/", path=path, query=list(api_key = key, ...))
	zeit_check(req)
	#message("Request: ", req$url) # for debugging
	return(req)
}


#zeit_auth <- function(key=zeit_key()) {
#	authenticate(key, "")
#}


zeit_check <- function(req) {
	if(req$status_code < 400) return(invisible())
	message <- zeit_parse(req)$message
	stop("HTTP failure: ", req$status_code, "\n", message, call.=FALSE)
}


zeit_parse <- function(req) {
	json <- content(req, as="text")
	if(identical(json, "")) stop("Not output to parse", call.=FALSE)
	if(length(grep("application/json", req$headers$'content-type', fixed=TRUE)) == 0) stop("No JSON to parse", call.=FALSE)
	fromJSON(json, simplifyVector=FALSE)
}


zeit_key <- function(force=FALSE) {
	env <- Sys.getenv('ZEIT_KEY')
	if(!identical(env, "") && !force) return(env)

	if(!interactive()) {
		stop("Please set env var 'ZEIT_KEY' to your personal ZEIT api key", call.=FALSE)
	}

	message("Couldn't find env var ZEIT_KEY.")
	message("Please enter your key and press enter")
	key <- readline(": ")

	if(identical(key, "")) {
		stop("Key entry failed", call.=FALSE)
	}

	message("Updating ZEIT_KEY env var to given key")
	Sys.setenv(ZEIT_KEY=key)

	return(key)
}


hasKey <- function() {
	!identical(zeit_key(), "")
}
# diffusr: network diffusion algorithms in R
#
# Copyright (C) 2016 Simon Dirmeier
#
# This file is part of diffusr.
#
# diffusr is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# diffusr is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with diffusr. If not, see <http://www.gnu.org/licenses/>.

#' @noRd
.equals.double <- function(val, cmp, delta)
{
  val  <= cmp + delta  &  val >=  cmp - delta
}

#' @noRd
.in <- function(val, lower, upper)
{
  val >= lower & val <= upper
}

#' @noRd
.check.restart <- function(s)
{
  name <- deparse(substitute(s))
  if (!is.numeric(s))
    stop(paste(name, "has to be numeric!"))
  if (!.in(s, 0, 1))
    stop(paste(name, "must be in [0, 1]!"))
}

#' @noRd
.check.graph <- function(m, v=NULL)
{
  name.graph  <- deparse(substitute(m))
  name.vector <- deparse(substitute(v))
  if (!is.matrix(m))
    stop('please provide a matrix object!')
  if (any(m < 0))
    stop(paste0("'", name.graph, "' has to be non-negative"))
  if (dim(m)[1] != dim(m)[2])
    stop(paste(name.graph, "has to be of dimension (n x n)!"))
  if (!is.null(v) && dim(m)[1] != dim(v)[1])
    stop(paste(name.vector, "has to have same dimension as", name.graph))
}

#' @noRd
.check.starting.matrix <- function(v)
{
  name <- deparse(substitute(v))
  if (any(v < 0))
    stop(paste(name, "can only contain non-negative values!"))
  if (!is.matrix(v))
    stop(paste("matrix-shaped", name, "required"))
}
#' Generate a weighted function.
#'
#' @param func Function that is used of the form func(x, params).
#' @param weights Weighting of each cluster.
#' @param params Cluster parameter list
#' @return weighted function
#'
#' @export
weighted_function_generator <- function(func, weights, params) {

  weights <- weights/sum(weights)

  weightedFunc <- function(y) {

    if (class(y) == "matrix"){
      out <- numeric(nrow(y))
    }
    else{
      out <- numeric(length(y))
    }
    cumWeight <- 0
    for (i in seq_along(weights)) {
      if (cumWeight > (1 - 1e-6)){
        break
      }
      cl_params <- vector("list", length = length(params))
      for (j in seq_along(params)) {
        cl_params[[j]] <- params[[j]][, , i, drop = FALSE]
      }
      out <- out + weights[i] * func(y, cl_params)
      cumWeight <- cumWeight + weights[i]
    }

    return(out)
  }
  return(weightedFunc)
}

dpareto <- function(x, xm, alpha) ifelse(x > xm, alpha * xm^alpha/(x^(alpha + 1)),
  0)
ppareto <- function(q, xm, alpha) ifelse(q > xm, 1 - (xm/q)^alpha, 0)
qpareto <- function(p, xm, alpha) ifelse(p < 0 | p > 1, NaN, xm * (1 - p)^(-1/alpha))
rpareto <- function(n, xm, alpha) qpareto(runif(n), xm, alpha)
assert_in_range <- function(x, min, max, name = deparse(substitute(x))) {
  assert_scalar_numeric(x, name)
  if (x < min || x > max) {
    stop(sprintf("%s must be in range [%s, %s]", name, min, max))
  }
}

assert_scalar <- function(x, name=deparse(substitute(x))) {
  if (length(x) != 1) {
    stop(sprintf("%s must be a scalar", name), call.=FALSE)
  }
}

assert_numeric <- function(x, name=deparse(substitute(x))) {
  if (!is.numeric(x)) {
    stop(sprintf("%s must be numeric", name), call.=FALSE)
  }
}

assert_nonmissing <- function(x, name=deparse(substitute(x))) {
  if (any(is.na(x))) {
    stop(sprintf("%s must not be NA", name), call.=FALSE)
  }
}

assert_function <- function(x, name=deparse(substitute(x))) {
  if (!is.function(x)) {
    stop(sprintf("%s must be a function", name), call.=FALSE)
  }
}

assert_scalar_numeric <- function(x, name = deparse(substitute(x))) {
  assert_scalar(x, name)
  assert_numeric(x, name)
  assert_nonmissing(x, name)
}
# Get Data
# It takes data as dataframe (edges) or as matrix (table) to be exported in proper form to be used by the diversity function.
# data Data to be processed as dataframe or as matrix. 
# category_row TRUE if column analysis is needed.
get_data <- function(data, category_row=FALSE)
{
	if (is.data.frame(data)) {
		entities <- as.vector(unique(data[,1]))
		categories <- as.vector(unique(data[,2]))
		n_ent <- length(entities)
		n_categ <- length(categories)

		data['id_ctg'] <- match(data[,2], categories) #getting numeric index for
		data['id_ent'] <- match(data[,1], entities) #getting numeric index for
		
		if(category_row==TRUE) {
			X <- matrix(0, nrow=n_categ, ncol=n_ent, dimnames=list(categories,entities))
			X[cbind(data[,4], data[,5])] <- data[,3]
		}
		else {
			X <- matrix(0, nrow=n_ent, ncol=n_categ, dimnames=list(entities,categories))
			X[cbind(data[,5], data[,4])] <- data[,3]
		}
	}
	else {
		if (category_row==TRUE) {
			X <- t(data)
			#diversity <- data.frame(row.names=rownames(X))
		}
		else {
			X <- data
			#diversity <- data.frame(row.names=rownames(X))
		}  
	}
	return(X)
	
}
get_from_cache <- function(packages) {
    .dlstats <- get(".dlstats", envir=.GlobalEnv)
    stats <- lapply(packages, function(pkg) tryCatch(get(pkg, envir=.dlstats, inherits=FALSE), error=function(e) NULL))
    names(stats) <- packages
    res <- do.call('rbind', stats[!sapply(stats, is.null)])
    rownames(res) <- NULL
    return(res)
}


dlstats_cache <- function(stats) {
    new_query <- split(stats, stats$package)
    .dlstats <- get(".dlstats", envir=.GlobalEnv)
    for (i in seq_along(new_query)) {
        assign(names(new_query)[i], new_query[[i]], envir=.dlstats)
    }
}
mdebug <- function(...) {
  if (!getOption("doFuture.debug", FALSE)) return()
  message(paste(sprintf(...), collapse = "\n"))
}

#' @importFrom utils capture.output str
mstr <- function(...) {
  if (!getOption("doFuture.debug", FALSE)) return()
  message(paste(capture.output(str(...)), collapse = "\n"))
}

#' @importFrom utils capture.output
mprint <- function(...) {
  if (!getOption("doFuture.debug", FALSE)) return()
  message(paste(capture.output(print(...)), collapse = "\n"))
}
# used by cuntions to make sure they are working with a well-formed docx object
ensure_docx <- function(docx) {
  if (!inherits(docx, "docx")) stop("Must pass in a 'docx' object", call.=FALSE)
  if (!(all(sapply(c("docx", "ns", "tbls", "path"), exists, where=docx))))
    stop("'docx' object missing necessary components", call.=FALSE)
}

# test if a w:tbl has a header row
has_header <- function(tbl, rows, ns) {

  # microsoft has a tag for some table structure info. examine it to
  # see if the creator of the header made the first row special which
  # will likely mean it's a header candidate
  look <- try(xml_find_first(tbl, "./w:tblPr/w:tblLook", ns), silent=TRUE)
  if (inherits(look, "try-error")) {
    return(NA)
  } else {
    look_attr <- xml_attrs(look)
    if ("firstRow" %in% names(look_attr)) {
      if (look_attr["firstRow"] == "0") {
        return(NA)
      } else {
        return(paste0(xml_text(xml_find_all(rows[[1]], "./w:tc", ns)), collapse=", "))
      }
    } else {
      return(NA)
    }
  }

}

is_url <- function(path) { grepl("^(http|ftp)s?://", path) }

is_docx <- function(path) { tolower(file_ext(path)) == "docx" }
#' List tables with specified pattern
#'
#' @param con Teradata connection.
#' @param pattern character string containing a regular expression.
#'
#' @importFrom dplyr db_list_tables
#' @export
db_list_tables_with_pattern <- function(con, pattern) {
  table_names <- db_list_tables(con)
  Filter(function(x) grepl(pattern, x), table_names)
}

#' Convert blob to character.
#'
#' @param blob blob vector.
#'
#' @examples
#' (x <- blob::as.blob("Good morning"))
#' #> [1] blob[12 B]
#' x[[1]]
#' #> [1] 47 6f 6f 64 20 6d 6f 72 6e 69 6e 67
#' blob_to_string(x)
#' #> [1] "476f6f64206d6f726e696e67"
#'
#' @export
blob_to_string <- function(blob) {
  vapply(blob, function(x) paste(as.character(x), collapse = ""), character(1L))
}
replace_with <- function(x, i, val, name, reason = NULL) {
  if (is.null(val)) {
    return(x)
  }

  check_length(val, x, name, reason)
  check_type(val, x, name)
  check_class(val, x, name)

  i[is.na(i)] <- FALSE

  if (length(val) == 1L) {
    x[i] <- val
  } else {
    x[i] <- val[i]
  }

  x
}

check_length <- function(x, template, header, reason = NULL) {
  check_length_val(length(x), length(template), header, reason)
}

check_length_col <- function(length_x, n, name, reason = NULL, .abort = abort) {
  check_length_val(length_x, n, fmt_cols(name), reason, .abort = .abort)
}

check_length_val <- function(length_x, n, header, reason = NULL, .abort = abort) {
  if (all(length_x %in% c(1L, n))) {
    return()
  }

  if (is.null(reason)) reason <- ""
  else reason <- glue(" ({reason})")

  if (n == 1) {
    glubort(header, "must be length 1{reason}, not {commas(length_x)}", .abort = .abort)
  } else {
    glubort(header, "must be length {n}{reason} or one, not {commas(length_x)}", .abort = .abort)
  }
}

check_type <- function(x, template, header) {
  if (identical(typeof(x), typeof(template))) {
    return()
  }

  glubort(header, "must be type {type_of(template)}, not {typeof(x)}")
}

check_class <- function(x, template, header) {
  if (!is.object(x)) {
    return()
  }

  if (identical(class(x), class(template))) {
    return()
  }

  glubort(header, "must be {fmt_classes(template)}, not {fmt_classes(x)}")
}
expr_type_of <- function(x) {
  type <- typeof(x)
  if (type %in% c("symbol", "language", "pairlist", "NULL")) {
    type
  } else {
    "literal"
  }
}
switch_expr <- function(.x, ...) {
  switch(expr_type_of(.x), ...)
}

node_walk_replace <- function(node, old, new) {
  while(!is_null(node)) {
    switch_expr(node_car(node),
      language = node_walk_replace(node_cdar(node), old, new),
      symbol = if (identical(node_car(node), old)) mut_node_car(node, new)
    )
    node <- node_cdr(node)
  }
}
expr_substitute <- function(expr, old, new) {
  expr <- duplicate(expr)
  switch_type(expr,
    formula = ,
    language = node_walk_replace(node_cdr(expr), old, new),
    symbol = if (identical(expr, old)) return(new)
  )
  expr
}

sym_dollar <- quote(`$`)
sym_brackets2 <- quote(`[[`)
is_data_pronoun <- function(expr) {
  is_lang(expr, list(sym_dollar, sym_brackets2)) &&
    identical(node_cadr(expr), quote(.data))
}
tidy_text <- function(quo, width = 60L) {
  expr <- f_rhs(quo)
  if (is_data_pronoun(expr)) {
    as_string(node_cadr(node_cdr(expr)))
  } else {
    quo_text(quo, width = width)
  }
}
named_quos <- function(...) {
  quos <- quos(...)
  exprs_auto_name(quos, printer = tidy_text)
}
#' Describing dimensions
#'
#' Prints the dimensions of an array-like object in a user-friendly manner,
#' substituting `NA` with ?? (for SQL queries).
#'
#' @param x Object to show dimensions for.
#' @export
#' @keywords internal
#' @examples
#' dim_desc(mtcars)
dim_desc <- function(x) {
  d <- dim(x)
  d2 <- big_mark(d)
  d2[is.na(d)] <- "??"

  fmt_dims(d2)
}

wrap <- function(..., indent = 0) {
  x <- paste0(..., collapse = "")
  wrapped <- strwrap(
    x,
    indent = indent,
    exdent = indent + 2,
    width = getOption("width")
  )

  paste0(wrapped, collapse = "\n")
}

ruler <- function(width = getOption("width")) {
  x <- seq_len(width)
  y <- case_when(
    x %% 10 == 0 ~ as.character((x %/% 10) %% 10),
    x %% 5 == 0  ~ "+",
    TRUE         ~ "-"
  )
  cat(y, "\n", sep = "")
  cat(x %% 10, "\n", sep = "")
}

rule <- function(pad = "-", gap = 2L) {
  paste0(rep(pad, getOption("width") - gap), collapse = "")
}

named_rule <- function(..., pad = "-") {
  if (nargs() == 0) {
    title <- ""
  } else {
    title <- paste0(...)
  }
  paste0(title, " ", rule(pad = pad, gap = nchar(title) - 1))
}


#' @export
print.BoolResult <- function(x, ...) {
  cat(x)
  if (!x) cat(": ", attr(x, "comment"), sep = "")
  cat("\n")
}

# function for the thousand separator,
# returns "," unless it's used for the decimal point, in which case returns "."
big_mark <- function(x, ...) {
  mark <- if (identical(getOption("OutDec"), ",")) "." else ","
  formatC(x, big.mark = mark, ...)
}
safe_grepl <- function(pattern, x){
  tryCatch(grepl(pattern, x), error = error_false)
}

is_file <- function(x){
  safe_grepl(pattern = quotes_regex, x = x)
}

standardize_filename <- function(text){
  text[is_file(text)] <-  gsub("^'|'$", "\"", text[is_file(text)])
  text
}

is_existing_file <- function(x){
  is_file(x) & file.exists(drake_unquote(x))
}

is_not_file <- function(x){
  !is_file(x)
}

braces <- function(x) {
  paste("{\n", x, "\n}")
}

# From lintr
`%||%` <- function(x, y) {
  if (is.null(x) || length(x) <= 0) {
    y
  } else {
    x
  }
}

drake_select <- function(
  cache, ..., namespaces = cache$default_namespace, list = character(0)
){
  tidyselect::vars_select(
    .vars = list_multiple_namespaces(cache = cache, namespaces = namespaces),
    ...,
    .strict = FALSE
  ) %>%
    unname %>%
    c(list)
}

merge_lists <- function(x, y){
  names <- base::union(names(x), names(y))
  lapply(
    X = names,
    function(name){
      base::union(x[[name]], y[[name]])
    }
  ) %>%
    setNames(nm = names)
}

clean_dependency_list <- function(x){
  if (!length(x)){
    return(character(0))
  }
  x %>%
    unlist() %>%
    unname() %>%
    as.character() %>%
    unique() %>%
    sort()
}
.take_poll <- function(n, plot = TRUE, return_values = FALSE, blue_prob = 0.529, jitter_factor = 1, cex=1.2, ...){
  bead_color <- sample(c("Blue","Red"), n, prob=c(blue_prob, 1-blue_prob), replace = TRUE)
  if(plot){
    cols <- ifelse(bead_color=="Blue", "#0072B2", "#D55E00")
    x <- jitter(ifelse(bead_color=="Blue", 1, 2), factor = jitter_factor)
    y <- stats::rnorm(n)
    plot(x,y, pch=21, bg=cols, xlim=c(0.5,2.5), xlab="", ylab="", xaxt="n", yaxt="n", cex = cex, bty = "n", ...)
    graphics::axis(side=3, at=c(1,2), labels = c("Blue", "Red"), tick=FALSE)
    }
  if(return_values) return(bead_color) 
}
# j <- lazyeval::interp(~ .I[rows], rows = args[[1]]$expr)
# dt_subset(dt, , j, env)

dt_subset <- function(dt, i, j, env = parent.frame(), sd_cols = NULL) {
  env <- new.env(parent = env, size = 2L)
  env$`_dt` <- dt
  env$`_vars` <- deparse_all(groups(dt))

  args <- list(
    i = if (missing(i)) quote(expr =) else dt_replace(i),
    j = if (missing(j)) quote(expr =) else dt_replace(j)
  )

  if (missing(j)) {
    call <- substitute(`_dt`[i], args)
  } else {
    call <- substitute(`_dt`[i, j, by = `_vars`], args)
    call$.SDcols = sd_cols
  }
  # print(call)

  eval(call, env)
}

dt_replace <- function(x) {
  if (is.atomic(x)) {
    x
  } else if (is.name(x)) {
    if (identical(x, quote(.))) {
      quote(.SD)
    } else {
      x
    }
  } else if (is.call(x)) {
    if (identical(x, quote(n()))) {
      quote(.N)
    } else {
      x[] <- lapply(x, dt_replace)
      x
    }
  } else {
    # User supplied incorrect input
    stop("Don't know how to handle type ", typeof(x),
      call. = FALSE)
  }
}

commas <- function(...) paste0(..., collapse = ", ")

deparse_all <- function(x) {
  deparse2 <- function(x) paste(deparse(x, width.cutoff = 500L), collapse = "")
  vapply(x, deparse2, FUN.VALUE = character(1))
}


drop_last <- function(x) {
  if (length(x) <= 1L) return(NULL)
  x[-length(x)]
}


names2 <- function(x) {
  names(x) %||% rep("", length(x))
}

"%||%" <- function(x, y) if(is.null(x)) y else x
`%??%` <- function(lhs, rhs)
  if (is_empty(lhs)) rhs else lhs

is_empty <- function(x)
  length(x) == 0

is_string <- function(x)
  length(x) == 1 && is.character(x)

opposite <- function(f) {
  formals(f) <- rev(formals(f))
  f
}

bind_to_env <- function(...)
  list2env(list(...), parent = emptyenv())
mergeLists <- function (base_list, overlay_list, recursive = TRUE) {
  if (length(base_list) == 0)
    overlay_list
  else if (length(overlay_list) == 0)
    base_list
  else {
    merged_list <- base_list
    for (name in names(overlay_list)) {
      base <- base_list[[name]]
      overlay <- overlay_list[[name]]
      if (is.list(base) && is.list(overlay) && recursive)
        merged_list[[name]] <- mergeLists(base, overlay)
      else {
        merged_list[[name]] <- NULL
        merged_list <- append(merged_list,
                              overlay_list[which(names(overlay_list) %in% name)])
      }
    }
    merged_list
  }
}

asISO8601Time <- function(x) {
  if (!inherits(x, "POSIXct"))
    x <- as.POSIXct(x, tz = "GMT")
  format(x, format = "%04Y-%m-%dT%H:%M:%OS3Z", tz = 'GMT')
}

resolveStrokePattern <- function(strokePattern) {
  if (is.character(strokePattern)) {
    if (strokePattern == "dotted") 
      strokePattern <- c(2, 2)
    else if (strokePattern == "dashed")
      strokePattern <- c(7, 3)
    else if (strokePattern == "dotdash")
      strokePattern <- c(7, 2, 2, 2)
    else if (strokePattern == "solid")
      strokePattern <- c(1, 0)
    else
      stop("Invalid stroke pattern: valid values are dotted, ",
           "dashed, and dotdash")
  }
  strokePattern
}

#' @importFrom stats end start
defaultPeriodicity <- function (data) {
  periodicity <- structure(
    list(difftime = structure(0, units = "secs", class = "difftime"),
         frequency = 0,
         start = start(data),
         end = end(data),
         units = "secs",
         scale = "seconds",
         label = "second"),
    class = "periodicity")
}
#' @import "igraph"
#' @import "parallel"
#' @import "doParallel"
#' @import "foreach"
NLSS <- function(n1,n2) {
  a <- length(intersect(n1,n2))
  b <- length(union(n1,n2))
  ifelse(b==0,1,a/b)
}
getsim <- function(g,uid,cid) {
  sim <- NLSS(neighbors(g,uid)$label, neighbors(g,cid)$label)
  names(sim) <- cid
  return(sim)
}
vecNLSS <- function(g, uid, candidates) {
  cid <- NULL
  simvec <- foreach (cid=candidates, .combine = c) %dopar% getsim(g,uid,cid)
  return(simvec)
}
is.label.match <- function(ulab,vlab) {
  ulabvec <- strsplit(ulab, split = " ")[[1]]
  vlablist <- strsplit(vlab, split = " ")
  sapply(vlablist, function(x) all(ulabvec%in%x))
}
is.label.include <- function(g,uid, vid) {
  ulabel <- strsplit(V(g)[uid]$label, split = " ")[[1]]
  vlabel <- strsplit(V(g)[vid]$label, split = " ")[[1]]
  all(ulabel%in%vlabel)
}
is.label.equal <- function(g,uid, vid) {
  ulabel <- strsplit(V(g)[uid]$label, split = " ")[[1]]
  vlabel <- strsplit(V(g)[vid]$label, split = " ")[[1]]
  setequal(ulabel,vlabel)
}
#' @import Kendall
#' @import KernSmooth
#' @import lmtest
#' @import nortest
#' @import som
#' @import spam
#' @import stats
NULL

#' Description: Get group assigment indices for univariate data points, given cluster break points
#'
#' Arguments:
#'    @param x Univariate data vector
#'    @param breakpoints Cluster breakpoints
#'
#' Returns:
#'   @return A vector of cluster indices
#'
#' @export
#'
#' @author Leo Lahti \email{leo.lahti@@iki.fi}
#' @examples #
#'
#' @keywords early-warning

UnivariateGrouping <- function(x, breakpoints) {
    g <- rep.int(NA, length(x))
    mps <- c(breakpoints, Inf)
    for (i in 1:length(mps)) {
        g[x <= mps[[i]] & is.na(g)] <- i
    }
    g
}
# extract target names from fit objects and rename columnns if needed
renameColumns = function(fit, pd)
  UseMethod("renameColumns")

renameColumns.ranger = function(fit, pd) {
  pd
}

renameColumns.randomForest = function(fit, pd) {
  if (fit$type == "regression" & any(grepl("formula", class(fit)))) {
    target = deparse(attr(fit$terms, "variables")[[2]])
  } else if (fit$type == "classification") {
    target = colnames(fit$err.rate)[-1]
  } else {
    target = "prediction"
  }
  
  colnames(pd)[(ncol(pd) - length(target) + 1):ncol(pd)] = target
  pd
}

renameColumns.RandomForest = function(fit, pd) {
  target = colnames(fit@responses@variables)
  if (ncol(fit@responses@variables) > 1L |
        (ncol(fit@responses@variables) == 1L & is.factor(fit@responses@variables[, 1]))) {
    target = gsub(paste0(target, "\\.", collapse = "|"), "",
      colnames(fit@responses@predict_trafo))
  }

  colnames(pd)[(ncol(pd) - length(target) + 1):ncol(pd)] = target
  pd
}

renameColumns.rfsrc = function(fit, pd) {
  if (is.factor(fit$yvar)) {
    target = levels(fit$yvar)
  } else {
    target = fit$yvar.names
  }

  colnames(pd)[(ncol(pd) - length(target) + 1):ncol(pd)] = target
  pd
}
is_url <- function(x) {
  grepl("^(http|ftp)s?://", x)
}

get_doc <- function(x, clean = F) {
  if (typeof(x) == "character") {
    if (is_url(x)) {
      res <- httr::GET(x)
      doc <- xml2::read_html(res, base_url = x)
    } else {
      doc <- xml2::read_html(x)
    }
  } else {
    doc <- x
  }

  if (clean) {
    doc <- clean_doc(doc)
  }

  doc
}

charToDoc <- function(x) {
  if (is_url(x)) {
    res <- httr::GET(x)
    xml2::read_html(res, base_url = x)
  } else {
    xml2::read_html(x)
  }
}

charToText <- function(x) {
  if (is_url(x)) {
    res <- httr::GET(x)
    return(httr::content(res, encoding = "UTF-8"))
  } else {
    return(x)
  }
}

# strips difficult to handle html bits we don't really care about
# @param x text of an html document
clean_html <- function(x) {
  x <- gsub("&nbsp;", " ", x, ignore.case = T)
  x <- gsub("<br>", " ", x, ignore.case = T)
  x <- gsub("<br/>", " ", x, ignore.case = T)
  x
}

# removes br from the doc since we don't really care about display, replacing
# with spaces
clean_doc <- function(doc) {
  replacement <- xml2::xml_find_first(xml2::read_xml("<p> </p>"),
                                      "/p/text()")
  xml2::xml_replace(xml2::xml_find_all(doc, "//br"), replacement)

  doc
}
##
## utilities.r - Internal utility functions
##
## Author:
##  Olaf Mersmann (OME) <olafm@statistik.tu-dortmund.de>
##

##' @useDynLib emoa do_which_points_on_edge
NA

rsbxbeta <- function(n, nc) {
    ## U ~ [0, 1] , twou := 2 * U ~ [0, 2]
    twou <- runif(n, 0, 2.0)

    e <- 1/(nc + 1)
    beta <- ifelse(twou < 1, twou, 1/(2 - twou))^e
    return(beta)
}

##' Clip value to a given range
##'
##' Clip \eqn{x} to the interval \eqn{[l, u]}. This is useful to enforce
##' box constraints.
##'
##' @param x Value to clip.
##' @param l Lower limit.
##' @param u Upper limit.
##'
##' @return l if x < l, u if x > u else x.
##'
##' @author Olaf Mersmann \email{olafm@@statistik.tu-dortmund.de}
##' @export
inbounds <- function(x, l, u) {
  ifelse(x < l, l, ifelse(x > u, u, x))
}

##' Return first non null argument.
##'
##' This function is useful when processing complex arguments with multiple
##' possible defaults based on other arguments that may or may not have been
##' provided.
##'
##' @param ... List of values.
##' @return First non null element in \code{...}.
##'
##' @author Olaf Mersmann \email{olafm@@statistik.tu-dortmund.de}
##' @export
coalesce <- function(...) {
  l <- list(...)
  isnull <- sapply(l, is.null)
  l[[which.min(isnull)]]
}
ellipsis <- function(x) {
  N <- 6
  if (length(x) > N) {
    x <- c(x[seq_len(N)], paste0("... (", length(x), " total)"))
  }
  paste(x, collapse = ", ")
}
# Format Call for Output
#
# This internal function transforms a call into a short version for
# appropriate for the error message. It will estimate the width of the
# output based on \code{getOption("width")} when formatting the call.
#
# @param cl a call
#
# @return a character string
format_call <- function(cl)
{
  # deparse the call, and get its length
  call_string <- deparse(cl, nlines = 1L)
  n <- nchar(call_string)

  # Find an appropriate max width for the error message
  max_width   <- getOption("width")
  if (is.null(max_width) || max_width < 80)
    max_width <- 80

  # The max length of the variable part of the message
  max_length <- max_width - 38

  # Construct the message:
  if (n > max_length) {
    fst_half <- substring(call_string, 1,  floor(max_length/2) - 2)
    snd_half <- substring(call_string, n - floor(max_length/2) + 3, n)
    paste(fst_half, "..", snd_half)
  } else {
    call_string
  }
}

# Extract Message for a Condition.
#
# Some conditions have custom messages associated witg them. If so, this
# function will get this message. If it is missing, a message is created.
#
# @param cond A condition
#
# @return a character string.
condition_message <- function(cond) {
  custom <- attr(cond, "custom_msg")
  if (is.null(custom) || !is.character(custom))
    deparse(cond, nlines = 1L)
  else
    custom[1L]
}
enve.col.alpha <- function
  ### Modify alpha in a color (or vector of colors).
    (col,
    ### Color or vector of colors. It can be any value supported by `col2rgb`, 
    ### such as 'darkred' or '#009988'.
    alpha=1/2
    ### Alpha value to add to the color, from 0 to 1.
  ){
  return(
    apply(col2rgb(col), 2,
      function(x) do.call(rgb, as.list(c(x[1:3]/256, alpha))) ) )
  ### Returns a color or a vector of colors in hex notation including alpha.
}
#*****************************************
#
# (C) Copyright IBM Corp. 2017
# Author: Bradley J Eck
#
#  
#****************************************/

#' getOpenflag
#' 
#' gets current value of EPANET global variable Openflag
#' 
#' @details primary use of this function is to allow
#' package functions to check status of toolkit before 
#' calling a function
#' @export 
#' @useDynLib epanet2toolkit RgetOpenflag
#' @return boolean
#' @examples 
#' getOpenflag()
getOpenflag <- function(){
	
		x <- .C("RgetOpenflag", as.integer(-1))
		return( as.logical( x[[1]] ) ) 
	
}

#' getOpenHflag
#' 
#' gets current value of EPANET global variable OpenHflag
#' 
#' @details primary use of this function is to allow
#' package functions to check open/closed status of the 
#' toolkit's hydraulic solver before 
#' calling a hydraulic function
#' @export 
#' @useDynLib epanet2toolkit RgetOpenHflag
#' @return boolean
#' @examples 
#' getOpenHflag()
getOpenHflag <- function() {
  
  x <- .C("RgetOpenHflag", as.integer(-1))
  return( as.logical( x[[1]] ) ) 
  
}

# take an integer from a character vector
# and return an integer if possible
# or a trimmed character if not
charlong_to_int_or_char <- function( charlong ){
	
	# check the argument 
	if( !is.character(charlong)) stop("argument must be character")
	
	suppressWarnings( return_value <- as.integer( charlong))
	
	if( is.na(return_value)){
		return_value <- gsub("\\s*", "", charlong)
	}
	return( return_value)
	
}

check_char_length_1 <- function( x ){
	if( !is.character(x)) stop("must be character")
	if(length(x)!=1) stop("must have length 1")
}
make_params <- function(params, by, ok="") {

  by <- stringi::stri_trans_tolower(by)
  by <- stringi::stri_replace_all_regex(by, "[[:space:]]", "")
  by <- strsplit(by, "")[[1]]
  by <- purrr::keep(by, `%in%`, ok)
  by <- sort(unique(by))

  params <- c(params, setNames(as.list(rep("*", length(by))), by))

}

clean_cols <- function(x) {

  x <- stringi::stri_replace_all_fixed(x, ",", "")

  if (any(grepl("%", x))) {
    as.numeric(stringi::stri_replace_all_fixed(x, "%", ""))/100
  } else if (any(grepl("\\$", x))) {
    as.numeric(stringi::stri_replace_all_fixed(x, "$", ""))
  } else {
    x
  }

}
.pm <- intToUtf8(177)

.onLoad <- function(libname, pkgname) {
  types <- c("bool", "coercion", "matmult")
  types <- paste0("errors.warn.", types)
  options(as.list(setNames(rep.int(TRUE, length(types)), types)))
}

warn_once <- function(message, fun, type) {
  type <- paste0("errors.warn.", type)
  if (getOption(type)) {
    options(as.list(setNames(FALSE, type)))
    warning("In '", fun, "' : ", message, call. = FALSE)
  }
}

.v <- function(x) as.numeric(x)

get_exponent <- function(x) ifelse(.v(x), floor(log10(abs(.v(x)))), 0)

propagate <- function(..., method=getOption("errors.propagation", "taylor-first-order")) {
  if (method == "taylor-first-order")
    sqrt(colSums(rbind(...)^2))
  else { # nocov start
    warning("error propagation '", method, "' not supported, falling back to 'taylor-first-order'")
    options(errors.propagation = "taylor-first-order")
    propagate(...)
  } # nocov end
}

cummatrix <- function(x, fill=0) {
  t(sapply(seq_len(length(x)), function(lag) {
    c(rep(fill, lag-1), x[1:(length(x)-lag+1)])
  }))
}

cond2int <- function(...) {
  args <- c(...)
  sum(2^(seq_along(args) - 1) * args)
}
hex_to_number <- function(hex, integer = TRUE) {
  hex <- ifelse(grepl("^0[xX]", hex), hex, paste0("0x", hex))
  #
  number <- strtoi(hex)
  #
  number <- ifelse(is.na(number),
                   if (integer) {
                     mpfr(hex, base = 16)
                   } else {
                     class(hex) <- "numeric"
                     as.numeric(sprintf("%.0f", hex))
                   },
                   number)
  #
  number
}

number_to_hex <- function(number) {
  sprintf("0x%x", number)
}

#' Convert Wei to kWei.
#'
#' @param wei Number of Wei.
#'
#' @export
as.kwei   <- function(wei) {
  wei / 1000
}

#' Convert Wei to MWei.
#'
#' @param wei Number of Wei.
#'
#' @export
as.mwei   <- function(wei) wei / 1000000

#' Convert Wei to GWei.
#'
#' @param wei Number of Wei.
#'
#' @export
as.gwei   <- function(wei) wei / 1000000000

#' Convert Wei to Szabo.
#'
#' @param wei Number of Wei.
#'
#' @export
as.szabo  <- function(wei) wei / 1000000000000

#' Convert Wei to Finney.
#'
#' @param wei Number of Wei.
#'
#' @export
as.finney <- function(wei) wei / 1000000000000000

#' Convert Wei to Ether.
#'
#' @param wei Number of Wei.
#'
#' @export
as.ether  <- function(wei) wei / 1000000000000000000
# Small utility functions used by other eurostat functions
# Should not be exported
# Return vector of available frequencies
# param x a vector of "raw" time variable
available_freq <- function(x){
  if (is.factor(x)) x <- levels(x)
  x <- gsub("X", "", x)
  freq <- c()
  if (any(nchar(x) == 4)) freq <- c(freq, "Y")
  freq_char <- unique(
    substr(grep("[[:alpha:]]", x, value = TRUE), 5,5))
  freq <- c(freq, freq_char)
  freq
}
make.me.quick = function(app){
    app[["Statusbar"]] = "Data exchange with R..."
    app[["Screenupdating"]] = FALSE
    app[["Calculation"]] = -4135 # xlCalculationManual = -4135
    invisible(NULL)
}


make.me.slow = function(app){
    app[["Statusbar"]] = ""
    app[["Screenupdating"]] = TRUE
    app[["Calculation"]] = -4105 # xlCalculationAutomatic = -4105
    invisible(NULL)
}


names_to_matrix = function(name,splitter = "|")
    # Convert rownames/colnames with items delimited by symbol 'splitted'
    # to matrix with each label in it's own cell and remove sequentally repeated
    # labels.
{
    if (!is.null(name)){
        splitted = strsplit(as.character(name),split = splitter,fixed = TRUE)
        el.len = max(unlist(lapply(splitted,length)))
        column.nums = 1:el.len
        res = vapply(splitted,"[",column.nums,FUN.VALUE = as.character(column.nums))
        if (!is.matrix(res)) res = t(res)
        res[is.na(res)] = ""
        width = NCOL(res)
        if ((NROW(res)>0) & (width>1)){
            boundary = logical(width-1)
            for (i in (1:NROW(res))){
                boundary = boundary | (res[i,1:(width-1)] !=  res[i,2:width])
                res[i,c(FALSE,!boundary)] = ""
            }
        }
        t(res)
    } else NULL
}


## stop if condition with message
stopif = function(cond,...){
    if (cond) {
        stop(do.call(paste0,c(list(...))),call. = FALSE)
    }
    invisible()
}
#' @include get_excerpts.R
NULL

#' Concatenate Code Files into one File
#'
#' Concatenate python codes and remove local imports and imports from
#' __future__.
#'
#' @param codes a character vector of file names.
#' @return The concatenated code.
concatenate_python_codes <- function(codes) {
    code <- NULL
    for (code_file in codes) {
        code <- c(code, readLines(code_file))
    }
    local_import_index <- grep("from \\. import", code)
    local_imports <- trimws(unique(sapply(strsplit(code[local_import_index],
                                                   split = "import"), "[[", 2)))
    code <- code[- local_import_index]
    for (local_import in local_imports) {
        code <- gsub(paste0(local_import, "\\."), "", code)
    }
    # get rid of imports from __future__ as excertps uses them only to soothe
    # pylint:
    future_index <- grep("from __future__ import ", code)
    code <- code[- future_index]
    return(code)
}

#' Load Excerpts
#'
#' Load excerpts' python codes.
#'
#' @return The status of \pkg{rPython}\code{::\link[rPython]{python.exec}}.
load_excerpts <- function() {
    python_directory <- get_excerpts_path()
    python_codes <- file.path(python_directory, "excerpts")
    codes <- list.files(python_codes, pattern = "^[^_].*\\.py",
                        full.names = TRUE)
    if (length(codes) == 0) {
        # devtools::test() creates it's own testing environment
        get_excerpts(directory = python_directory)
        codes <- list.files(python_codes, pattern = "^[^_].*\\.py",
                            full.names = TRUE)
    }
    # we don't need command_line.py and it imports excerpts. This is not
    # intended, especially as on systems where excerpts is not installed
    # (travis, for example) this will cause an error.
    codes <- codes[! grepl("command_line.py", codes)]
    code <- concatenate_python_codes(codes)
    status <- rPython::python.exec(code)
    return(status)
}
#' Problem: Comparison between several Machine Learning algorithms from the Weka library
#'
#' A problem containing experimental data obtaining by comparing several instances
#' of Machine Algorithms from the Weka library. The variables are as follows:
#'
#' \itemize{
#'   \item method. Classification algorithms used in the experimen (NaiveBayes, J48, IBk)
#'   \item problem. Problems used as benchmark in the comparison, up to 12.
#'   \item featureSelection. Boolean parameter indicating if the data was preprocessed
#'   \item fold. For each configuration a 10-fold cross validation was performed. This variable is a numeric value ranging from 1 to 10.
#'   \item accuracy. This is a measure of the performance of each algorithm. Representing the percentage of correctly classified instances.
#'   \item trainingTime. A second measure of performance. This one indicates the time in seconds that took the algorithm to build the model.
#' }
#' @docType data
#' @keywords problems
#' @name wekaExperiment
#' @usage data(wekaExperiment)
#' @format A data frame with 
#'
"wekaExperiment"
.createDepthStructure <- function(l){
  # Transform a nested list to a vector of objects with two elements: $depth and $str
  # $depth refers to the nested level
  # $str refers to the string representation for that element in the nested list
  s <- list()
  for(i in 1:length(l))
  {
    if(is.list(l[[i]])){
      recX <- .createDepthStructure(l[[i]])
      recX <- lapply(recX,function(x){
        x$depth <- x$depth+1
        x
      })
      s <- do.call(c,list(s,recX))
    }
    else{
      x <- list(depth=0, str = l[[i]])
      s <- c(s,list(x))
    }
  }
  s
}
.nestedList2String <- function(l, numbered=TRUE){
  # A toString method por nested lists.
  x <- .createDepthStructure(l)
  s <- ""
  for(i in 1:length(x)){
    sep <- ifelse(numbered, paste0(i," ) "), '*) ')
    s <- paste(s,do.call(function(...){ paste(...,sep="") },as.list(c(rep('\t',x[[i]]$depth),sep,x[[i]]$str,'\n'))),sep="")
  }
  s
}

.nestedList2HTML <- function(l, numbered=TRUE){
  # A toString method por nested lists.
  x <- .createDepthStructure(l)
  depth <- 0
  sepA <- ifelse(numbered, "<ol>\n", "<ul>\n")
  sepB <- ifelse(numbered, "\n</ol>", "\n</ul>")
  s <- sepA
  for (i in 1:length(x)){
    
    if (x[[i]]$depth > depth)
      s <- paste0(s, sepA)
    if (x[[i]]$depth < depth)
      s <- paste0(s, sepB)
    
    depth <- x[[i]]$depth
    s <- paste0(s, sprintf("<li>%s</li>\n", x[[i]]$str))
  }
  s <- paste0(s, sepB)
  s
}

.nestedList2Latex <- function(l){
  # A toString method por nested lists.
  x <- .createDepthStructure(l)
  depth <- 0
  s <- "\\begin{enumerate}\n"
  for (i in 1:length(x)){
    
    if (x[[i]]$depth > depth)
      s <- paste0(s, "\\begin{enumerate}\n")
    if (x[[i]]$depth < depth)
      s <- paste0(s, "\n\\end{enumerate}")
    
    depth <- x[[i]]$depth
    s <- paste0(s, sprintf("\\item %s\n", x[[i]]$str))
  }
  s <- paste0(s, "\n\\end{enumerate}")
  s
}
named_expr <- function(name, expr) {
  stats::setNames(list(expr), nm = name)
}

last_group <- function(x) {
  groups <- dplyr::groups(x)
  groups[[length(groups)]]
}

check_se_column <- function(col_name) {
  stopifnot(as.character(col_name), length(col) == 1)
}



#' Common parameters across routines
#'
#' @param data A \code{\link[base]{data.frame}} or \code{\link[dplyr]{tbl}}.
#' @param col Name of the generated column. Use a bare name when using NSE
#' functions and a character (quoted) name when using SE functions (functions
#' that end with underscores).
#' @param .dots Used in conjunction with \code{...} to support both explicit
#' and implicit arguments.
#' @keywords internal
common_params <- function(data, col, .dots) {
  NULL
}


# Adapted from tidyr
append_df <- function (x, values, after = length(x)) {
  y <- append(x, values, after = after)
  class(y) <- class(x)
  attr(y, "row.names") <- attr(x, "row.names")
  y
}

append_col <- function (x, col, name, after = length(x)) {
  name <- enc2utf8(name)
  append_df(x, named_expr(name, col), after = after)
}
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU Library General Public License for more details.
#
# You should have received A copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA  02111-1307  USA


################################################################################
# FUNCTION:                 DESCRIPTION:
#  listIndex                 Extracts R package index
################################################################################


listIndex <-
function(package, character.only = FALSE)
{
    ## A function implemented by Diethelm Wuertz & Yohan Chalabi

    ## Extracts R package index

    ## Example:
    ##   listIndex("timeSeries")

### --> ../man/utils-listIndex.Rd
    ##         ~~~~~~~~~~~~~~~~~~

    if (!character.only)
        package <- as.character(substitute(package))
    ans <- library(help = package, character.only=TRUE)
    index <- ans$info[[2]]
    cat("\n", package, "Index:\n\n")
    cat(paste(" ", index), sep = "\n")
}


################################################################################
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU Library General Public License for more details.
#
# You should have received A copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA  02111-1307  USA


################################################################################
# FUNCTION:                 DESCRIPTION:
#  listDescription           Extracts R package description
################################################################################


listDescription <-
function(package, character.only = FALSE)
{
    # A function implemented by Diethelm Wuertz & Yohan Chalabi

    # Description:
    #   Extracts package description

## MM: I would
### .Deprecated("packageDescription")

    # FUNCTION:

    # Extract Description:
    if (!character.only && !missing(package))
        package <- as.character(substitute(package))
    if(missing(package) || length(package) == 0)
        stop("Must specify a package by name")
    ans <- library(help = package, character.only=TRUE)
    ## DW: gsub(): for proper insertion added
    description <- gsub("\n", "\n    ", ans$info[[1]])
    cat("\n", package, "Description:\n\n")
    cat(paste(" ", description), sep = "\n")
}


################################################################################
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 
# GNU Library General Public License for more details.
#
# You should have received A copy of the GNU Library General 
# Public License along with this library; if not, write to the 
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, 
# MA  02111-1307  USA


################################################################################
# FUNCTION:                 DESCRIPTION:
#  symbolTable               Shows a table of plot symbols from a given font
################################################################################


symbolTable <- 
function(font = par('font'), cex = 0.7) 
{   
    # A function implemented by Diethelm Wuertz

    # Description:
    #   Shows a table of plot characters from a given font
    
    # Example:
    #   symbolTable()
    
    # Author:
    #   Unknown, piece of code found on the internet.

    # FUNCTION:
    
    # Table:
    plot(0, 0, xlim = c(-1, 11), ylim = c(0, 26), type = 'n', 
        axes = FALSE, xlab = '', ylab = '', 
        main = "Table of Plot Characters")
    j = -1
    for(i in 0:255) {
        if(i %% 25 == 0) {j = j+1; k = 26}
        k = k-1
        points(j, k, pch = i, font = font, cex = cex, col = 2)
        text(j + 0.50, k, i, cex = cex) 
    }
    
    # Return Value:
    invisible(font)
}


################################################################################
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU Library General Public License for more details.
#
# You should have received A copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA  02111-1307  USA


################################################################################
# FUNCTION:                 DESCRIPTION:
#  as.matrix.ts              Converts univariate ts to 1-column matrix
#  as.matrix.mts             Converts multivariate ts to matrix
################################################################################


## as.matrix.ts <-
## function(x, ...)
## {
##     # A function implemented by Diethelm Wuertz

##     # Description:
##     #   Coerces a "ts" object into a matrix

##     # FUNCTION:

##     # Transform:
##     ans = as.matrix.default(unclass(x))
##     attr(ans, "tsp")<-NULL
##     rownames(ans)<-NULL
##     colnames(ans)<-NULL

##     # Return Value:
##     ans
## }


## # ------------------------------------------------------------------------------


## as.matrix.mts <-
## function(x, ...)
## {
##     # A function implemented by Diethelm Wuertz

##     # Description:
##     #   Coerces a multivariate "ts" object into a matrix

##     # FUNCTION:

##     # Transform:
##     ans = as.matrix.default(unclass(x))
##     attr(ans, "tsp")<-NULL
##     rownames(ans)<-NULL
##     colnames(ans)<-NULL

##     # Return Value:
##     ans
## }


################################################################################
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 
# GNU Library General Public License for more details.
#
# You should have received A copy of the GNU Library General 
# Public License along with this library; if not, write to the 
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, 
# MA  02111-1307  USA


################################################################################
# FUNCTION:                 DESCRIPTION:
#  colorTable                Shows a table of plot color codes
################################################################################


colorTable <- 
function(cex = 0.7) 
{   
    # A function implemented by Diethelm Wuertz
    
    # Description:
    #   Displays a table of plot colors.
    
    # Author:
    #   Unknown, piece of code found on the internet.
    
    # Example:
    #   colorTable()
  
    # FUNCTION:
    
    # Plot:
    plot(0, 0, xlim = c(-1, 10), ylim = c(0, 10), type = 'n', axes = FALSE, 
        xlab = '', ylab = '', cex = cex, main = "Table of Color Codes")
    ## DW
    ## j = -1
    j = -2 ## here I have shifted the plot to the left ... DW
    for(i in 0:99) {
        if(i %% 10 == 0) {j = j+1; k = 10}
        k = k-1
        points(j, k, pch = 15, col = i, cex = 2)
        text(j+0.45, k, i, cex = cex)}
    
    # Return Value:
    invisible()
}


################################################################################
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU Library General Public License for more details.
#
# You should have received A copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA  02111-1307  USA


################################################################################
# FUNCTION:                 CONTROL ATTRIBUTES:
#  print.control             Prints unlisted control attributes  
# FUNCTION:                 DESCRIPTION:
#  .print                    Used in regression package
################################################################################


print.control <-
function(x, ...)
{
    # Return Value:
    print(unlist(x))
}


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

.print <- 
function(x, ...)
{
    UseMethod(".print")
}


# ------------------------------------------------------------------------------


.plot <- 
function(x, ...)
{
    UseMethod(".plot")
}


# ------------------------------------------------------------------------------


.summary <- 
function(object, ...)
{
    UseMethod(".summary")
}


# ------------------------------------------------------------------------------


.predict <- 
function(object, ...)
{
    UseMethod(".predict")
}


################################################################################
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU Library General Public License for more details.
#
# You should have received A copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA  02111-1307  USA


################################################################################
# FUNCTION:                 DESCRIPTION:
#  .recessionLines           Adds vertical recession lines to a plot
################################################################################


.recessionLines <-
function() 
{
    # A function implemented by Diethelm Wuertz
    
    # Description:
    #   Adds vertical recession lines to a plot
    
    # Arguments:
    #   none
       
    # References:
    #   http://www.nber.org/cycles/cyclesmain.html
    
    # FUNCTION:
    
    # Add Recession Liones:
    abline(v = as.POSIXct(c(
        "1920-01-01", "1921-08-01",
        "1923-05-01", "1924-07-01",
        "1926-10-01", "1927-11-01",
        "1929-08-01", "1933-03-01",
        "1945-01-01", "1945-10-01",
        "1948-11-01", "1949-10-01",
        "1953-07-01", "1954-05-01",
        "1957-08-01", "1958-04-01",
        "1960-04-01", "1961-02-01",
        "1969-12-01", "1970-11-01",
        "1973-11-01", "1975-03-01",
        "1990-07-01", "1991-03-01",
        "2001-03-01", "2001-11-01", 
        "2007-12-07")), col = "grey")
}


################################################################################
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 
# GNU Library General Public License for more details.
#
# You should have received A copy of the GNU Library General 
# Public License along with this library; if not, write to the 
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, 
# MA  02111-1307  USA


################################################################################
# FUNCTION:               DESCRIPTION:
#  composeURL              Compose URL from partial strings
#  indexGrep               Greps Lines given a pattern
################################################################################


composeURL <- 
    function(..., prefix = "http://")
{
    # A function implemented by Diethelm Wuertz
    
    # Description:
    #   Compose URL from partial strings
    
    # FUNCTION:
    
    # Return Value:
    paste(prefix, ..., sep = "")
}


# ------------------------------------------------------------------------------


indexGrep <- 
    function(pattern, x, ...)
{
    # A function implemented by Diethelm Wuertz
    
    # Description:
    #   Greps Lines given a pattern
    
    # FUNCTION:
    
    # Return Value:
    x[grep(pattern, x, ...)]
}


################################################################################
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA  02111-1307  USA


################################################################################
# FUNCTION:             DESCRIPTION:
#  grid2d                Returns from two vectors x-y grid coordinates
################################################################################


grid2d <- 
    function(x = (0:10)/10, y = x)
{   
    # A function implemented by Diethelm Wuertz

    # Description:
    #   Creates from two vectors x-y grid coordinates
    
    # Arguments:
    #   x, y - two numeric vectors defining the x and y coordinates.
    
    # Value:
    #   returns a list with two vectors named $x and $y spanning the 
    #   grid defined by the coordinates x and y.
    
    # Example:
    #   > grid2d(1:3, 1:2)
    #       $x
    #       [1] 1 2 3 1 2 3
    #       $y
    #       [1] 1 1 1 2 2 2

    # FUNCTION: 
    
    # Prepare for Input:
    nx  = length(x)
    ny  = length(y)
    xoy = cbind(rep(x, ny), as.vector(matrix(y, nx, ny, byrow = TRUE)))
    XY  = matrix(xoy, nx * ny, 2, byrow = FALSE)
    
    # Return Value:
    list(x = XY[, 1], y = XY[, 2])
}



################################################################################
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA  02111-1307  USA


###############################################################################
# FUNCTION:
#  print.solver
#  summary.solver
###############################################################################


print.solver <- 
    function(x, ...)
{
    # A function implemented by Diethelm Wuertz
    
    # Number of Variables:
    nSolution <- length(x$solution)
    
    # Print:
    cat("\nSolver:      ", x$solver)
    cat("\nSolution:    ", 1, ":", x$solution[1])
    for (i in 2:nSolution) 
    cat("\n             ", i, ":", x$solution[i])
    cat("\nObjective:   ", x$objective)
    cat("\nStatus:      ", x$status)
    cat("\nMessage:     ", x$message)
    cat("\n")
}


# -----------------------------------------------------------------------------


.summary.solver <- 
     function(object, ...)
{
    # A function implemented by Diethelm Wuertz
    
    # Print:
    print(object[1])
}


###############################################################################
#common utility functions

.faoutlierClusterEnv <- new.env(parent=emptyenv())
.faoutlierClusterEnv$ncores <- 1L

myApply <- function(X, MARGIN, FUN, progress = FALSE, ...){
    usepar <- if(MARGIN == 1L){
            ifelse(length(X[,1]) > 2*.faoutlierClusterEnv$ncores, TRUE, FALSE)
        } else {
            ifelse(length(X[1,]) > 2*.faoutlierClusterEnv$ncores, TRUE, FALSE)
        }
    if(!is.null(.faoutlierClusterEnv$CLUSTER) && usepar){
        if(progress){
            return(pbapply::pbapply(cl=.faoutlierClusterEnv$CLUSTER, X=X,
                                     MARGIN=MARGIN, FUN=FUN, ...))
        } else return(t(parallel::parApply(cl=.faoutlierClusterEnv$CLUSTER, X=X,
                                    MARGIN=MARGIN, FUN=FUN, ...)))
    } else {
        if(progress){
            return(pbapply::pbapply(X=X, MARGIN=MARGIN, FUN=FUN, ...))
        } else return(t(apply(X=X, MARGIN=MARGIN, FUN=FUN, ...)))
    }
}

myLapply <- function(X, FUN, progress = FALSE, ...){
    usepar <- ifelse(length(X) > 2*.faoutlierClusterEnv$ncores, TRUE, FALSE)

    if(!is.null(.faoutlierClusterEnv$CLUSTER) && usepar){
        if(progress){
            return(pbapply::pblapply(cl=.faoutlierClusterEnv$CLUSTER, X=X,
                                     fun=FUN, ...))
        } else return(parallel::parLapply(cl=.faoutlierClusterEnv$CLUSTER, X=X,
                                   fun=FUN, ...))
    } else {
        if(progress){
            return(pbapply::pblapply(X=X, FUN=FUN, ...))
        } else return(lapply(X=X, FUN=FUN, ...))
    }
}
check_type <- function(.data) {
  if (data.table::is.data.table(.data)) {
    data_type <- "is_data_table"
  } else if (tibble::is_tibble(.data)) {
    data_type <- "is_tibble"
  } else {
    data_type <- "is_data_frame"
  }

  return(data_type)
}

fix_data_type <- function(.data, data_type) {
  if (data_type == "is_data_frame") {
    .data <- as.data.frame(.data)
  } else if (data_type == "is_tibble") {
    .data <- tibble::as_tibble(.data)
  }

  return(.data)
}
#' Download a model from a BiGG json file
#' 
#' @param address An address to download from
#' 
#' @return A model in expanded format
#' 
#' @export
#' 
#' @importFrom rlang .data
#' @import dplyr
get_BiGG <- function(address){
  if(!requireNamespace('jsonlite', quietly = TRUE)){
    stop('This function requires jsonlite. Please install it before continuing')
  }
  
  
  json_mod <- jsonlite::fromJSON(address)
  
  res <- list()
  
  res$rxns <- json_mod$reactions %>%
    purrr::keep(is.vector) %>%
    rename(abbreviation = .data$id,
           officialName = .data$name,
           lowbnd = .data$lower_bound,
           uppbnd = .data$upper_bound,
           geneAssociation = .data$gene_reaction_rule
    ) %>%
    mutate(obj_coef = coalesce(.data$objective_coefficient, 0))
  
  res$mets <- json_mod$metabolites %>% 
    purrr::keep(is.vector) %>%
    transmute(chemical = .data$id,
              compartment = .data$compartment,
              name = .data$name) %>%
    recompose_metabolites()
  
  res$stoich <- json_mod$reactions$metabolites %>%
    mutate(abbreviation = json_mod$reactions$id) %>%
    tidyr::gather(key = 'met', value = 'stoich', -.data$abbreviation, na.rm=TRUE)
  
  return(res)
  
}
#' Get path to feather example files
#'
#' @description
#' \code{feather_example} gets the path of a specific example
#'
#' @param x example file
#' @export
#' @keywords internal
feather_example <- function(x) {
  system.file("feather", x, mustWork = TRUE, package = "feather")
}

#' @description
#' \code{feather_examples} gets the path of all examples
#'
#' @export
#' @rdname feather_example
feather_examples <- function() {
  path <- feather_example("")
  stats::setNames(dir(path, full.names = TRUE), dir(path))
}



dim_desc <- function(x) {
  paste0("[", paste0(big_mark(x), collapse = " x "), "]")
}

big_mark <- function(x, ...) {
  mark <- if (identical(getOption("OutDec"), ",")) "." else ","
  formatC(x, big.mark = mark, ...)
}
#' @rdname filesstrings-defunct
#' @export
AllEqual <- function(...) {
  .Defunct("all_equal")
}

#' @rdname filesstrings-defunct
#' @export
GroupClose <- function(...) {
  .Defunct("group_close")
}
# Some bitwise operators.
# CRAN check complains if we assign these functions directly!
`%<<%` <- function(a, b) bitwShiftL(a, b)
`%>>%` <- function(a, b) bitwShiftR(a, b)
`%&%`  <- function(a, b) bitwAnd(a, b)


# More for binary reading.
unsigned_I <- function(raw_vector) {  # fmt = "I"
  # 0:31 because this "I" is four bytes (32 bits).
  sum(2 ^ .subset(0:31, bool(rawToBits(raw_vector))))
}


# Better names for builtins!
string <- as.character
bool   <- as.logical


# One liners.
`%notin%` <- function(x, table) match(x, table, nomatch = 0L) == 0L
zchar     <- function(x) !nzchar(x)  # double negative ennit
`%or%`    <- function(lhs, rhs) if (is.null(lhs)) rhs else lhs
rm_nulls  <- function(.ls) .ls[!vapply(.ls, is.null, logical(1))]
inquotes  <- function(x) sprintf("'%s'", x)


# Used when forming data messages.
get_field_name <- function(field_def) field_def$field$name %or% ""

extract_field_names <- function(field_defs) {
  .names <- vapply(field_defs, get_field_name, "")
  ifelse(nchar(.names), .names, "unknown")   # FitCSVTool.jar behaviour
}

get_field_units <- function(field_def) field_def$field$units %or% ""

extract_units <- function(field_defs) {
  vapply(field_defs, get_field_units, "")
}


# Decode protocol and profile versions the same way the SDK does.
decode_protocol_version <- function(protocol_venc) {
  as.double(sprintf("%d.%d",
    protocol_venc %>>% 4, protocol_venc %&% ((1 %<<% 4) - 1)
  ))
}

decode_profile_version <- function(profile_venc) {
  as.double(sprintf("%d.%d",
    trunc(profile_venc / 100), profile_venc %% 100
  ))
}
relk_to_plc <- function(relk)100 - 100*relk

plc_to_relk <- function(plc)(100 - plc)/100

ab_to_px <- function(a,b,x)(log(1/(1 - x/100) - 1)/a) + b

sigmoid_untrans <- function(x)(100 - 100/(exp(x) + 1))/100

boot_ci <- function(b, coverage){
  
  a <- (1 - coverage)/2
  quantile(b, probs=c(a, 1-a))
  
}


seq_within <- function(v, n=101){
  
  Min <- min(v, na.rm=TRUE)
  Max <- max(v, na.rm=TRUE)
  seq(Min,Max,length=n)
  
}


label_lowci <- function(coverage) sprintf("%s%%", 100*(1 - coverage)/2)
label_upci <- function(coverage) sprintf("%s%%", 100*(coverage + (1 - coverage)/2))
label_coverage <- function(coverage)paste0(100*coverage,"%")


ci_names <- function(prefix="", coverage=0.95, sep = " - "){
  c(sprintf("%s%s%s",prefix,
            ifelse(prefix == "", "", sep),
            label_lowci(coverage)),
    sprintf("%s%s%s",prefix,
            ifelse(prefix == "", "", sep),
            label_upci(coverage)))
}
##
## Utility functions
##

# Validate R and r
validate.Rr <- function(R,r){
  if(r<2 || R<2)
    stop("R and r must both be 2 or larger")
  if(r>R)
    stop("r can not be larger than R")
}

# Change NAs to NaNs
NA2NaN <- function(k){
  if(any(is.na(k)))
    warning("NaN(s) produced", call.=FALSE)
  k[is.na(k)] <- NaN
  k
}

# Stirling's approximation to the log of a factorial
facL <- function(n){
  x <- n*log(n) + log(n*sqrt(2*pi/n)) - n + log(1 + 1/(12*n))
  x[n==0] <- 0
  x
}
date_check <- function(start_date, end_date) {
  if (missing(start_date) || missing(end_date)) {
    stop("Values for `start_date` and `end_date` parameters must be included",
      call. = FALSE
    )
  }

  if (as.numeric(as.Date(end_date) - as.Date(start_date)) > 365) {
    stop("Only 365 dats of data can be returned at one time",
      call. = FALSE
    )
  }
}
base_util <- function(base) {
  act <- Sys.getenv("FIXER_ACT_TYPE")

  if (!identical(act, "free") && !identical(act, "") ||
    identical(base, "EUR")) {
    base_query <- paste0("&base=", base)
  } else {
    base_query <- ""
    warning("Currency base only available on paid plans.")
  }

  base_query
}
symbols_util <- function(symbols) {
  ifelse(!is.null(symbols),
    paste0(
      "&symbols=",
      paste0(symbols, collapse = ",")
    ), ""
  )
}
# success check utility
success_check <- function(result) {
  if (!result$success) {
    stop(paste(
      "Error code:", result$error$code, "\n",
      "Error type:", result$error$type, "\n",
      "Error message:", result$error$info
    ), call. = FALSE)
  }

  result
}
act <- Sys.getenv("FIXER_ACT_TYPE")

fixer_url <- ifelse(identical(act, "free") || identical(act, ""),
  "http://data.fixer.io/api/", "https://data.fixer.io/api/"
)
# return a string as a tempfile
as_tmpfile <- function(str) {
  if (length(str) > 0) {
    str_tmpfile <- tempfile("rmarkdown-str", fileext = ".html")
    writeLines(str, str_tmpfile)
    str_tmpfile
  } else {
    NULL
  }
}

# A variant of relative_to that normalizes its inputs.
normalized_relative_to <- function(dir, file) {
  rmarkdown::relative_to(
    normalizePath(dir, winslash = "/", mustWork = FALSE),
    normalizePath(file, winslash = "/", mustWork = FALSE))
}

# devel mode
knit_devel <- function(input, ...) {
  rmarkdown::render(input,
                    output_options = list(devel = TRUE),
                    quiet = TRUE)
}
#
#  Copyright (C) 2004-2016 Friedrich Leisch and Bettina Gruen
#  $Id: utils.R 5079 2016-01-31 12:21:12Z gruen $
#

list2object = function(from, to){
    n = names(from)
    s = slotNames(to)
    p = pmatch(n, s)
    if(any(is.na(p)))
        stop(paste("\nInvalid slot name(s) for class",
                   to, ":", paste(n[is.na(p)], collapse=" ")))
    names(from) = s[p]
    do.call("new", c(from, Class=to))
}

printIter = function(iter, logLik, label="Log-likelihood")
    cat(formatC(iter, width=4),
        label, ":", formatC(logLik, width=12, format="f"),"\n")
    

## library(colorspace)
## dput(x[c(1,3,5,7,2,4,6,8)])

## x = hcl(seq(0, 360*7/8, length.out = 8), c=30)
LightColors <- c("#F9C3CD", "#D0D4A8", "#9DDDD5", "#D1CCF5",
                 "#EDCAB2", "#AFDCB8", "#ACD7ED", "#EFC4E8")
    
## x = hcl(seq(0, 360*7/8, length.out = 8), c=100, l=65)
FullColors <- c("#FF648A", "#96A100", "#00BCA3", "#9885FF",
                "#DC8400", "#00B430", "#00AEEF", "#F45BE1")


###**********************************************************

## similar defaults to silhouette plots in flexclust
unipolarCols <- function(n, hue=0, chr=50, lum = c(55, 90))
{
    lum <- seq(lum[1], lum[2], length=n)
    hcl(hue, chr, lum)
}


bipolarCols <- function(n, hue=c(10, 130), ...)
{        
    if(n%%2){ # n odd
        n2 <- (n-1)/2
        c1 <- unipolarCols(n2, hue[1])
        c2 <- rev(unipolarCols(n2, hue[2]))
        return(c(c1, "white", c2))
    }
    else{ # n even
        n2 <- n/2
        c1 <- unipolarCols(n2, hue[1])
        c2 <- rev(unipolarCols(n2, hue[2]))
        return(c(c1, c2))
    }
}

###**********************************************************
#' Build a `ZeroCurve` from example data set
#'
#' This creates a [`ZeroCurve`][ZeroCurve] object from the example data set
#' `zerocurve.csv`.
#'
#' @param interpolation an `Interpolation` object
#' @return a `ZeroCurve` object using data from `zerocurve.csv`
#' @examples
#' build_zero_curve(LogDFInterpolation())
#' @export
#' @family build object helpers

build_zero_curve <- function(interpolation = NULL) {
  filepath <- system.file("extdata", "zerocurve.csv", package = "fmbasics")
  df <- utils::read.csv(filepath, header = TRUE, stringsAsFactors = FALSE)
  zc_df <- tibble::as_tibble(df)
  values <- zc_df$dfs
  starts <- as.Date(as.character(zc_df[["start"]]), "%Y%m%d")
  ends <- as.Date(as.character(zc_df[["end"]]), "%Y%m%d")
  dfs <- DiscountFactor(values, starts, ends)
  ZeroCurve(dfs, starts[1], interpolation %||% LogDFInterpolation())
}

`%||%` <- function (x, y) if (is.null(x)) y else x


is_atomic_list <- function(ll, .p) {
  is.list(ll) && all(vapply(ll, .p, logical(1), USE.NAMES = FALSE))
}

assertthat::on_failure(is_atomic_list) <- function(call, env) {
  "Element of the list are not all of the same class"
}
is_list_of <- function (object, class) {
  is.list(object) && Reduce(`&&`, Map(is, object, class))
}
`%||%` <- function(x, y) {
    if (is.null(x)) return(y)
    x
}

`%~~%` <- function(x, y) {
    if (length(x) == 0L) return(y)
    x
}

convert_nas <- function(tbl, replace_with = 0L) {
    tbl[is.na(tbl)] <- replace_with
    tbl
}

convert_email_to_cran_format <- function(email) {
    ## check email
    lapply(email, function(x)
        if (!grepl("\\@", x)) {
            stop("Malformed email address: ", sQuote(email), call. = FALSE)
        })
    email <- gsub("\\@", "_at_", tolower(email))
    ##  "all characters different from letters, digits, hyphens,
    ##  underscores, colons, and periods replaced by underscores ..."
    email <- gsub("[^[:alnum:]_:.-]", "_", email)
    email
}

add_cols <- function(tbl) {
    names(tbl)[match("Package", names(tbl))] <- "package"
    to_add <- setdiff(names(default_cran_results), names(tbl))
    if (length(to_add) > 0) {
        col_to_add <- replicate(length(to_add), list(rep(0L, nrow(tbl))))
        names(col_to_add) <- to_add
        col_to_add <- as.tibble(col_to_add)
        res <- cbind(tbl, col_to_add)
        tbl <- tibble::as.tibble(res)
    }
    convert_nas(tbl)[, names(default_cran_results)]
}
#' Pipe operator
#'
#' See \code{\link[magrittr]{\%>\%}} for more details.
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @export
#' @importFrom magrittr %>%
#' @usage lhs \%>\% rhs
NULL


check_factor <- function(f) {
  if (is.character(f)) {
    factor(f)
  } else if (is.factor(f)) {
    f
  } else {
    stop("`f` must be a factor (or character vector).", call. = FALSE)
  }
}

check_factor_list <- function(fs, arg_name = "fs") {
  if (!is.list(fs)) {
    stop("`fs` must be a list", call. = FALSE)
  }

  is_factor <- vapply(fs, is.factor, logical(1))
  if (any(!is_factor)) {
    stop("All elements of `", arg_name, "` must be factors", call. = FALSE)
  }

  fs
}
`%||%` <- function(x, y) if(is.null(x)) y else x
#
#  Copyright (C) 2005-2008 Friedrich Leisch
#  $Id: utils.R 3 2013-06-12 10:06:43Z leisch $
#

list2object = function(from, to){
    n = names(from)
    s = slotNames(to)
    p = pmatch(n, s)
    if(any(is.na(p)))
        stop(paste("\nInvalid slot name(s) for class",
                   to, ":", paste(n[is.na(p)], collapse=" ")))
    names(from) = s[p]
    do.call("new", c(from, Class=to))
}
"%||%" <- function(x, y) if (is.null(x)) y else x


common_by <- function(by = NULL, x, y) {
  if (is.list(by)) return(by)

  if (!is.null(by)) {
    x <- names(by) %||% by
    y <- unname(by)

    # If x partially named, assume unnamed are the same in both tables
    x[x == ""] <- y[x == ""]

    return(list(x = x, y = y))
  }

  by <- intersect(dplyr::tbl_vars(x), dplyr::tbl_vars(y))
  if (length(by) == 0) {
    stop("No common variables. Please specify `by` param.", call. = FALSE)
  }
  message("Joining by: ", utils::capture.output(dput(by)))

  list(
    x = by,
    y = by
  )
}
## Required functions borrowed from the VineCopula package because
## they are not exported

createMaxMat <- function(Matrix){
  
  if(dim(Matrix)[1]!=dim(Matrix)[2]) 
    stop("Structure matrix has to be quadratic.")
  
  MaxMat <- reorderRVineMatrix(Matrix)  
  n  <- nrow(MaxMat)  
  for(j in 1:(n-1)){
    for(i in (n-1):j){
      MaxMat[i,j] <- max(MaxMat[i:(i+1),j])
    }
  }
  
  tMaxMat <- MaxMat
  tMaxMat[is.na(tMaxMat)] <- 0  
  oldSort <- diag(Matrix)
  oldSort <- oldSort[n:1]  
  for(i in 1:n){
    MaxMat[tMaxMat == i] <- oldSort[i]
  }
  
  return(MaxMat)
}

neededCondDistr <- function(Vine){
  if(dim(Vine)[1]!=dim(Vine)[2]) stop("Structure matrix has to be quadratic.")
  
  Vine <- reorderRVineMatrix(Vine)
  MaxMat <- createMaxMat(Vine)
  d <- nrow(Vine)
  
  M <- list()
  M$direct <- matrix(FALSE,d,d)
  M$indirect <- matrix(FALSE,d,d)  
  M$direct[2:d,1] <- TRUE
  
  for(i in 2:(d-1)){
    v <- d-i+1 
    bw <- as.matrix(MaxMat[i:d,1:(i-1)]) == v  
    direct <- Vine[i:d,1:(i-1)] == v  
    M$indirect[i:d,i] <- apply(as.matrix(bw & (!direct)),1,any)   
    M$direct[i:d,i] <- TRUE  
    M$direct[i,i] <- any(as.matrix(bw)[1,] & as.matrix(direct)[1,])
  }
  
  return(M)
}

reorderRVineMatrix <- function(Matrix){
  oldOrder <- diag(Matrix) 
  O <- apply(t(1:nrow(Matrix)),2,"==", Matrix) 
  for(i in 1:nrow(Matrix)){
    Matrix[O[,oldOrder[i]]] <- nrow(Matrix)-i+1
  }  
  return(Matrix)
}
#' Cast matrix to an adjacency matrix
#'
#' Create and assign a new class for use of \code{geomnet}'s \code{\link{fortify.adjmat}} function.
#' @param dat A square adjacency matrix.
#' @export
as.adjmat <- function(dat){
  if (class(dat) != "matrix"){
    stop("as.adjmat requires a matrix object")
  }
  if (nrow(dat) != ncol(dat)){
    stop("dat must be a square matrix")
  }
  if (sum(rownames(dat)!=colnames(dat)) > 0){
    stop("row and column names of dat must match")
  }
  class(dat) <- c("adjmat", "matrix")
  return(dat)
}

#' Cast a data frame to an edgedf
#'
#' Create and assign a new class for use of \code{geomnet}'s \code{\link{fortify.edgedf}} function.
#' @param dat A network edgelist of class \code{"data.frame"} for use with \code{\link{fortify.edgedf}}.
#' @export
as.edgedf <- function(dat){
  if (class(dat) != "data.frame"){
    stop("as.edgedf requires a data.frame object")
  }
  if (ncol(dat) < 2){
    stop("dat should have at least 2 columns (from node and to node)")
  }
  from_id <- names(dat)[1]
  to_id <- names(dat)[2]
  message(paste("Using", from_id, "as the from node column and",
              to_id, "as the to node column.
If this is not correct, rewrite dat so that the first 2 columns are from and to node, respectively."))
  names(dat)[1:2] <- c("from_id", "to_id")
  class(dat) <- c("edgedf", "data.frame")
  return(dat)
}
# taken from the raster package
#   the function isn't exported from raster so it must be replicated here
# author Robert Hijmans
# June 2010
# version 1.0
# license GPL3


.compareCRS <- function(x, y, unknown=FALSE, verbatim=FALSE, verbose=FALSE) {
	
	x <- tolower(projection(x))
	y <- tolower(projection(y))
	
	step1 <- function(z, verbatim) {
		z <- gsub(' ', '', z)
		if (!verbatim) {
			z <- unlist( strsplit(z, '+', fixed=TRUE) )[-1]
			z <- do.call(rbind, strsplit(z, '='))
		}
		z
	}
	
	if (verbatim) {
		return(x==y)
	}
	
	x <- step1(x, verbatim)
	y <- step1(y, verbatim)
	
	if (length(x) == 0 | length(y) == 0) {
		if (unknown) {
			return(TRUE)
		} else {
			if (verbose) {
				cat('Unknown CRS\n')
			}
			return(FALSE) 
		}
	}
	x <- x[x[,1] != 'towgs84', , drop=FALSE]
	x <- x[which(x[,1] %in% y[,1]), ,drop=FALSE]
	y <- y[which(y[,1] %in% x[,1]), ,drop=FALSE]
	x <- x[order(x[,1]), ,drop=FALSE]
	y <- y[order(y[,1]), ,drop=FALSE]
	i <- x[,2] == y[,2]
	
	if (! all(i)) {
		if (verbose) {
			i <- which(!i)
			for (j in i) {
				cat('+',x[j,1], ':  ', x[j,2],' != ', y[j,2], '\n', sep='') 
			}
		}
		return(FALSE)
	}
	return(TRUE)
}

cellsBuffer = function(cells, buffer) {
	cells = squareRaster(cells)
  
	buffer =  ceiling(buffer/xres(cells))
	
	cellsInla = raster::extend(cells, c(buffer, buffer))
	values(cellsInla ) =  
			c(t(matrix(seq(1,ncell(cellsInla)), 
									nrow=nrow(cellsInla), ncol=ncol(cellsInla))))
	names(cellsInla) = "space"
	
	
	result = list(small=crop(cellsInla, cells), big=cellsInla)
}
isaterm <- function()
{
  gui <- .Platform$GUI

  if (!isatty(stdin()))
    return(FALSE)
  # ban emacs: here and everywhere else in life
  else if (Sys.getenv("EMACS") == "t" || identical(getOption("STERM"), "iESS"))
    return(FALSE)
  else if (gui == "RTerm" || gui == "X11")
    return(TRUE)
  else if (gui == "unknown" && .Platform$OS.type == "unix" && Sys.getenv("RSTUDIO") != 1 && Sys.getenv("R_GUI_APP_VERSION") == "")
    return(TRUE) # I think?
  else
    return(FALSE)
}



hastcltk <- function()
{
  test <- tryCatch(requireNamespace("tcltk", quietly=TRUE), warning=identity)
  if (!is.logical(test))
    test <- FALSE
  
  test
}
# Copyright (c) 2011-2013 Trevor L. Davis <trevor.l.davis@gmail.com>  
#  
#  This file is free software: you may copy, redistribute and/or modify it  
#  under the terms of the GNU General Public License as published by the  
#  Free Software Foundation, either version 2 of the License, or (at your  
#  option) any later version.  
#  
#  This file is distributed in the hope that it will be useful, but  
#  WITHOUT ANY WARRANTY; without even the implied warranty of  
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU  
#  General Public License for more details.  
#  
#  You should have received a copy of the GNU General Public License  
#  along with this program.  If not, see <http://www.gnu.org/licenses/>.  

#' Returns file name of calling Rscript
#'
#' \code{get_Rscript_filename} returns the file name of calling Rscript 
#' @return A string with the filename of the calling script.
#'      If not found (i.e. you are in a interactive session) returns NA.
#'
#' @export
get_Rscript_filename <- function() {
    prog <- sub("--file=", "", grep("--file=", commandArgs(), value=TRUE)[1])
    if( .Platform$OS.type == "windows") { 
        prog <- gsub("\\\\", "\\\\\\\\", prog)
    }
    prog
}

#' Recursively sorts a list
#'
#' \code{sort_list} returns a sorted list
#' @param unsorted_list A list.
#' @return A sorted list.
#' @export
sort_list <- function(unsorted_list) {
    for(ii in seq(along=unsorted_list)) {
        if(is.list(unsorted_list[[ii]])) {
            unsorted_list[[ii]] <- sort_list(unsorted_list[[ii]])
        }
    }
    unsorted_list[sort(names(unsorted_list))] 
}
# color and differentiation aesthetics
.color_diff_aesthetics <- c(
  "fill", "bg", "fg", "col", "colour", "color", "alpha",
  "lty", "linetype", "cex", "lwd", "size", "pch", "shape"
)
#' Pipe operator
#'
#' See \code{magrittr::\link[magrittr]{\%>\%}} for details.
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @export
#' @importFrom magrittr %>%
#' @usage lhs \%>\% rhs
NULL
create_link_function <- function(fam, link) {
  # for generalized linear models, we need the family and link function first
  if (fam == "binomial")
    ff <- stats::binomial(link = link)
  else if (fam == "poisson")
    ff <- stats::poisson(link = link)
  else if (fam == "gaussian")
    ff <- stats::gaussian(link = link)
  else if (fam == "Gamma")
    ff <- stats::Gamma(link = link)
  else if (fam == "inverse.gaussian")
    ff <- stats::inverse.gaussian(link = link)
  else if (fam == "quasi")
    ff <- stats::quasi(link = link)
  else if (fam == "quasibinomial")
    ff <- stats::quasibinomial(link = link)
  else if (fam == "quasipoisson")
    ff <- stats::quasipoisson(link = link)

  ff
}
#' @importFrom stats family
get_link_fun <- function(model) {
  # get model family
  ff <- stats::family(model)

  # return link function, if exists
  if ("linkfun" %in% names(ff)) return(ff$linkfun)

  # else, create link function from link-string
  if ("link" %in% names(ff)) return(match.fun(ff$link))

  NULL
}


#' @importFrom stats terms weights
get_model_weights <- function(model) {
  w <- NULL
  tryCatch(
    {
      w <- stats::weights(model)
    },
    error = function(x) { NULL },
    warning = function(x) { NULL },
    finally = function(x) { NULL }
  )

  w
}
set_attributes_and_class <- function(data, model, t.title, x.title, y.title, l.title, legend.labels, x.axis.labels, faminfo, x.is.factor, full.data, constant.values = NULL) {
  # check correct labels
  if (!is.null(x.axis.labels) && length(x.axis.labels) != length(stats::na.omit(unique(data$x))))
    x.axis.labels <- as.vector(sort(stats::na.omit(unique(data$x))))

  # to tibble
  data <- tibble::as_tibble(data)

  # add attributes
  attr(data, "title") <- t.title
  attr(data, "x.title") <- x.title
  attr(data, "y.title") <- y.title
  attr(data, "legend.title") <- l.title
  attr(data, "legend.labels") <- legend.labels
  attr(data, "x.axis.labels") <- x.axis.labels
  attr(data, "x.is.factor") <- x.is.factor
  attr(data, "full.data") <- full.data
  attr(data, "constant.values") <- constant.values

  # remember fit family
  attr(data, "family") <- faminfo$family
  attr(data, "link") <- faminfo$link.fun
  attr(data, "logistic") <- ifelse(faminfo$is_bin, "1", "0")

  # and model-function
  attr(data, "fitfun") <- get_model_function(model)

  # add class attribute
  class(data) <- c("ggeffects", class(data))

  data
}
# Utilities

`%||%` <- function(lhs, rhs) {
  if (is.null(lhs)) {
    rhs
  } else {
    lhs
  }
}
#' @keywords internal
load_pkg <- function(x) {
  if (!require(x, character.only = TRUE)) {
    stop("install the '", x, "' package to use ggnetwork")
  }
}

#' Blank ggplot2 theme, suited for plotting networks.
#'
#' A \code{ggplot2} theme without lines, borders, axis text or titles, suited
#' for plotting networks.
#' @param base_size base font size
#' @param base_family base font family
#' @param ... other \code{\link{theme}} arguments
#' @export
theme_blank <- function(base_size = 12, base_family = "", ...) {
  ggplot2::theme_bw(base_size = base_size, base_family = base_family) +
    ggplot2::theme(
      axis.text = ggplot2::element_blank(),
      axis.ticks = ggplot2::element_blank(),
      axis.title = ggplot2::element_blank(),
      legend.key = ggplot2::element_blank(),
      panel.background = ggplot2::element_rect(fill = "white", colour = NA),
      panel.border = ggplot2::element_blank(),
      panel.grid = ggplot2::element_blank(),
      ...
    )
}

#' Blank ggplot2 theme with a panel border.
#'
#' A variation of \code{\link{theme_blank}} that adds a panel border to the
#' plot, which is often suitable for plotting faceted networks.
#' @param base_size base font size
#' @param base_family base font family
#' @param ... other \code{\link{theme}} arguments
#' @export
theme_facet <- function(base_size = 12, base_family = "", ...) {
  theme_blank(base_size = base_size, base_family = base_family) +
    ggplot2::theme(
      panel.border = ggplot2::element_rect(fill = NA, color = "grey50"),
      ...
    )
}
rd_aesthetics <- function(type, name) {
  obj <- switch(type,
    geom = find_subclass("Geom", name, globalenv()),
    stat = find_subclass("Stat", name, globalenv())
  )
  aes <- rd_aesthetics_item(obj)

  paste("\\code{", type, "_", name, "} ",
    "understands the following aesthetics (required aesthetics are in bold):\n\n",
    "\\itemize{\n",
    paste("  \\item \\code{", aes, "}", collapse = "\n", sep = ""),
    "\n}\n", sep = "")
}

rd_aesthetics_item <- function(x) {
  req <- x$required_aes
  all <- union(req, sort(x$aesthetics()))

  ifelse(all %in% req,
    paste0("\\strong{", all, "}"),
    all
  )
}
compute_grob_widths <- function(grob_layout, widths) {
  cols <- split(grob_layout, grob_layout$l)
  do.call("unit.c", lapply(cols, compute_grob_dimensions, dims = widths))
}

compute_grob_heights <- function(grob_layout, heights) {
  cols <- split(grob_layout, grob_layout$t)
  do.call("unit.c", lapply(cols, compute_grob_dimensions, dims = heights))
}

compute_grob_dimensions <- function(grob_layout, dims) {
  # If any don't have explicit dims, then width is NULL
  if (!any(grob_layout$type %in% names(dims))) {
    return(unit(1, "null"))
  }

  grob_layout <- grob_layout[grob_layout$type %in% names(dims), , drop = FALSE]

  dims <- unique(Map(function(type, pos) {
    type_width <- dims[[type]]
    if (length(type_width) == 1) type_width else type_width[pos]
  }, grob_layout$type, grob_layout$id))
  units <- vapply(dims, is.unit, logical(1))

  if (all(units)) {
    if (all(lapply(dims, attr, "unit") == "null")) unit(max(unlist(dims)), "null")
    else do.call("max", dims)
  } else {
    raw_max <- unit(max(unlist(dims[!units])), "cm")
    if (any(units)) {
      unit_max <- max(do.call("unit.c", dims[units]))
      max(raw_max, unit_max)
    }
    else {
      raw_max
    }
  }
}
#' @export
grid::unit

#' @export
grid::arrow

# Name ggplot grid object
# Convenience function to name grid objects
#
# @keyword internal
ggname <- function(prefix, grob) {
  grob$name <- grobName(grob, prefix)
  grob
}

width_cm <- function(x) {
  if (is.grob(x)) {
    convertWidth(grobWidth(x), "cm", TRUE)
  } else if (is.unit(x)) {
    convertWidth(x, "cm", TRUE)
  } else if (is.list(x)) {
    vapply(x, width_cm, numeric(1))
  } else {
    stop("Unknown input")
  }
}
height_cm <- function(x) {
  if (is.grob(x)) {
    convertWidth(grobHeight(x), "cm", TRUE)
  } else if (is.unit(x)) {
    convertHeight(x, "cm", TRUE)
  } else if (is.list(x)) {
    vapply(x, height_cm, numeric(1))
  } else {
    stop("Unknown input")
  }
}
# Col union
# Form the union of columns in a and b.  If there are columns of the same name in both a and b, take the column from a.
#
# @param data frame a
# @param data frame b
# @keyword internal
cunion <- function(a, b) {
  if (length(a) == 0) return(b)
  if (length(b) == 0) return(a)

  cbind(a, b[setdiff(names(b), names(a))])
}

# Interleave (or zip) multiple units into one vector
interleave <- function(...) UseMethod("interleave")
#' @export
interleave.unit <- function(...) {
  do.call("unit.c", do.call("interleave.default", plyr::llply(list(...), as.list)))
}
#' @export
interleave.default <- function(...) {
  vectors <- list(...)

  # Check lengths
  lengths <- unique(setdiff(plyr::laply(vectors, length), 1))
  if (length(lengths) == 0) lengths <- 1
  stopifnot(length(lengths) <= 1)

  # Replicate elements of length one up to correct length
  singletons <- plyr::laply(vectors, length) == 1
  vectors[singletons] <- plyr::llply(vectors[singletons], rep, lengths)

  # Interleave vectors
  n <- lengths
  p <- length(vectors)
  interleave <- rep(1:n, each = p) + seq(0, p - 1) * n
  unlist(vectors, recursive = FALSE)[interleave]
}
#' Compute the "resolution" of a numeric vector
#'
#' The resolution is the smallest non-zero distance between adjacent
#' values.  If there is only one unique value, then the resolution is defined
#' to be one. If x is an integer vector, then it is assumed to represent a
#' discrete variable, and the resolution is 1.
#'
#' @param x numeric vector
#' @param zero should a zero value be automatically included in the
#'   computation of resolution
#' @export
#' @examples
#' resolution(1:10)
#' resolution((1:10) - 0.5)
#' resolution((1:10) - 0.5, FALSE)
#'
#' # Note the difference between numeric and integer vectors
#' resolution(c(2, 10, 20, 50))
#' resolution(c(2L, 10L, 20L, 50L))
resolution <- function(x, zero = TRUE) {
  if (is.integer(x) || zero_range(range(x, na.rm = TRUE)))
    return(1)

  x <- unique(as.numeric(x))
  if (zero) {
    x <- unique(c(0, x))
  }

  min(diff(sort(x)))
}
# Name ggplot grid object
# Convenience function to name grid objects
#
# @keyword internal
ggname <- function(prefix, grob) {
  grob$name <- grobName(grob, prefix)
  grob
}

width_cm <- function(x) {
  if (is.grob(x)) {
    convertWidth(grobWidth(x), "cm", TRUE)
  } else if (is.list(x)) {
    vapply(x, width_cm, numeric(1))
  } else if (is.unit(x)) {
    convertWidth(x, "cm", TRUE)
  } else {
    stop("Unknown input")
  }
}

height_cm <- function(x) {
  if (is.grob(x)) {
    convertWidth(grobHeight(x), "cm", TRUE)
  } else if (is.list(x)) {
    vapply(x, height_cm, numeric(1))
  } else if (is.unit(x)) {
    convertHeight(x, "cm", TRUE)
  } else {
    stop("Unknown input")
  }
}
"%||%" <- function(a, b) {
  if (!is.null(a)) a else b
}

#' Return a boolean vector of non-empty items.
#'
#' @param xs Vector with a mix of "expression" items, "character" items,
#'  and items from other classes.
#' @return Boolean vector indicating which items are not empty.
#' @noRd
not_empty <- function(xs) {
  sapply(seq_along(xs), function(i) {
    if (is.expression(xs[i])) {
      return(length(nchar(xs[i])) > 0)
    } else {
      return(xs[i] != "")
    }
  })
}

#' Return a unit version of the argument.
#'
#' @param x Number or unit object.
#' @return unit(x, "lines") if number or the unchanged argument if it's already
#'  a unit object.
#' @noRd
to_unit <- function(x) {
  # don't change arg if already unit
  if (class(x) == "unit") {
    return(x)
  }

  # NA used to exclude points from repulsion calculations
  if (is.na(x)) {
    return(NA)
  }

  unit(x, "lines")
}
#' Reduce a list to a single value by iteratively applying a binary function
#'
#' Inspired by \code{reduce()} from the \code{purrr} package
#'
#' @param .x A list or atomic vector.
#' @param .f A 2-argument function. The function will be
#'   passed the accumulated value as the first argument and the "next" value
#'   as the second argument.
#' @param ... Additional arguments passed on to `.f`.
#' @param .init If supplied, will be used as the first value to start
#'   the accumulation, rather than using \code{x[[1]]}. This is useful if
#'   you want to ensure that `reduce` returns a correct value when `.x`
#'   is empty. If missing, and `x` is empty, will throw an error.
#'
#' @author Jonathon Love <jon@thon.cc>
#'
reduce <- function(.x, .f, ..., .init) {

  if (missing(.init)) {
    if (length(.x) == 0)
      stop('`.x` is empty, and no `.init` supplied')
    v <- .x[[1]]
    i <- 2
  }
  else {
    v <- .init
    i <- 1
  }

  while (i <= length(.x)) {
    v <- .f(v, .x[[i]], ...)
    i <- i + 1
  }

  v
}
# code that needed to be copied from ggplot2

# Name ggplot grid object, from ggplot2/R/utilities-grid.r
# Convenience function to name grid objects
#
# @keyword internal
ggname <- function(prefix, grob) {
  grob$name <- grid::grobName(grob, prefix)
  grob
}

# From ggplot2/R/utilities.r
snakeize <- function(x) {
  x <- gsub("([A-Za-z])([A-Z])([a-z])", "\\1_\\2\\3", x)
  x <- gsub(".", "_", x, fixed = TRUE)
  x <- gsub("([a-z])([A-Z])", "\\1_\\2", x)
  tolower(x)
}

snake_class <- function(x) {
  snakeize(class(x)[1])
}

with_seed_null <- function(seed, code) {
  if (is.null(seed)) {
    code
  } else {
    withr::with_seed(seed, code)
  }
}

"%||%" <- function(a, b) {
  if (!is.null(a)) a else b
}

# ggplot2 range code, from ggplot2/R/range.r

#' @importFrom ggplot2 ggproto
#' @noRd
Range <- ggproto("Range", NULL,
  range = NULL,
  reset = function(self) {
    self$range <- NULL
  }
)

#' @importFrom scales train_discrete
#' @noRd
RangeDiscrete <- ggproto("RangeDiscrete", Range,
  train = function(self, x, drop = FALSE, na.rm = FALSE) {
    self$range <- scales::train_discrete(x, self$range, drop = drop, na.rm = na.rm)
  }
)

discrete_range <- function() {
  ggproto(NULL, RangeDiscrete)
}


# ggplot2 aes code, from ggplot2/R/aes.r

# Look up the scale that should be used for a given aesthetic
aes_to_scale <- function(var) {
  var[var %in% c("x", "xmin", "xmax", "xend", "xintercept")] <- "x"
  var[var %in% c("y", "ymin", "ymax", "yend", "yintercept")] <- "y"

  var
}

# Figure out if an aesthetic is a position aesthetic or not
is_position_aes <- function(vars) {
  aes_to_scale(vars) %in% c("x", "y")
}
#' Pipe operator
#'
#' See \code{magrittr::\link[magrittr]{\%>\%}} for details.
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @export
#' @importFrom magrittr %>%
#' @usage lhs \%>\% rhs
NULL
charopts <- function(x) {
  paste(sprintf("\\code{\"%s\"}", x), collapse = ", ")
}

# copied from ggplot2
"%||%" <- function(a, b) {
  if (!is.null(a)) a else b
}

# copied from ggplot2
ggname <- function(prefix, grob) {
  grob$name <- grid::grobName(grob, prefix)
  grob
}
camelCase <- function(x) {
  words <- strsplit(x, "_")
  
  caps <- lapply(words, function(x) {
    if (length(x) == 1) return(x)
    x[-1] <- capitalise(x[-1])
    x
  })
  
  vapply(caps, paste0, collapse = "", FUN.VALUE = character(1))
}

under_score <- function(x) {
  substr(x, 1, 1) <- tolower(substr(x, 1, 1))
  tolower(gsub("([A-Z])", "_\\1", x))
}

capitalise <- function(x, first = TRUE) {
  substr(x, 1, 1) <- toupper(substr(x, 1, 1))
  x
}
reactive_id <- function(x) {
  attr(x, "reactive_id", TRUE)
}

`reactive_id<-` <- function(x, value) {
  attr(x, "reactive_id") <- value
  x
}


# Pull reactives out of various types of objects
extract_reactives <- function(x) UseMethod("extract_reactives")
#' @export
extract_reactives.ggvis_props <- function(x) {
  compact(lapply(x, extract_reactives))
}
#' @export
extract_reactives.prop_reactive <- function(x) x$value
#' @export
extract_reactives.default <- function(x) NULL

# Get the value of a reactive or non-reactive object.
value <- function(x) UseMethod("value")
#' @export
value.default <- function(x) x
#' @export
value.reactive <- function(x) x()

values <- function(x) lapply(x, value)
trim_ws <- function(x) {
  sub("\\s*$", "", sub("^\\s*", "", x))
}

## from devtools, among other places
compact <- function(x) {
  is_empty <- vapply(x, function(x) length(x) == 0, logical(1))
  x[!is_empty]
}

## from purrr, among other places
`%||%` <- function(x, y) {
  if (is.null(x)) {
    y
  } else {
    x
  }
}

## as seen in purrr, with the name `has_names()`
has_name <- function(x) {
  nms <- names(x)
  if (is.null(nms)) {
    rep_len(FALSE, length(x))
  } else {
    !(is.na(nms) | nms == "")
  }
}

has_no_names <- function(x) all(!has_name(x))

## if all names are "", strip completely
cleanse_names <- function(x) {
  if (has_no_names(x)) {
    names(x) <- NULL
  }
  x
}

## to process HTTP headers, i.e. combine defaults w/ user-specified headers
## in the spirit of modifyList(), except
## x and y are vectors (not lists)
## name comparison is case insensitive
## http://www.w3.org/Protocols/rfc2616/rfc2616-sec4.html#sec4.2
## x will be default headers, y will be user-specified
modify_vector <- function(x, y = NULL) {
  if (length(y) == 0L) return(x)
  lnames <- function(x) tolower(names(x))
  c(x[!(lnames(x) %in% lnames(y))], y)
}
#' Pipe operator
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @export
#' @usage lhs \%>\% rhs
NULL
#' @importFrom devtools github_pull
#' @export
devtools::github_pull

get_package_list <- function() {
  if(!exists("package_list", envir = .options)) {
    gh_update_package_list()
  }
  .options$package_list
}

stop_without_message <- function() {
  old_sem <- options("show.error.messages")$show.error.messages
  on.exit(options(show.error.messages = old_sem))
  options(show.error.messages = FALSE)
  stop()
}
has_names <- function(x) {
  nms <- names(x)
  if (is.null(nms)) {
    rep(FALSE, length(x))
  } else {
    !(is.na(nms) | nms == "")
  }
}

assign_args <- function(args, envir) {
  res <- vector("list", length(args))
  nms <- names(args)
  for (i in seq_along(args)) {
    assign(nms[[i]], eval(args[[i]], envir), envir = envir)
  }
}

# From tibble::recycle_columns
recycle_columns <- function (x) {
    if (length(x) == 0) {
        return(x)
    }
    lengths <- vapply(x, NROW, integer(1))
    if (any(lengths) == 0) {
      return(character())
    }
    max <- max(lengths)
    bad_len <- lengths != 1L & lengths != max
    if (any(bad_len)) {
      stop(call. = FALSE,
        ngettext(max,
          "Variables must be length 1",
          paste0("Variables must be length 1 or ", max), domain = NA))
    }
    short <- lengths == 1
    if (max != 1L && any(short)) {
        x[short] <- lapply(x[short], rep, max)
    }
    x
}

# From https://github.com/hadley/colformat/blob/0a35999e7d77b9b3a47b4a04662d1c2625f929d3/R/styles.R#L19-L25
colour_na <- function() {
  grDevices::rgb(5, 5, 2, maxColorValue = 5)
}

style_na <- function(x) {
  if (requireNamespace("crayon", quietly = TRUE)) {
    crayon::style(x, bg = colour_na())
  } else {
    x # nocov
  }
}

lengths <- function(x) {
  vapply(x, length, integer(1L))
}
integral <- function ( grid, values ) {
  return( sum( ( values[ -1 ] + values[ -length( values ) ] ) * diff( grid ) / 2 ) )
}


hhat <- function( p , lambda ) {  	# definisco la funzione h
  return( lambda / ( lambda + 1 / p ) )
}
integral <- function ( grid, values ) {
  return( sum( ( values[ -1 ] + values[ -length( values ) ] ) * diff( grid ) / 2 ) )
}


hhat <- function( p , lambda ) {  	# definisco la funzione h
  return( lambda / ( lambda + 1 / p ) )
}
#' Pipe operator
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @export
#' @importFrom magrittr %>%
#' @usage lhs \%>\% rhs
NULL
# purrr's map_df without dplyr
my_map_df <- function(.x, .f, ...){

  .f <- purrr::as_mapper(.f, ...)
  res <- map(.x, .f, ...)
  Reduce(rbind, res)

}


#' @importFrom jsonlite unbox
#' @noRd
jubox <- function(x){
  unbox(x)
}

# tests if a google storage URL
is.gcs <- function(x){
  out <- grepl("^gs://", x)
  if(out){
    my_message("Using Google Storage URI: ", x, level = 3)
  }
  out
}

# controls when messages are sent to user via an option
# 1 = low level, 2= debug, 3=normal
my_message <- function(..., level = 1){

  compare_level <- getOption("googleAuthR.verbose", default = 1)

  if(level >= compare_level){
    message(Sys.time()," -- ", ...)
  }

}
# Find Lat Column
#
# Tries to identify the latitude column
# @param names string of column names
find_lat_column <- function(names) {
  
  lat = names[grep("^(lat|lats|latitude|latitudes|stop_lat|shape_pt_lon)$", names, ignore.case = TRUE)]
  
  if (length(lat) == 1) {
    return(lat)
  }
  stop("Couldn't infer latitude column")
}

# Find Lon Column
#
# Tries to identify the longitude column
# @param names string of column names
find_lon_column <- function(names, calling_function) {
  
  lon = names[grep("^(lon|lons|lng|lngs|long|longs|longitude|longitudes|stop_lon|shape_pt_lon)$", names, ignore.case = TRUE)]
  
  if (length(lon) == 1) {
    return(lon)
  }
  stop("Couldn't infer longitude column")
}
# This is very single-byte-encoding-specific, but that
# should be ok because that is all I am expecting to
# get out of tracing a PostScript file
tidyString <- function(string) {
    # Convert any non-printing char to a full stop
    rawString <- charToRaw(string)
    nonPrinting <-  rawString < 32
    if (any(nonPrinting)) {
        rawString[nonPrinting] <- as.raw(46)
        rawToChar(rawString)
    } else {
        string
    }
}
# Test:
# tidyString(rawToChar(as.raw(1:40)))

readLTY <- function(ltyString) {
    tc <- textConnection(ltyString)
    lty <- scan(tc, quiet=TRUE)
    close(tc)
    lty
}

# Go from numeric vector for lty to string
fixLTY <- function(lty, lwd) {
    if (length(lty)) {
        # Minimum allowed is 1
        paste(as.hexmode(pmax(1, round(lty/lwd))),
              collapse="")
    } else {
        "solid"
    }
}
assign_grapes = Vectorize(function(names, from, to){
  if(!(names %in% ls(from))){
    warning("function ", names, " not in found.")
    return()
  }
  value = from[[names]]
  if(is.function(value))
    assign(x = grape_names(names), value = value, envir = to)
  else
    warning(names, " is not a function.")
}, vectorize.args = "names")

grape_names = function(names){
  paste0("%", names, "%")
}

name_if_function = function(name, from){
  if(is.function(from[[name]])) name
}

parse_from = function(from){
  if(is.character(from)){
    require(from, character.only = TRUE)
    from = paste0("package:", from) %>%
      as.environment
  }
  if(!is.environment(from))
    stop("argument 'from' must be a package name or an environment.")
  from
}
#' @importFrom raster xmin xmax
xrange <- function(x) {
  c(xmin(x), xmax(x))
}
#' @importFrom raster ymin ymax
yrange <- function(x) {
  c(ymin(x), ymax(x))
}
# select columns satisfying a condition

select_which_ <- hutils::select_which

unselect_ <- function(.data, .dots) {
  hutils::drop_cols(.data, vars = .dots)
}

`%notin%` <- function(x, y) {
  !(x %in% y)
}

# from dplyr::near
near <- function (x, y, tol = .Machine$double.eps^0.5) {
  abs(x - y) < tol
}

as.numeric_unless_warning <- function(x){
  tryCatch(as.numeric(x),
           error = function(e) e,
           warning = function(w){x})
}

# from testthat
`%||%` <- function (a, b) {
  if (is.null(a)) b else a
}

# Cosmetic: For line-breaking. Slower but easier to read.  
.add <- function(...) Reduce("+", list(...))

gforecast <- function(x, ...) {
  forecast::forecast(forecast::auto.arima(x), ...)
} 

# NSE
inflator_frac <- function(.data, front, over, under, new_col_name){
  # Will only be invoked where these vars don't exist
  setnames(.data, c(front, over, under), c("r", "a", "b"))
  r <- a <- b <- NULL
  .data[, (new_col_name) := r * a / b]
}

last_over_first <- function(x){
  if (is.numeric(x)){
    last(x) / first(x)
  } else {
    x
  }
}

MeanNumeric <- function(x){
  sum(as.numeric(x)) / length(x)
}

mean_of_nonzero <- function(x){
  MeanNumeric(x[x > 0])
}

is.nonnegative <- function(vec){
  is.numeric(vec) && !anyNA(vec) && all(vec >= 0)
}

are_zero <- function(x){
  x < .Machine$double.eps ^ 0.5
}

qtrs_ahead <- function(x, y) {
  stopifnot(y > x)
  x_year <- as.integer(substr(x, 0, 4))
  y_year <- as.integer(substr(y, 0, 4))
  x_qtr <- as.integer(substr(x, 7, 7))
  y_qtr <- as.integer(substr(y, 7, 7))
  
  if (x_year == y_year) {
    qtrs_ahead <- y_qtr - x_qtr
  } else {
    qtrs_ahead <- 4 - x_qtr + y_qtr + 4 * (y_year - x_year - 1)
  }
  qtrs_ahead
}
#' Run gridsampler app
#'
#' This function starts the gridsampler shiny app.
#' @param display.mode \code{auto} by default, can also be \code{showcase}.
#' See \link[shiny]{runApp}.
#' @param launch.browser Boolean, set \code{TRUE} to open the app in the browser.
#' See \link[shiny]{runApp}.
#' @export
#' @import shiny
#' @import shinythemes
#' @import shinyBS
#' @examples
#' \dontrun{
#' gridsampler()
#' }
gridsampler <- function(display.mode = "auto",
                        launch.browser = getOption("shiny.launch.browser", interactive())) {
  appDir <- system.file("shiny", package = "gridsampler")
  if (appDir == "") {
    stop("Could not find shiny directory. Try re-installing `gridsampler`.", call. = FALSE)
  }

  shiny::runApp(appDir, display.mode = display.mode, launch.browser = launch.browser)
}


#' Adjusted sampling function
#'
#' @inheritParams stats::sample
#' @keywords internal
#'
sample_new <- function(x, size, replace = FALSE, prob = NULL)
{
  if (length(x) == 1)
    rep(x, size)
  else
    sample(x=x, size=size, replace = replace, prob = prob)
}
## small utilities that are not exported
renameListElement <- function(L, old, new) {
  if (is.null(L)) return(NULL)
  names(L)[match(old, names(L))] <- new
  L
}

is.numericOrNull <- function(x) {
  is.numeric(x) | is.null(x)
}
old2new_par <- function(x)
{
    if(!inherits(x, "glcStruct")) 
        stop("x not of class 'glcStruct'")
    if(is.null(x$coeffs) & !is.null(x$angle))
       angle <- x$angle
    else 
       angle <- cart2angle(x$coeffs)
    new_params <- structure(
       list(noise = x$noise,
       angle = angle, 
       bias = x$bias),
       class=c("glcStruct", "list"))
    new_params
}

new2old_par <- function(x)
{
    if(!inherits(x, "glcStruct")) 
        stop("x not of class 'glcStruct'")
    if(!is.null(x$coeffs) & is.null(x$angle))
       coeffs <- x$coeffs
    else 
       coeffs <- angle2cart(x$angle)
    old_params <- structure(
       list(noise = x$noise,
       coeffs = coeffs, 
       bias = x$bias),
       class=c("glcStruct", "list"))
    old_params
}

cart2angle <- function(cart)
{
    x <- as.vector(cart)
    if(length(x) == 1) stop("no angle for 1D")
    else if(length(x) == 2)
    {
        x <- x / sqrt(sum(x^2))
	angles <- acos(x[1])
	if(x[2]<0) angles <- 2*pi - angles
    }
    else if(length(x) == 3)
    {
        x <- x / sqrt(sum(x^2))
	angles <- c(asin(x[3]), acos(x[1]/cos(asin(x[3]))) )
	if(x[2]<0) angles[2] <- 2*pi - angles[2]
    }
    else stop("length(x) should be between 1 and 3")
    angles
}

angle2cart <- function(angle)
{
    x <- as.vector(angle)
    if(length(x) == 1) cart <- c(cos(x), sin(x))
    else if(length(x) == 2)
        cart <- c(cos(x[1])*cos(x[2]), cos(x[1])*sin(x[2]), sin(x[1]))
    else stop("length(x) should be between 1 and 2")
    cart
}

unscale <- function(x)
{
    if(!is.null(attr(x,"scaled:scale")))
        x <- sweep(x, FUN="*", 2, attr(x,"scaled:scale"))
    if(!is.null(attr(x,"scaled:scale")))
        x <- sweep(x, FUN="+", 2, attr(x,"scaled:center"))
    attr(x,"scaled:scale") <- NULL
    attr(x,"scaled:center") <- NULL
    x
}
neg_to_pos <- function(x, max) {
  ifelse(x >= 0, x, max + 1 + x)
}

compare_unit <- function(x, y, comp = `=`) {
  if (length(x) == 0) return(y)
  if (length(y) == 0) return(x)

  x_val <- unclass(x)
  y_val <- unclass(y)

  x_unit <- attr(x, "unit")
  y_unit <- attr(x, "unit")

  if (!all(x_unit == y_unit)) {
    stop("Comparison of units with different types currently not supported")
  }

  unit(comp(x_val, y_val), x_unit)
}


insert.unit <- function (x, values, after = length(x)) {
  lengx <- length(x)
  if (lengx == 0) return(values)
  if (length(values) == 0) return(x)

  if (after <= 0) {
    unit.c(values, x)
  } else if (after >= lengx) {
    unit.c(x, values)
  } else {
    unit.c(x[1L:after], values, x[(after + 1L):lengx])
  }
}

"%||%" <- function(a, b) {
  if (!is.null(a)) a else b
}

width_cm <- function(x) {
  if (is.grob(x)) {
    convertWidth(grobWidth(x), "cm", TRUE)
  } else if (is.list(x)) {
    vapply(x, width_cm, numeric(1))
  } else if (is.unit(x)) {
    convertWidth(x, "cm", TRUE)
  } else {
    stop("Unknown input")
  }
}
height_cm <- function(x) {
  if (is.grob(x)) {
    convertWidth(grobHeight(x), "cm", TRUE)
  } else if (is.list(x)) {
    vapply(x, height_cm, numeric(1))
  } else if (is.unit(x)) {
    convertHeight(x, "cm", TRUE)
  } else {
    stop("Unknown input")
  }
}

# Check that x is same length as g, or length 1
len_same_or_1 <- function(x, g) {
  if(length(x) == 1 || length(x) == length(g)) {
    TRUE
  } else {
    FALSE
  }
}
#' Read a file from a .zip URL
#'
#' Download, read, and delete a .zip file
#'
#' @param url URL to a .zip file
read_zip_url <- function(url) {
  f <- function(tmp) {
    utils::download.file(url, tmp, quiet = TRUE)
    readr::read_lines(tmp)
  }
  tmp <- tempfile(fileext = ".zip")
  ret <- suppressWarnings(purrr::possibly(f, NULL)(tmp))
  unlink(tmp)

  ret
}


#' Discard all values at the start of .x while .p is true
#'
#' @param .x Vector
#' @param .p Logical vector
#'
#' @noRd
discard_start_while <- function(.x, .p) {
  if (.p[1] && any(!.p)) {
    .x <- utils::tail(.x, -(min(which(!.p)) - 1))
  }
  .x
}


#' Keep values at the start of .x while .p is true
#'
#' @param .x Vector
#' @param .p Logical vector
#'
#' @noRd
keep_while <- function(.x, .p) {
  if (.p[1] && any(!.p)) {
    .x <- utils::head(.x, min(which(!.p)) - 1)
  }
  .x
}


#' Discard all values at the start of .x while .p is true
#'
#' @param .x Vector
#' @param .p Logical vector
#'
#' @noRd
discard_end_while <- function(.x, .p) {
  rev(discard_start_while(rev(.x), rev(.p)))
}
utils::globalVariables(c("H", "J", "K", "Li", "Lijk", "Lik", "N",
                  "alpha", "dalpha", "lambda", "p", "q", "pik",
                  "theta_ls", "w", "x", "y", "z", "fitted_mean", "fitted_var"))

# convert original response data to integers
fac2int <- function(x) as.integer(factor(x, exclude = c(NA, NaN)))

# logical or infix function
`%||%` <- function(a, b) if (!is.null(a)) a else b

# calculate gamma gradient for case i
si_gamma <- function(i) {
    sum(pik[i, ] * Lik[i, ] * (theta_ls - fitted_mean[i]))/
    fitted_var[i]/Li[i] * x[i, 2:p]
}

# calculate lambda gradient for case i
si_lambda <- function(i) {
    sum(0.5 * pik[i, ] * Lik[i, ] * ((theta_ls - fitted_mean[i])^2/fitted_var[i] - 1))/Li[i] * z[i, 2:q]
}
### tidying bills datas

bills_tidy <- function(df, tidy_style) {
    
    if (nrow(df) > 0) {
        
        df$date._value <- as.POSIXct(df$date._value)
        
        df$date._datatype <- "POSIXct"
        
    }
    
    df <- hansard_tidy(df, tidy_style)
    
    df
    
}
# A function to make the results of calls to the API easier to work with.

hansard_tidy <- function(df, tidy_style) {

    if (nrow(df) > 0) {

        names(df) <- gsub("\\.", "_", names(df), perl = TRUE)

        names(df) <- gsub(
          "([[:lower:]])([[:upper:]])", "\\1_\\2", names(df), perl = TRUE
          )

        names(df) <- gsub("__", "_", names(df), perl = TRUE)

        names(df) <- gsub("^_", "", names(df), perl = TRUE)

        names(df) <- tolower(names(df))

        names(df)[names(df) == "x_about"] <- "about"

        names(df)[names(df) == "x_value"] <- "value"

        if (tidy_style == "camelCase") {

            names(df) <- gsub(
              "(^|[^[:alnum:]])([[:alnum:]])", "\\U\\2", names(df), perl = TRUE
              )

            substr(names(df), 1, 1) <- tolower(substr(names(df), 1, 1))

        } else if (tidy_style == "period.case") {

            names(df) <- gsub("_", "\\.", names(df), perl = TRUE)

        }

    }

    df

}
## Retrieves data from the API, using pagination
loop_query <- function(query, jpage, verbose){

  seq_list <- seq(from=0, to=jpage, by=1)

  pages <- list()

  for(i in seq_along(seq_list)){
    mydata <- jsonlite::fromJSON(paste0(query, seq_list[[i]]), flatten = TRUE)
    if (verbose == TRUE) {
      message("Retrieving page ", seq_list[[i]] + 1, " of ", jpage + 1)
    }
    pages[[seq_list[[i]] + 1]] <- mydata$result$items
  }

  df <- tibble::as_tibble(dplyr::bind_rows(pages))

  df

}
# Tidying research briefing retrievals
research_tidy <- function(df, tidy_style) {

    df$date._value <- gsub("T", " ", df$date._value)

    df$date._value <- lubridate::parse_date_time(df$date._value,
                                                 "Y-m-d H:M:Sz!*")

    df$date._datatype <- "POSIXct"

    df$description <- as.character(df$description)

    names(df)[names(df)=="_about"] <- "about"

    df$about <- gsub("http://data.parliament.uk/resources/", "", df$about)

    df$description[df$description == "NULL"] <- NA

    seq_list <- seq(from = 1, to = nrow(df), by = 1)

    pages <- list()

    for (i in seq_along(seq_list)) {

      if (is.null(df$section[[seq_list[[i]]]]) == FALSE) {

        df$section[[seq_list[[i]]]] <- hansard_tidy(df$section[[seq_list[[i]]]],
                                                    tidy_style)

      }
    }

    df <- hansard_tidy(df, tidy_style)

}
## Tidy function for constituency calls

cons_tidy <- function(df, current, tidy_style) {
    
    if (nrow(df) > 0) {
        
        if (is.null(current) || current == FALSE) {
            
            df$endedDate._value <- as.POSIXct(df$endedDate._value)
            
            df$endedDate._datatype <- "POSIXct"
            
        }
        
        df$startedDate._value <- as.POSIXct(df$startedDate._value)
        
        df$startedDate._datatype <- "POSIXct"
        
        df <- hansard_tidy(df, tidy_style)
        
    }
    
    df
    
}
# mp_question multi function ----------------------------------------------

mp_question_multi <- function(mp_id, question_type, start_date,
                              end_date, extra_args,  verbose) {

    mp_id_list <- as.list(mp_id)

    dat <- vector("list", length(mp_id_list))

    seq_list <- seq(from = 1, to = length(mp_id_list), by = 1)

    for (i in seq_along(seq_list)) {

        dat[[i]] <- hansard::mp_questions(mp_id = mp_id_list[[i]],
                                          question_type = question_type,
                                          end_date = end_date,
                                          start_date = start_date,
                                          extra_args = extra_args,
                                          verbose = verbose,
                                          tidy = FALSE,
                                          tidy_style = "snake_case")

    }

    dat <- dat[sapply(dat, function(d) is.null(d) == FALSE)]

    df <- dplyr::bind_rows(dat)

    names(df)[names(df) == "_about"] <- "about"

    df

}

## MP question tidying

mp_question_tidy <- function(df, tidy_style) {

    if (nrow(df) > 0) {

        df$dateTabled._value <- as.POSIXct(df$dateTabled._value)

        df$AnswerDate._value <- as.POSIXct(df$AnswerDate._value)

        df$AnswerDate._datatype <- "POSIXct"

        df$dateTabled._datatype <- "POSIXct"

        df$tablingMemberPrinted <- unlist(df$tablingMemberPrinted)

        df$AnsweringBody <- unlist(df$AnsweringBody)

        df$tablingMember._about <- stringi::stri_replace_all_fixed(
          df$tablingMember._about,
          "http://data.parliament.uk/members/", "",
          vectorize_all = FALSE)

    }

    df <- hansard_tidy(df, tidy_style)

    df

}
### tidy function for epetition_tibble

epetition_tibble_tidy <- function(df, tidy_style) {

    if (nrow(df) > 0) {

        df$created._value <- stringi::stri_replace_all_fixed(
          df$created._value, "T", " ", vectorize_all = FALSE
          )

        df$created._value <- lubridate::parse_date_time(
          df$created._value, "Y-m-d H:M:S"
          )

        df$created._datatype <- "POSIXct"

        df$status <- as.factor(df$status)

    }

    df <- hansard_tidy(df, tidy_style)

    df

}
# publication logs tidying ------------------------------------------------

pub_tidy <- function(df, tidy_style) {
    
    if (nrow(df) > 0) {
        
        df$publicationDate._value <- as.POSIXct(df$publicationDate._value)
        
        df$publicationDate._datatype <- "POSIXct"
        
    }
    
    df <- hansard_tidy(df, tidy_style)
    
    df
    
}
## tidying sessions queries
sessions_tidy <- function(df, days, tidy_style){

  df$`_about` <- gsub("http://data.parliament.uk/resources/", "", df$`_about`)

            if (days == FALSE) {

                df$endDate._value <- as.POSIXct(df$endDate._value)

                df$startDate._value <- as.POSIXct(df$startDate._value)

                df$endDate._datatype <- "POSIXct"

                df$startDate._datatype <- "POSIXct"

            } else {

                df$date._value <- as.POSIXct(df$date._value)

                df$date._datatype <- "POSIXct"
            }

            df <- hansard_tidy(df, tidy_style)

}
# elections tidying -------------------------------------------------------

elections_tidy <- function(df, tidy_style) {

    if (nrow(df) > 0) {

        df$date._value <- as.POSIXct(df$date._value)

        df$date._datatype <- "POSIXct"

    }

    df <- hansard_tidy(df, tidy_style)

    df

}


## election_candidates tidy function
## -------------------------------------------------------


elect_can_tidy <- function(df, tidy_style) {

    if (nrow(df) > 0) {

        df$election._about <- stringi::stri_replace_all_fixed(
          df$election._about, "http://data.parliament.uk/resources/", "",
          vectorize_all = FALSE
          )

        df$constituency._about <- stringi::stri_replace_all_fixed(
          df$constituency._about, "http://data.parliament.uk/resources/", "",
          vectorize_all = FALSE
          )

    }

    df <- hansard_tidy(df, tidy_style)

    df

}
url_util <- "http://lda.data.parliament.uk/"
# calling message from .onLoad gives a NOTE on R CMD CHECK, so we circumvent that here.
mymsg <- message

.onLoad <- function(libname, pkgname){

  nthread = parallel::detectCores()

  if ( is.na(nthread) || !is.numeric(nthread) ){
    nthread <- 1L
    mymsg("Could not detect number of cores, defaulting to 1.")
  }

  omp_thread_limit = as.numeric(Sys.getenv("OMP_THREAD_LIMIT"))
  if ( is.na(omp_thread_limit) ) omp_thread_limit <- nthread
  
  nthread = min(omp_thread_limit,nthread)
  if (nthread >= 4) nthread <- nthread - 1
 
  options(hashr_num_thread=nthread)
}
max_level_length <- function(x) {
  if (!is.factor(x))
    return(0L)

  max(0L, nchar(levels(x)), na.rm = TRUE)
}
# taken from car::utility-functions.R; should be imported into heplots
# but not sure how to do this
# [perhaps need importFrom(car, car:::df.terms, car:::df.terms.default, car:::is.aliased) in NAMESPACE?]

df.terms <- function(model, term, ...){
	UseMethod("df.terms")
}

df.terms.default <- function(model, term, ...){
	if (is.aliased(model)) stop("Model has aliased term(s); df ambiguous.")
	if (!missing(term) && 1 == length(term)){
		assign <- attr(model.matrix(model), "assign")
		which.term <- which(term == labels(terms(model)))
		if (0 == length(which.term)) stop(paste(term, "is not in the model."))
		sum(assign == which.term)
	}
	else {
		terms <- if (missing(term)) labels(terms(model)) else term
		result <- numeric(0)
		for (term in terms) result <- c(result, Recall(model, term))
		names(result) <- terms
		result
	}
}

is.aliased <- function(model){
	!is.null(alias(model)$Complete)
}
# list to array
list_to_array <- function(L){
  if (is.matrix(L[[1]]) == T){
      array(unlist(L), dim = c(nrow(L[[1]]), ncol(L[[1]]), length(L)))
  } else if (is.vector(L[[1]]) == T){
      array(unlist(L), dim = c(1, length(L[[1]]), length(L)))
  } else{
      stop("List must contain matrices or vectors")
  }
}

# Return vector of absorbing states
absorbing <- function(tmat){
  which(apply(tmat, 1, function(x) all(is.na(x))))
}
# Just for use in examples in hexView help files 
hexViewFile <- function(filename) {
  system.file("files", package="hexView", filename)
}
update_css <- function(html_file, tags) {
  
  location_css <- max(grep("</style>", html_file, ignore.case = TRUE))
  
  # # split file
  html_preamble <- html_file[1:(location_css - 1)]
  html_main <- html_file[location_css:length(html_file)]
  
  ## adding custom CSS
  updated_html <- c(html_preamble, tags, html_main)
  updated_html
}
# because utils:::SweaveParseOptions is now forbidden on CRAN
SweaveParseOptions <- function (text, defaults = list(), check = NULL){
    x <- sub("^[[:space:]]*(.*)", "\\1", text)
    x <- sub("(.*[^[:space:]])[[:space:]]*$", "\\1", x)
    x <- unlist(strsplit(x, "[[:space:]]*,[[:space:]]*"))
    x <- strsplit(x, "[[:space:]]*=[[:space:]]*")
    if (length(x)) {
        if (length(x[[1L]]) == 1L)
            x[[1L]] <- c("label", x[[1L]])
    }
    else return(defaults)
    if (any(sapply(x, length) != 2L))
        stop(gettextf("parse error or empty option in\n%s", text),
            domain = NA)
    options <- defaults
    for (k in seq_along(x)) options[[x[[k]][1L]]] <- x[[k]][2L]
    if (!is.null(options[["label"]]) && !is.null(options[["engine"]]))
        options[["label"]] <- sub(paste0("\\.", options[["engine"]],
            "$"), "", options[["label"]])
    if (!is.null(check))
        check(options)
    else options
}
# generate spaces of width n
spaces = function(n = 1, char = ' ') {
  if (n <= 0) return('')
  if (n == 1) return(char)
  paste(rep(char, n), collapse = '')
}

# group source lines into complete expressions (using a brutal-force method)
group_src = function(code) {
  if ((n <- length(code)) < 1) return(list(code))
  i = i1 = i2 = 1
  x = list()
  while (i2 <= n) {
    piece = code[i1:i2]
    if (try_parse(piece)) {
      x[[i]] = piece; i = i + 1
      i1 = i2 + 1 # start from the next line
    }
    i2 = i2 + 1
  }
  if (i1 <= n) parse(text = piece)  # must be an error there
  x
}

# whether a code expression can be parsed
try_parse = function(code, silent = TRUE) {
  !inherits(
    try(parse(text = code, keep.source = FALSE), silent = silent), 'try-error'
  )
}

# TODO: eventually remove the hack for R <= 3.2.2
parse_source = if (getRversion() > '3.2.2') function(lines) {
  parse(text = lines, keep.source = TRUE)
} else function(lines) {
  # adapted from evaluate
  src = srcfilecopy('<text>', lines = '')
  if (length(grep('\n', lines))) lines = unlist(strsplit(
    sub('$', '\n', as.character(lines)), '\n'
  ))
  src$lines = lines
  parse(text = lines, srcfile = src)
}

# borrowed from knitr

# escape backslashes and {} for the alltt package
escape_latex = function(x) {
  x = gsub('\\\\', '\\\\textbackslash', x)
  x = gsub('([{}])', '\\\\\\1', x)
  gsub('\\\\textbackslash', '\\\\textbackslash{}', x)
}

# escape special HTML chars
escape_html = function(x) {
  x = gsub('&', '&amp;', x)
  x = gsub('<', '&lt;', x)
  x = gsub('>', '&gt;', x)
  x = gsub('"', '&quot;', x)
  x
}
`logchoose` <-
function(n,D,last=FALSE) {
    tmp <- c(0,cumsum(log((n+1-(1:D))/(1:D))))
    if(last) tmp <- tmp[length(tmp)]
    return(tmp)
}
            
calcNL<-function(y,BL,right) {
	n<-length(y)
	bn<-length(BL)
	NL<-rep(0,bn)
	if (right) {
		k<-sum(y<=BL[1])
		NL[1]<-k
		ind<-2
		while (k<n) {
			k<-k+1
			rbd<-BL[ind]
			while (y[k]>rbd) {
				NL[ind]<-k-1
				ind<-ind+1
				rbd<-BL[ind]
				}
			NL[ind]<-k
		}
	}
	else {
		k<-sum(y<BL[1])
		NL[1]<-k
		ind<-2
		while (k<n) {
			k<-k+1
			rbd<-BL[ind]
			while (y[k]>=rbd) {
				NL[ind]<-k-1
				ind<-ind+1
				rbd<-BL[ind]
				}
			NL[ind]<-k
		}
	}
	if (ind<bn) NL[ind:bn]<-n
	NL
}
#' setNames for arrays...
#'
#' @param array.object Array
#' @param list.of.dimension.names List of character vectors with which to name each dimension of the array
#' @return Named array
#' @examples
#' setDimNames(matrix(1:4,2,2), list(c("Cat", "Dog"), c("Name", "Weight")))
#' @export
setDimNames <- function(array.object, list.of.dimension.names) {
	dimnames(array.object) <- list.of.dimension.names
	array.object
}

#' Capitalise words in character vector
#'
#' @param x Character vector 
#' @return Character vector
#' @examples
#' simpleCap(c("a simple test", "Another-test"))
#' @export
simpleCap <- function(x) {
	s <- strsplit(x, " ")
	sapply(
		s,
		function(x) paste(
			toupper(substring(x, 1,1)), 
			substring(x, 2),
			sep="", collapse=" "
		)
	)
}
is_empty <- function(x) length(x) == 0

all_empty <- function(x) {
  all(sapply(x, length) == 0)
  }

equal_length <- function(x) {
  x.length <- sapply(x, length)
  length(unique(x.length)) == 1
}

rm_str_white <- function(el) gsub("^\\s+|\\s+$", "", el)

check_correct <- function(nodeset){
  names <- sapply(1:length(nodeset), function(index) XML::xmlName(nodeset[[index]]))
  if(!all(names == "tr")) stop("You must pass header/body information that identifies row elements (tr)", call. = FALSE)
}

#' Wrapper around if stop logic
#' @noRd
ifstop <- function(cond, mess, ...){

  cond <- eval(quote(cond))

  if(isTRUE(cond)){
    stop(mess, call. = F)
  }
}

#' Is str a URL?
#' @noRd
is_url <- function(str){
  grepl("^(http:|https:|www.)", str)
}


#' Assert a specific tag in an XML node
#'
#' @param table.Node the table node
#' @param tag a character string for the tag name to be matched
#' @return logical value indicating whether tag is present in table code
#' @noRd

has_tag <- function(table.Node, tag) {
  x <- XML::xpathSApply(table.Node, tag)
  if(length(x) > 0){TRUE} else{FALSE}
}
"%||%" <- function(a, b) {
  if (length(a) > 0) a else b
}

timestamp <- function(x = Sys.time()) {
  format(x, "%Y-%m-%dT%H:%M:%SZ", tz = "UTC")
}

sort_names <- function(x) x[order(names(x))]

nonce <- function(length = 10) {
  paste(sample(c(letters, LETTERS, 0:9), length, replace = TRUE),
    collapse = "")
}

has_env_var <- function(x) !identical(Sys.getenv(x), "")

named <- function(x) x[has_name(x)]
unnamed <- function(x) x[!has_name(x)]

has_name <- function(x) {
  nms <- names(x)
  if (is.null(nms))
    return(rep(FALSE, length(x)))

  !is.na(nms) & nms != ""
}

travis_encrypt <- function(vars) {
  values <- Sys.getenv(vars)
  cat(paste0("travis encrypt ", paste0(vars, "=", values, collapse = " ")))
}

is_installed <- function(pkg) {
  system.file(package = pkg) != ""
}

need_package <- function(pkg) {
  if (is_installed(pkg)) return(invisible())

  stop("Please install ", pkg, " package", call. = FALSE)
}

last <- function(x) {
  if (length(x) < 1) return(x)
  x[[length(x)]]
}

compact <- function(x) {
  empty <- vapply(x, is_empty, logical(1))
  x[!empty]
}

is_empty <- function(x) length(x) == 0

keep_last <- function(...) {
  x <- c(...)
  x[!duplicated(names(x), fromLast = TRUE)]
}

named_vector <- function(title, x) {
  if (length(x) == 0) return()

  cat(title, ":\n", sep = "")
  bullets <- paste0("* ", names(x), ": ", as.character(x))
  cat(bullets, sep = "\n")
}

keep_last <- function(...) {
  x <- c(...)
  x[!duplicated(names(x), fromLast = TRUE)]
}

find_cert_bundle <- function() {
  if (.Platform$OS.type != "windows")
    return()

  env <- Sys.getenv("CURL_CA_BUNDLE")
  if (!identical(env, ""))
    return(env)

  bundled <- file.path(R.home("etc"), "curl-ca-bundle.crt")
  if (file.exists(bundled))
    return(bundled)

  # Fall back to certificate bundle in openssl
  system.file("cacert.pem", package = "openssl")
}

isFALSE <- function(x) identical(x, FALSE)
#' Create host name address using a subdomain
#' @noRd
server_address <- function(subdomain) {
  paste0(subdomain, ".hydroscope.gr")
}

#' Ping a remote server to see if its alive
#' @noRd
server_alive <- function(subdomain) {
  if (all(is.na(pingr::ping_port(server_address(subdomain),
                                 port = 80L,
                                 count = 3)))) {
    err_msg <- paste("The server for that data source is probably down,",
                     "get more info at hydroscope@hydroscope.gr or try",
                     "again later.")
    stop(err_msg, call. = FALSE)
  }
}

#' create coords from points
#' @noRd
create_coords <- function(str) {

  str_split <- stringr::str_split(string = str, pattern = "[\\(  \\)]",
                                  simplify = TRUE)
  if (NCOL(str_split) == 5) {
    tibble::tibble(long = as.numeric(str_split[, 3]),
                   lat = as.numeric(str_split[, 4]))
  } else {
    tibble::tibble(long = rep(NA, NROW(str)),
                   lat = rep(NA, NROW(str)))
  }
}
# Copyright (C) 2014 - 2018  Jack O. Wasey
#
# This file is part of icd.
#
# icd is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# icd is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with icd. If not, see <http:#www.gnu.org/licenses/>.

icd10cm_get_xml_file <- function(...) {
  unzip_to_data_raw(
    url = "http://www.cdc.gov/nchs/data/icd/icd10cm/2016/ICD10CM_FY2016_Full_XML.ZIP",
    file_name = "Tabular.xml", ...)
}

icd10cm_get_flat_file <- function(...) {
  unzip_to_data_raw(
    url = "http://www.cdc.gov/nchs/data/icd/icd10cm/2016/ICD10CM_FY2016_code_descriptions.zip",
    file_name = "icd10cm_order_2016.txt", ...)
}
enlist_img <- function(img) {
  checkmate::assert_numeric(img)
  checkmate::assert_array(img, d = 4)
  purrr::map(seq_len(dim(img)[4]), ~ img[, , , .])
}

dims <- function(lst) {
  checkmate::assert_list(lst)
  dims_cpp(lst)
}

enlist_cols <- function(mat) {
  checkmate::assert_matrix(mat)
  purrr::map(seq_len(ncol(mat)), ~ mat[, .])
}
enlist_rows <- function(mat) {
  checkmate::assert_matrix(mat)
  purrr::map(seq_len(nrow(mat)), ~ mat[., ])
}
enlist_planes <- function(arr) {
  checkmate::assert_array(arr, d = 3)
  purrr::map(seq_len(dim(arr)[3]), ~ arr[, , .])
}

extract_desired_plane <- function(arr) {
  checkmate::assert_array(arr, min.d = 2, max.d = 3)
  d <- dim(arr)
  if (length(d) == 3) {
    nonzero_planes <- !purrr::map_lgl(seq_len(d[3]),
                                      ~ filesstrings::all_equal(arr[, , .], 0))
    if (sum(nonzero_planes) == 0) {
      arr <- arr[, , 1]
    } else if (sum(nonzero_planes) == 1) {
      arr <- arr[, , nonzero_planes]
    } else if (filesstrings::all_equal(enlist_planes(arr))) {
      arr <- arr[, , 1]
    } else {
      stop("Cannot extract the desired plane.")
    }
  }
  arr
}
PadParameters <- function(paramA, paramB){
  num_a <- length(paramA)
  num_b <- length(paramB)
  if (num_a < num_b){
    indices <- rep_len(seq.int(num_a), length.out = num_b)
    paramA <- paramA[indices]
  }

  paramA
}

GetFirstFunction <- function(obj){
  if (!is.list(obj)) {
    warning("Object is not a list. Returning NULL.")
  }

  obj <- obj[[1]]

  if (!is.function(obj)){
    warning("Object is not a function. Returning NULL.")
    obj <- NULL
  }

  obj
}

PutFunctionInList <- function(obj){
  if (!is.function(obj)){
    warning("Object is not a function. Returning NULL.")
    obj <- NULL
  }

  obj <- list(obj)

  obj
}
check_return <- function(errors, output, stage, check_name = check_name){
  date <- format.Date(Sys.Date(), "%Y%m%d")
  if(output == FALSE){
    return(errors)
  } else if (output == TRUE){
    if(is.null(stage)){
      openxlsx::write.xlsx(errors, paste0(check_name, "_errors_",
                                          date, ".xlsx"))
    } else {
      openxlsx::write.xlsx(errors, paste0(stage, "_", check_name, "_errors_",
                                          date, ".xlsx"))
    }
  }
}
# ---------------------------------------------------------------------
# Internal supporting functions
# ---------------------------------------------------------------------
# General real/complex crossprod
cross <- function(x, y)
{
  if (missing(y))
  {
    if (is.complex(x)) return(abs(Conj(t(x)) %*% x))
    return(crossprod(x))
  }
  if (!is.complex(x) && !is.complex(y)) return(crossprod(x, y))
  Conj(t(x)) %*% y
}

# Euclidean norm
norm2 <- function(x)
{
  drop(sqrt(cross(x)))
}

# Orthogonalize vectors Y against vectors X.
orthog <- function(Y, X)
{
  dx2 <- dim(X)[2]
  if (is.null(dx2)) dx2 <- 1
  dy2 <- dim(Y)[2]
  if (is.null(dy2)) dy2 <- 1
  if (dx2 < dy2) doty <- cross(X, Y)
  else doty <- Conj(t(cross(Y, X)))
  Y - X %*% doty
}

# Convergence tests
# Input parameters
# Bsz            Number of rows of the bidiagonal matrix B
# tol
# k_org
# Bsvd           svd list of small matrix B
# residuals
# k
# Smax
# lastsv, svtol, work, S
#
# Output parameter list
# converged      TRUE/FALSE
# k              Number of singular vectors returned
convtests <- function(Bsz, tol, k_org, Bsvd, residuals, k, Smax, lastsv, svtol, maxritz, work, S)
{
# Converged singular triplets
  subspace_converged <- residuals[1:k_org] < tol * Smax
# Converged fixed point triplets
  if (is.null(lastsv)) lastsv <- 0 * Bsvd$d
  delta_converged <- (abs(Bsvd$d[1:k_org] - lastsv[1:k_org]) / Bsvd$d[1:k_org])  < svtol
  len_res <- sum(subspace_converged & delta_converged) # both
  if (is.na(len_res)) len_res <- 0
  if (len_res >= k_org) return(list(converged=TRUE, k=k))
  if (S == 0) return(list(converged=TRUE, k=k))
# Not converged yet...
# Adjust k to include more vectors as the number of vectors converge, but not
# too many (maxritz):
  augment <- min(sum(subspace_converged), maxritz)
  k <- min(max(k, k_org + augment), work - 1)
  list(converged=FALSE, k=k)
}

message_once <- function(..., flag)
{
  if (flag$flag) return()
  flag$flag <- TRUE
  message(...)
}
`rmultinomial` <-
function(x, n=100, prob=rep(1,length(x))/length(x)) {
 x <- colSums(x*(rmultinom(n=n, size = 1, prob=prob)== 1))
 return(x)
 }


`propCorrect` <-
function(theta, S, C, D, s, b, c, d) {
 propCorrect <- 0
 nItems      <- length(b)
 for (i in (1:nItems)) {
  propCorrect <- propCorrect + pm4pl(theta=theta,S=S,C=C,D=D,s=s[i],b=b[i],c=c[i],d=d[i])
  }
 return(propCorrect/nItems)
 }
# This code was contributed by Hadley Wickham

end_iteration <- function() stop('StopIteration', call.=FALSE)

iteration_has_ended <- function(e) {
  identical(conditionMessage(e), 'StopIteration')
}

new_iterator <- function(nextElem, ...) {
  structure(list(nextElem=nextElem, ...), class=c('abstractiter', 'iter'))
}

is.iterator <- function(x) inherits(x, 'iter')
# Copied from tidyr/R/utils.R, to export the magrittr pipe

#' Pipe operator
#'
#' @description Exported from the magrittr package.  To learn more, run \code{?magrittr::`\%>\%`}.
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @export
#' @importFrom dplyr %>%
#' @usage lhs \%>\% rhs
#' @examples
#' mtcars %>%
#'   tabyl(carb, cyl) %>%
#'   adorn_totals()
NULL
#' Apply list input to a worker
#' 
#' @param worker a worker
#' @param input a list of characters
#' @examples 
#' cutter = worker()
#' apply_list(list("this is test", "that is not test"), cutter)
#' apply_list(list("this is test", list("that is not test","ab c")), cutter)
#' @export
apply_list = function(input, worker){
  if (!is.list(input)){
    
    if(is.character(input)){
      return(worker[input])
    }else{
      # will not do anything
      return(input)
    }
  }else{
    # input is list and we will contruct the result
    len = length(input)
    res = vector("list", len)
    for( x in 1:len ){
      res[[x]] = apply_list(input[[x]],worker)
    }
    return(res)
  }
}
#' @keywords internal
getD <- function(q, arg) {
  D <- matrix(0, q, length(arg))
  for (i in 1:q) {
    D[i, ] <- arg^(i - 1)
  }
  return(D) # calculate the Z-design matrix
}


#' @keywords internal
notNA <- function(x) {
  !(is.vector(x) & length(x) == 1 & any(is.na(x)))
}


#' @keywords internal
sep <- function(ests, logical) {
  if (logical == FALSE) {
    ests <- "No separate results requested"
  }
  ests
}
#' @export
dplyr::`%>%`


# General utilities -------------------------------------------------------
dots_remove_elements <- function(..., .elements = character(0)) {
  dots <- quos(...)

  dots[!(names(dots) %in% .elements)]
}


# Class utilities ---------------------------------------------------------
add_class <- function(x, class) {
  class(x) <- c(class, class(x))

  x
}

add_class_cond <- function(x, class) {
  if (class(x)[1] != class) {
    class(x) <- c(class, class(x))
  }

  x
}

remove_class <- function(x) {
  class(x) <- class(x)[-1]

  x
}

remove_class_cond <- function(x, class) {
  if (class(x)[1] == class) {
    class(x) <- class(x)[-1]
  }

  x
}


# Two tables utilities ----------------------------------------------------
diff_tbl <- function(.tbl1, .tbl2) {
  not_in_tbl2_idx <- which(!(colnames(.tbl1) %in% colnames(.tbl2)))

  select(.tbl1, not_in_tbl2_idx)
}

assign_tbl <- function(.tbl1, .tbl2) {
  .tbl1[, colnames(.tbl2)] <- .tbl2[, ]

  .tbl1
}
utf8 <- function(x) {
  if (is.null(x)) return(x)
  iconv(x, "", "UTF-8")
}

`%||%` <- function(l, r) if (is.null(l)) r else l

cat0 <- function(..., sep = "") {
  cat(..., sep = sep)
}

confirmation <- function(prompt, yes) {
  ans <- readline(paste0(prompt, ": "))
  if (ans != yes) stop("Aborted", call. = FALSE)
}

darwin_version <- function() {
  info <- Sys.info()
  if (info[["sysname"]] != "Darwin") stop("Not macOS")
  package_version(info[["release"]])
}
# create table header
.header <- function (x, rows) {
  ifelse(rows, y  <- append("", colnames(x)), y  <- colnames(x))
  paste(paste(y, collapse=' & '), '\\\\')
}

# add toprule and midrule to header
.printhead <- function (top, header, mid) {
  .printif(header, paste(top, header, mid, sep='\n'))
}

# sprintf if
.printif <- function(x, str, ...){ if (!is.null(x)) sprintf(str, x, ...) }

# if booktabs else - helper function
.book <- function(opt, booktabs, true, false){
  getOption(opt, ifelse(booktabs, true, false))
}

# create table body
.body <- function (x, rows, rowsep) {
  if(rows) x  <- cbind(rownames(x), x)
  sep  <- sprintf("%s\n", rowsep)
  paste(apply(x, 1, paste, collapse=' & '), '\\\\', collapse=sep)
}

# set column definitions
.coldef <- function(x, colsep){
  paste(ifelse(sapply(x, is.numeric), 'r', 'l'), collapse=colsep)
}

# paste table
.pt <- function(x){
  cat(paste(x, collapse='\n'), '\n')
}

# triple option
.op <- function (op1, op2, def) {
  getOption(op1, getOption(op2, def))
}
# util functions

guess_url <- function(url_str) {
  if(!purrr::is_scalar_character(url_str)) {
    stop("url_str must be character and the length is 1")
  }

  if(!stringr::str_detect(url_str, "^http")){
    url_str <- paste0("https://", url_str)
  }

  url <- httr::parse_url(url_str)

  url$scheme <- "https"
  url$path <- NULL

  httr::build_url(url)
}


calc_ranges <- function(first_offset = 0L,
                        max_records = 1000L,
                        records_per_request = 100L) {
  ranges <- list()

  ranges$offsets <- seq(from = first_offset,
                        to = first_offset + max_records,
                        by = records_per_request)

  ranges$limits <- rep(records_per_request, length(ranges$offsets) - 1)

  # treat a fraction
  fraction <- max_records %% records_per_request
  if(fraction == 0) {
    # remove the range of zero-length
    length(ranges$offsets) <- length(ranges$offsets) - 1
  } else {
    ranges$limits <- append(ranges$limits, fraction)
  }

  dplyr::as_data_frame(ranges)
}
# Utilities

as_param <- function(x) {
  stringr::str_c(as.character(x), collapse = ",")
}

make_sure_data_is_loaded <- function(x) {
  if (!exists(x)) {
    do.call(utils::data, list(x, package = "kokudosuuchi"))
  }
}
# These functions are (mostly) verbatim copies of functions from
# the rticles package, which is copyrighted to RStudio and licensed under
# GPL-3.

find_file <- function(template, file) {
  template <- system.file("rmarkdown",
                          "templates",
                          template,
                          file,
                          package = "komadown")
  if (template == "")
    stop("Couldn't find template file ", template, "/", file, call. = FALSE)
  template
}

find_resource <- function(template, file) {
  find_file(template, file.path("resources", file))
}

inherit_pdf_document <- function(...) {
  fmt <- bookdown::pdf_document2(...)
  fmt$inherits <- "pdf_document"
  fmt
}

pdf_document_format <- function(..., format, template, csl) {
  # base format
  fmt <- inherit_pdf_document(..., template = find_resource(format, template))

  # add csl to pandoc_args
  fmt$pandoc$args <- c(fmt$pandoc$args,
                       "--csl",
                       rmarkdown::pandoc_path_arg(find_resource(format, csl)))
  # return format
  fmt
}
## taken from "pcts"
.reportClassName <- function(object, class, trailer = "\n"){
    if(class(object) == class)
        cat('An object of class "', class, '"', trailer, sep = "")
    NULL
}
#' Import Roboto Condensed font for use in charts
#'
#' Roboto Condensed is a trademark of Google.
#'
#' @md
#' @note This will take care of ensuring PDF/PostScript usage. The location of the
#'   font directory is displayed after the base import is complete. It is highly
#'   recommended that you install them on your system the same way you would any
#'   other font you wish to use in other programs.
#' @export
#' @aliases util_import_roboto_condensed
#' @rdname util_import_roboto_condensed
#'
util_import_roboto_condensed <- function() {
  # borrowed from hrbrmstr and his great package hrbrthemes
  # https://github.com/hrbrmstr/hrbrthemes

  rc_font_dir <-
    system.file("fonts", "roboto-condensed", package = "landscapetools")

  suppressWarnings(suppressMessages(extrafont::font_import(rc_font_dir, prompt =
                                                               FALSE)))

  message(
      sprintf(
      "You will likely need to install these fonts on your system as well.\n\n
      You can find them in [%s]",
          rc_font_dir
      )
  )

}

#' @rdname RobotoCondensed
#' @md
#' @title Roboto Condensed font name R variable aliases
#' @description `font_rc` == "`Roboto Condensed`"
#' @format length 1 character vector
#' @export
font_rc <- "Roboto Condensed"

#' @rdname RobotoCondensed
#' @md
#' @note `font_rc_light` (a.k.a. "`Roboto Condensed Light`") is not available on
#'     Windows and will throw a warning if used in plots.
#' @description `font_fc_light` == "`Roboto Condensed Light`"
#' @export
font_rc_light <- "Roboto Condensed Light"
#' util_calc_boundaries
#'
#' @description Determine upper class boundaries for classification of a vector with values ranging 0-1 based upon an
#' vector of cumulative proportions.
#'
#' @param x vector of data values.
#' @param cumulative_proportions Vector of class cumulative proportions, as generated by `w2cp`.
#'
#'
#' @return Numerical vector with boundaries for matrix classification
#'
#'
#' @examples
#' x <- matrix(runif(100,0,1),10,10)
#' y <- util_w2cp(c(0.5, 0.25, 0.25)) #cumulative proportion
#' util_calc_boundaries(x,y)
#'
#' @keywords internal
#' @export


util_calc_boundaries <- function(x, cumulative_proportions) {

  # Check function arguments ----
  checkmate::assert_numeric(cumulative_proportions)

  # Get number of cells  ----
  n_cells <- length(x)

  # Use number of cells to find index of upper boundary element ----
  boundary_indexes <- as.integer( (cumulative_proportions * n_cells))

  # Get boundary values ----
  boundary_values <- sort(as.vector(x))[boundary_indexes]

  return(boundary_values)
}
#' Converts raster data into tibble
#'
#' @description Writes spatial raster values into tibble and adds coordinates.
#'
#' @details You will loose any resolution, extent or reference system.
#' The output is raw tiles.
#'
#' @param x Raster* object
#'
#' @return a tibble
#'
#' @examples
#' maptib <- util_raster2tibble(fbmmap)
#' \dontrun{
#' library(ggplot2)
#' ggplot(maptib, aes(x,y)) +
#'     coord_fixed() +
#'     geom_raster(aes(fill = z))
#' }
#' @aliases util_raster2tibble
#' @rdname util_raster2tibble
#'
#' @export
#'

util_raster2tibble <- function(x) {

  # Check function arguments ----
  checkmate::assert_class(x, "RasterLayer")

  # Create empty tibble with the same dimension as the raster ----
  grd <- tibble::as_tibble(expand.grid(x = seq(1, raster::ncol(x)),
                                       y = seq(raster::nrow(x), 1)))

  # Fill with raster values ----
  grd <- dplyr::bind_cols(grd, z = raster::values(x))

  return(grd)
}
#' util_w2cp
#'
#' Convert a list of category  weighting  into a 1D array of cumulative proportions.
#'
#' @param  weighting  A list of numeric values
#'
#' @return Rectangular matrix with values ranging from 0-1
#'
#'
#' @examples
#' util_w2cp(c(0.2, 0.4, 0.6, 0.9))
#'
#'
#' @keywords internal
#' @export

util_w2cp <- function(weighting) {
  w <- weighting
  proportions <- w / sum(w)
  cumulative_proportions <- cumsum(proportions)
  return(cumulative_proportions)
}
#' Pipe operator
#'
#' See \code{magrittr::\link[magrittr]{\%>\%}} for details.
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @export
#' @importFrom magrittr %>%
#' @usage lhs \%>\% rhs
NULL
#' Converts tibble data into a raster
#'
#' @description Writes spatial tibble values into a raster.
#'
#' @details Writes tiles with coordinates from a tibble into a raster.
#' Resolution is set to 1 and the extent will be c(0, max(x), 0, max(y)).
#'
#' You can directly convert back the result from 'util_raster2tibble()' without
#' problems. If you have altered the coordinates or otherwise played with the
#' data, be careful while using this function.
#'
#'
#' @param x a tibble
#'
#' @return Raster* object
#'
#' @examples
#' maptib <- util_raster2tibble(rndmap)
#' mapras <- util_tibble2raster(maptib)
#' all.equal(rndmap, mapras)
#'
#' @aliases util_tibble2raster
#' @rdname util_tibble2raster
#'
#' @export
#'

util_tibble2raster <- function(x) {

  # Create raster with values from tibble ----
  r <- raster::raster(matrix(x$z, max(x$y), max(x$x), byrow = TRUE))
  raster::extent(r) <- c(0, max(x$x), 0, max(x$y))

  return(r)
}
#' Binarize continuous raster values
#'
#' @description Classify continuous raster values into binary map cells based upon given
#' break(`s`).
#'
#' @details Breaks are considered to be habitat percentages (`p`). If more than
#' one percentage is given multiple layers are written in the same brick.
#'
#' @param x Raster* object
#'
#' @param breaks Vector with one or more break percentages
#'
#' @return RasterLayer / RasterBrick
#'
#' @examples
#' breaks <- c(0.3, 0.5)
#' (binary_maps <- util_binarize(fbmmap, breaks))
#'
#' @aliases util_binarize
#' @rdname util_binarize
#'
#' @export
#'

util_binarize <- function(x, breaks) {

  # Check function arguments ----
  checkmate::assert_class(x, "RasterLayer")
  checkmate::assert_atomic_vector(breaks)

  if (length(breaks) > 1) {
    map.stack <- raster::stack()
    for (i in seq_along(breaks)) {
      map.stack <- raster::stack(
        map.stack,
        util_classify(
          x,
          c(1 - breaks[i], breaks[i]),
          c("Matrix", "Habitat")
        )
      )
    }
    names(map.stack) <- paste("p", breaks)
    r <- raster::brick(map.stack)
  } else {
    r <- util_classify(
      x,
      c(1 - breaks, breaks),
      c("Matrix", "Habitat")
    )
  }

  return(r)
}
#' util_merge
#'
#' Merge a primary raster with other rasters weighted by scaling factors.
#'
#' @param primary_nlm Primary \code{Raster* object}
#' @param secondary_nlm  A list or stack of \code{Raster* object}s that are merged with the primary \code{Raster* object}
#' @param scalingfactor Weight for the secondary \code{Raster* objects}
#' @param rescale If \code{TRUE} (default), the values are rescaled between 0-1.
#'
#' @return Rectangular matrix with values ranging from 0-1
#'
#' @examples
#' (util_merge(grdmap, rndmap))
#'
#' @export
#'


util_merge <- function(primary_nlm,
                       secondary_nlm,
                       scalingfactor = 1,
                       rescale = TRUE) {

  # Check function arguments ----
  checkmate::assert_number(scalingfactor)
  checkmate::assert_logical(rescale)

  if (class(secondary_nlm) != "RasterStack") {
    secondary_nlm <- raster::stack(secondary_nlm)
  }

  if (length(secondary_nlm@layers) > 1) {
    nlm_merge <- primary_nlm + (sum(secondary_nlm) * scalingfactor)
  } else {
    nlm_merge <- primary_nlm + (secondary_nlm * scalingfactor)
  }

  # Rescale values to 0-1 ----
  if (rescale == TRUE) {
    nlm_merge <- util_rescale(nlm_merge)
  }

  return(nlm_merge)
}
#' util_rescale
#'
#' Linearly rescale element values in a raster to a range between 0 and 1.
#'
#' @param x Raster* object
#'
#' @return Raster* object with values ranging from 0-1
#'
#' @details Rasters generated by \code{nlm_} functions are scaled between 0 and 1 as default, this option can be set to \code{FALSE} if needed.
#'
#' @examples
#' unscmap <- util_merge(grdmap, rndmap, rescale = FALSE)
#' util_rescale(unscmap)
#'
#'
#' @aliases util_rescale
#' @rdname util_rescale
#'
#' @export
#'

util_rescale <- function(x) {
  rescaled_NLM <-
    (x - raster::cellStats(x, "min")) /
      (raster::cellStats(x, "max") - raster::cellStats(x, "min"))

  return(rescaled_NLM)
}
#' util_classify
#'
#' @description Classify a raster into proportions based upon a vector of class
#' weightings.
#'
#' @details  The number of elements in the weighting vector determines the number of classes
#' in the resulting matrix. The classes start with the value 1.
#' If non-numerical levels are required, the user can specify a vector to turn the
#' numerical factors into other data types, for example into character strings (i.e. class labels).
#' If the numerical vector of weightings does not sum up to 1, the sum of the
#' weightings is divided by the number of elements in the weightings vector and this is then used for the classification.
#'
#' @param x 2D matrix
#' @param weighting Vector of numeric values.
#' @param level_names Vector of names for the factor levels.
#'
#' @return RasterLayer
#'
#' @examples
#' weight <- c(0.5, 0.25, 0.25)
#' util_classify(fbmmap, weight,
#'               level_names = c("Land Use 1", "Land Use 2", "Land Use 3"))
#'
#'
#' @aliases util_classify
#' @rdname util_classify
#'
#' @export
#'

util_classify <- function(x, weighting, level_names = NULL) {

  # Check function arguments ----
  checkmate::assert_class(x, "RasterLayer")
  checkmate::assert_numeric(weighting)

  # Calculate cum. proportions and boundary values ----
  cumulative_proportions <- util_w2cp(weighting)
  boundary_values <- util_calc_boundaries(raster::values(x),
                                          cumulative_proportions)

  # Classify the matrix based on the boundary values ----
  raster::values(x) <- findInterval(raster::values(x),
                                    boundary_values,
                                    rightmost.closed = TRUE)

  # If level_names are not NULL, add them as specified ----
  if (!is.null(level_names)) {

    # Turn raster values into factors ----
    x <- raster::as.factor(x)

    c_r_levels <- raster::levels(x)[[1]]
    c_r_levels[["Categories"]] <- level_names
    levels(x) <- c_r_levels
  }

  return(x)
}
`%||%` <- function(a,b) if(is.null(a)) b else a
# not exported, just internal helper to make sure columns exist
col_check <- function(col, data, fun = sys.call(-1)) {
  if (!is.null(col) && !col %in% names(data)) 
    stop("column not in dataset: '", col, "'. Plese check your call to ", fun, call. = FALSE)
}
"%||%" <- function(x, y) if(is.null(x)) y else x

is_atomic <- function(x) {
  typeof(x) %in% c("logical", "integer", "double", "complex", "character", "raw")
}

is_vector <- function(x) {
  is_atomic(x) || is.list(x)
}

has_names <- function(x) {
  nms <- names(x)
  if (is.null(nms)) {
    rep(FALSE, length(x))
  } else {
    !(is.na(nms) | nms == "")
  }
}

substitute_ <- function(x, env) {
  if (identical(env, globalenv())) {
    env <- as.list(env)
  }

  call <- substitute(substitute(x, env), list(x = x))
  eval(call)
}

#' Generate a missing argument.
#'
#' @export
#' @examples
#' f_interp(~f(x = uq(missing_arg())))
#' f_interp(~f(x = uq(NULL)))
missing_arg <- function() {
  quote(expr = )
}
# avoid CRAN notes when using magrittr
utils::globalVariables(".")

#' Regex pattern to validate SQL identifier names
#'
#' @description
#' Returns a regular expression to validate unquoted SQL identifiers.
#' @details
#' Valid SQL identifiers must begin with an alphabetic character followed by
#' alphanumeric characters or underscores "\code{_}".
#' @note
#' The current implementation doesn't allow any other special characters in
#' SQL identfiers or quoted SQL identifiers for safety reasons.
#' In future releases, valid SQL identifiers might be defined depending
#' on the target database system.
#' @return Character string with regular expression.
#' @references
#' ORACLE Database SQL Language Reference.
#' @author Uwe Block
#' @examples
#' lazysql::valid_identifier_regex()
#' @export
#'
valid_identifier_regex <- function() {
  return("^[[:alpha:]][_[:alnum:]]*$")
}
# .onAttach <- function(libname, pkgname ){
#   library(leaflet)
#   library(sp)
# }
globalVariables(c("mapNames", ".triList"))

## Encoding solution
encodingSolution = function(str){
  iconv(str, "UTF-8", "UTF-8")
}

## read function
readGeoLocal = function(city){
  query = toLabel(city)
  if(!any(mapNames$label==query)){
    stop(paste0("\n",
                city,
                ": this mapType cannot found!\n",
                "Please check the mapType name or use icnov to convert encoding.\n",
                "Valid mapTypes: regionNames()\n",
                "Encoding convert: ?iconv"))
  }
  file = paste0("geojson/",
                mapNames$files[mapNames$label==query]
  )
  filePath = system.file(file,package = "leafletCN")

  # output = rgdal::readOGR(filePath, "OGRGeoJSON")
  output = read.geoShape(filePath)
  if(.Platform$OS.type == "windows"){
    output$name = encodingSolution(output$name)
  }

  return(output)
}

## .triList
## Use first two words to match
toLabel = function(city){
  labels = sapply(city, function(x){
    if(tolower(substr(x,1,1)) %in% letters){
      return(tolower(x))
    } else if(grepl(.triList[[1]], x)|
       grepl(.triList[[2]], x)|
       grepl(.triList[[3]], x)|
       grepl(.triList[[4]], x)
    ){
      return(substr(x, 1, 3))
    }else{
      return(substr(x, 1, 2))
    }
  })
  return(labels)
}

## Fork from echarts
evalFormula = function(x, data) {
  # x = ~value; data = mapData
  if (!inherits(x, 'formula')) return(x)
  if (length(x) != 2) stop('The formula must be one-sided: ', deparse(x))
  x_formula = terms.formula(x)
  if (length(attr(x_formula, "term.labels")) == 1){
    eval(x[[2]], data, environment(x))
  }else{
    as.data.frame(sapply(attr(x_formula, "term.labels"),function(tmpTerm){
      return(eval(as.name(tmpTerm), data, environment(x)))
    }),stringsAsFactors=F)
  }
}
"%||%" <- function(x, y) if (is.null(x)) y else x

is_windows <- function() {
  .Platform$OS.type == 'windows'
}

is_macos <- function() {
  Sys.info()[["sysname"]] == "Darwin"
}


is_localhost <- function(location) {
  if (location$hostname %in% c("localhost", "127.0.0.1"))
    TRUE
  else if (nzchar(Sys.getenv("RSTUDIO")) && grepl("/p/\\d+/", location$pathname))
    TRUE
  else
    FALSE
}
# This files provides general urilires for the package


#' @import stringr
NULL


# collapse
collapse <- function(x,collapse='') paste(x,collapse = collapse)

# qw 
qw <- function (...) as.character(match.call())[-1]




#   `%|%` =
#   function(left, right){
#     subsright = substitute(right)
#     lazyright = lazy(right)
#     if(".." %in% all.vars(subsright))
#       lazy_eval(lazyright, list(.. = left))
#     else {
#       if(is.call(subsright)) {
#         lsr = as.list(subsright)
#         do.call(
#           as.character(
#             lsr[1]),
#           c(substitute(left),
#             lsr[-1]),
#           envir = lazyright$env)}
#       else{
#         if(is.function(right))
#           right(left)
#         else
#           stop("Don't know how to pipe THAT!")}}}
#' get_word_sentiment
#'
#' Lookup word or term in datasets available on lexiconPT
#'
#' @param word character.
#'
#' @return A list of all datasets available on lexiconPT filtered by the inputed word.
#' @examples{
#'   get_word_sentiment("cantar")
#'   \dontshow{
#'   get_word_sentiment("facil")
#'   }
#'  }
#' @export
get_word_sentiment <- function(word){

  notAvailable <- function(df) {
    if(nrow(df) == 0) return("Word not present in dataset") else df
  }
  x1 <- notAvailable(oplexicon_v2.1[oplexicon_v2.1[["term"]] == word, ])
  x2 <- notAvailable(oplexicon_v3.0[oplexicon_v3.0[["term"]] == word, ])
  x3 <- notAvailable(sentiLex_lem_PT02[sentiLex_lem_PT02[["term"]] == word, ])


  list(
    oplexicon_v2.1 = x1,
    oplexicon_v3.0 = x2,
    sentilex = x3
  )
}
# ===============================================================================
#
# PROGRAMMERS:
#
# jean-romain.roussel.1@ulaval.ca  -  https://github.com/Jean-Romain/lidR
#
# COPYRIGHT:
#
# Copyright 2017 Jean-Romain Roussel
#
# This file is part of lidR R package.
#
# lidR is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>
#
# ===============================================================================

get_epsg = function(header)
{
  epsg = NULL
  for (tag in header@VLR$GeoKeyDirectoryTag$tag)
  {
    if (tag$key == 3072)
       epsg = tag$`value offset`
  }

  return(epsg)
}


.epsg2proj = function(code)
{
  if (is.null(code))
    return(sp::CRS())

  crs = tryCatch(sp::CRS(paste0("+init=epsg:", code)), error = function (e) sp::CRS())

  return(crs)
}

.epsg2wkt = function(code)
{
  if (is.null(code))
    return(NA_character_)

  url = paste0("http://spatialreference.org/ref/epsg/", code, "/ogcwkt/")

  proj = tryCatch(readLines(url, warn = F), error = function (e) NA_character_)

  return(proj)
}

epsg2proj = memoise::memoise(.epsg2proj)
epsg2wkt = memoise::memoise(.epsg2wkt)
# ===============================================================================
#
# PROGRAMMERS:
#
# jean-romain.roussel.1@ulaval.ca  -  https://github.com/Jean-Romain/lidR
#
# COPYRIGHT:
#
# Copyright 2016 Jean-Romain Roussel
#
# This file is part of lidR R package.
#
# lidR is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>
#
# ===============================================================================

convex_hull = function(x, y)
{
  i <- grDevices::chull(x,y)
  i <- c(i, i[1])
  coords <- list(x = x[i], y = y[i])
  data.table::setDF(coords)
  return(coords)
}

polygon_area = function(x, y)
{
  if (length(x) == 0 && length(y) == 0) return(0)
  if (!is.numeric(x) || !is.numeric(y) ) stop("Arguments 'x' and 'y' must be real")
  if (length(x) != length(y)) stop("Argument 'x' and 'y' must be of same size")

	area = 0;
	j = length(x)

	for (i in 1:j)
	{
		area = area + (x[j]+x[i])*(y[j]-y[i]);
		j = i;
	}

	area  = abs(area*0.5)

	return(area)
}

area = function(x, y)
{
  hull = convex_hull(x, y)
  area = polygon_area(hull$x, hull$y)
  area = round(area,1)
  return(area)
}
# convert string vectors to single quote-marked
# string separated by comma
quote_str = function(x) {
  paste0("\'", paste(x, collapse = "','"), "\'")
}

# get directory of the file
file_dir = function(x) {
  dirname(normalizePath(x))
}

# get file name with extension
file_name = function(x) {
  basename(normalizePath(x))
}

# get file name without extension
sans_ext = tools::file_path_sans_ext
file_name_sans = function(x) {
  basename(sans_ext(normalizePath(x)))
}

# generate UUID for Docker container names
# derived from https://stackoverflow.com/questions/10492817/
uuid = function() {
  id = paste(sample(c(letters[1:6], 0:9), 30, replace = TRUE), collapse = '')
  paste(
    substr(id, 1, 8), '_', substr(id, 9, 12), '_', '4',
    substr(id, 13, 15), '_', sample(c('8', '9', 'a', 'b'), 1),
    substr(id, 16, 18), '_', substr(id, 19, 30), sep = '',
    collapse = '')
}

#' check if from Bioconductor base images
#' @importFrom stringr str_trim
#' @noRd
is_from_bioc = function(x) {
  substr(str_trim(x), 1L, 13L) == 'bioconductor/'
}

#' check if from the rocker/rstudio base image
#' @importFrom stringr str_trim
#' @noRd
is_from_rstudio = function(x) {
  substr(str_trim(x), 1L, 14L) == 'rocker/rstudio'
}

# remove consecutive blank lines and only keep one
sanitize_blank = function(txt) {
  blank = which(txt == "")
  # if no blank lines at all
  if (length(blank) == 0L) return(txt)
  idx = which(diff(blank) == 1L) + 1L
  # if no consecutive blank lines
  if (length(idx) == 0L) return(txt)
  txt = txt[-blank[idx]]
  txt
}

# determine os type
check_os = function() {
  if (Sys.info()[['sysname']] == 'Darwin') 'mac' else if
  (.Platform$OS.type == 'windows') 'win' else 'lnx'
}
# Create the toggle matrix used to solve the Ax=b equation in order to get
# the solution to a board
generate_lightsout_matrix <- function(size, classic = TRUE) {
  mat <- matrix(0, ncol = size*size, nrow = size*size)

  for (i in seq(size)) {
    for (j in seq(size)) {
      row <- size * (i - 1) + j
      mat[row, row] <- 1
      if (classic) {
        if (i > 1)    mat[row, row - size] <- 1
        if (i < size) mat[row, row + size] <- 1
        if (j > 1)    mat[row, row - 1] <- 1
        if (j < size) mat[row, row + 1] <- 1
      } else {
        mat[row, size * (i - 1) + seq(size)] <- 1
        mat[row, size * seq(size - 1) + (j - 1) + 1] <- 1
      }
    }
  }

  mat
}

# Translates an integer into a (row, column) location
position_1d_to_2d <- function(pos, size, byrow = TRUE) {
  row <- floor((pos - 1) / size) + 1
  col <- pos - ((row - 1) * size)
  if (byrow) {
    c(row, col)
  } else {
    c(col, row)
  }
}
## util.R
## Karl W Broman

#' Installed version of R/lineup
#'
#' Print the version number of the currently installed version of R/lineup.
#'
#'
#' @return A character string with the version number of the currently
#' installed version of R/lineup.
#' @author Karl W Broman, \email{kbroman@@biostat.wisc.edu}
#' @keywords print
#' @examples
#'
#'   lineupversion()
#'
#' @export
lineupversion <-
    function()
{
    version <- unlist(utils::packageVersion("lineup"))

    # make it like #.#-#
    paste(c(version,".","-")[c(1,4,2,5,3)], collapse="")
}
all_finite <- function(x){
  stopifnot(is.numeric(x))
  storage.mode(x) <- "double"
  .Call("all_finite_double",x)
}


check_sys <- function(A, b, neq, x ,eps){
  if (!is.numeric(A)){
    stop("'A' is not a numeric matrix")
  }
  if (!is.numeric(b)){
    stop("'b' is not a numeric vector")
  }
  if (!missing(x) && !is.numeric(x)){
    stop("'x' is not a numeric vector")
  }
  if ( !is.matrix(A)){
    stop("'A' is not of class 'matrix'")
  }
  if (!missing(eps) && !all_finite(eps)){
    stop("Non-finite value specified for 'eps'")
  }
  if (!missing(eps) && eps < 0){
    stop("Negative value for 'eps' specified")
  }
  if (!all_finite(A)){
    stop("Non-finite values detected in 'A'")
  }
  if (!all_finite(b)){
    stop("Non-finite values detected in 'b'")
  }
  if (!missing(x) && !all_finite(x)){
    stop("Non-finite values detected in 'x'")
  }
  if (nrow(A) != length(b)){
    stop("Number of rows of 'A' not equal to length of 'b'")
  }
  if (!missing(x) && ncol(A) != length(x)){
    stop("Number of columns of 'A' not equal to length of 'x'")
  }
  if (!missing(neq) && neq > nrow(A)){
    stop("number of equations 'neq' larger than number of rows in matrix 'A'")
  }
  
}
## From R.utils 2.0.2 (2015-05-23)
hpaste <- function(..., sep = "", collapse = ", ", last_collapse = NULL,
                   max_head = if (missing(last_collapse)) 3 else Inf,
                   max_tail = if (is.finite(max_head)) 1 else Inf,
                   abbreviate = "...") {
  max_head <- as.double(max_head)
  max_tail <- as.double(max_tail)
  if (is.null(last_collapse)) last_collapse <- collapse

  # Build vector 'x'
  x <- paste(..., sep = sep)
  n <- length(x)

  # Nothing todo?
  if (n == 0) return(x)
  if (is.null(collapse)) return(x)

  # Abbreviate?
  if (n > max_head + max_tail + 1) {
    head <- x[seq_len(max_head)]
    tail <- rev(rev(x)[seq_len(max_tail)])
    x <- c(head, abbreviate, tail)
    n <- length(x)
  }

  if (!is.null(collapse) && n > 1) {
    if (last_collapse == collapse) {
      x <- paste(x, collapse = collapse)
    } else {
      x_head <- paste(x[1:(n - 1)], collapse = collapse)
      x <- paste(x_head, x[n], sep = last_collapse)
    }
  }

  x
}


stopf <- function(fmt, ..., call. = TRUE, domain = NULL) {  #nolint
  stop(sprintf(fmt, ...), call. = call., domain = domain)
}

warnf <- function(fmt, ..., call. = TRUE, domain = NULL) {  #nolint
  warning(sprintf(fmt, ...), call. = call., domain = domain)
}
#' @keywords internal
named_vec2list <- function(listx){
  # to avoid toJSON keep_vec_names warnings
  #  with named vectors
  #  convert named vectors to list
  #  see https://github.com/timelyportfolio/listviewer/issues/10
  if(
    !inherits(listx,"list") &&
    is.null(dim(listx)) &&
    !is.null(names(listx))
  ){
    listx <- as.list(listx)
  }
  return(listx)
}

#' @keywords internal
list_proper_form <- function(listdata){
  if(inherits(listdata,"list")){
    listdata <- rapply(listdata,named_vec2list,how="list")
  }
  listdata
}

#' Recurse Over Nested Lists
#'
#' Like \code{rapply} but recurses over nested lists and
#' retain \code{attributes} and \code{names}.
#'
#' @param l \code{list} over which we would like to recurse
#' @param func \code{function} to apply to the list
#' @param ... arguments for the \code{func}
#'
#' @keywords internal
recurse <- function(l, func, ...) {
l <- func(l, ...)
if(is.list(l) && length(l)>0){
  lapply(
    l,
    function(ll){
      recurse(ll, func, ...)
    }
  )
} else {
  l
}
}

#' @keywords internal
add_number_names <- function(l){
  if(length(l)>1 && is.null(names(l))){
    names(l) <- seq_len(length(l))
  }
  l
}


#' Number Starting at \code{1}
#'
#' JavaScript starts at \code{0}, but R starts at \code{1}.
#' This means unnamed lists and vectors are indexed starting at
#' \code{0} in listviewer widgets.  This little helper function
#' tries to resolve the disconnect by assigning sequential numbers
#' starting at \code{1} to names for unnamed \code{lists} and \code{vectors}.
#' Please note though that using \code{number_unnamed} will potentially
#' cause difficulties serializing back and forth between JavaScript and R.
#'
#' @param l \code{list}
#'
#' @examples
#' library(listviewer)
#' jsonedit(
#'   number_unnamed(list(x=list(letters[1:3])))
#' )
#'
#' @export

number_unnamed <- function(l) {
  recurse(l, add_number_names)
}
random_id <- function(length = 10, prefix = "q") {
  paste(
    c(prefix, sample(c(letters, 0:9), length, replace = TRUE)),
    collapse = ""
  )
}

random_queue_name <- function() {
  random_id(length = 10, prefix = "q")
}

random_lock_name <- function() {
  random_id(length = 6, prefix = "")
}

`%||%` <- function(l, r) if (is.null(l)) r else l

try_silent <- function(x) {
  try(x, silent = TRUE)
}
## Copyright 2018  Marc Hofmann and Achim Zeileis
##
## This file is part of the 'lmSubsets' R extension.
##
## 'lmSubsets' is free software: you can redistribute it and/or modify
## it under the terms of the GNU General Public License as published by
## the Free Software Foundation, either version 3 of the License, or
## (at your option) any later version.
##
## 'lmSubsets' is distributed in the hope that it will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
## GNU General Public License for more details.
##
## You should have received a copy of the GNU General Public License
## along with 'lmSubsets'.  If not, see <http://www.gnu.org/licenses/>.



parent.env <- function (env = parent.frame()) {
    base::parent.env(env)
}


pix2usr <- function (x, y, carry) {
    if (!missing(x)) {
        if (!missing(y))  warning ("unused argument 'y' will be discarded")

        ans <- grconvertX(x, "device", "user") - grconvertX(0, "device", "user")
        if (!missing(carry))  ans <- carry_sign(carry, x, ans)
    } else if (!missing(y)) {
        ans <- grconvertY(y, "device", "user") - grconvertY(0, "device", "user")
        if (!missing(carry))  ans <- carry_sign(carry, y, ans)
    } else {
        stop ("please specify 'x' or 'y'")
    }

    ans
}


carry_sign <- function (carry, a, b) {
    if (carry > 0) {
        sign(a) * abs(b)
    } else if (carry < 0) {
        -sign(a) * abs(b)
    } else {
        abs(b)
    }
}
#################################################################################

## sample actions for handlers

## a handler is a function that accepts a logging.record and a
## configuration.

## a logging.record contains the real message, its level, the name of the
## logger that generated it, a timestamp.

## a configuration contains a formatter (a function taking a
## logging.record and returning a string), a numeric level (only records
## with level equal or higher than that are taken into account), an
## action (writing the formatted record to a stream).

writeToConsole <- function(msg, handler, ...)
{
  if(length(list(...)) && 'dry' %in% names(list(...)))
    return(TRUE)
  cat(paste(msg, '\n', sep=''))
}

writeToFile <- function(msg, handler, ...)
{
  if(length(list(...)) && 'dry' %in% names(list(...)))
    return(exists('file', envir=handler))
  cat(paste(msg, '\n', sep=''), file=with(handler, file), append=TRUE)
}

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

## the single predefined formatter

defaultFormat <- function(record) {
  text <- paste(record$timestamp, paste(record$levelname, record$logger, record$msg, sep=':'))
}

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

#################################################################################
#' A function that performs basic utilities about the data.
#' @import irlba
#' @param X \code{[n, d]} the data with n samples in d dimensions.
#' @param Y \code{[n]} the labels of the samples.
#' @param ... optional args.
#' @return \code{n} the number of samples.
#' @return \code{d} the number of dimensions.
#' @return ylabs \code{[K]} vector containing the unique, ordered class labels.
#' @return priors \code{[K]} vector containing prior probability for the unique, ordered classes.
#' @author Eric Bridgeford
lol.utils.info <- function(X, Y, ...) {
  ylabs <- as.vector(sort(unique(Y)))
  dimx <- dim(X)
  n <- dimx[1]; d <- dimx[2]
  K <- length(ylabs)
  # compute the fraction of each class for prior p
  priors = sapply(ylabs, function(y) sum(Y == y)/n)
  centroids <- as.matrix(sapply(ylabs, function(y) colMeans(X[Y==y,,drop=FALSE])))
  return(list(n=n, d=d, ylabs=ylabs, priors=priors, centroids=centroids, K=K))
}

#' A function that performs a utility computation of information about the differences of the classes.
#' @import irlba
#' @param centroids \code{[d, K]} centroid matrix of the unique, ordered classes.
#' @param priors \code{[K]} vector containing prior probability for the unique, ordered classes.
#' @param ... optional args.
#' @return deltas \code{[d, K]} the K difference vectors.
#' @author Eric Bridgeford
lol.utils.deltas <- function(centroids, priors, ...) {
  d <- dim(centroids)[1]; K <- length(priors)
  # compute the rank-K difference space as deltas(i) = mus(i) - mus(0) where the mus are ordered
  # by decreasing prior
  deltas <- array(0, dim=c(d, K))
  srt_prior <- sort(priors, decreasing=TRUE, index.return=TRUE)$ix
  gr_mix <- srt_prior[1]
  deltas[,1] <- centroids[,gr_mix]
  for (i in 2:K) {
    deltas[,(i)] <- centroids[,srt_prior[i]] - deltas[,1]
  }
  return(deltas)
}
## Utility functions

## Index-finding

indx = function(x, v) {
  storage.mode(x) = storage.mode(v) = "double"
  m = length(x)
  n = length(v)
  ind = integer(m)
  .C("indx", x, m, v, n, ind=ind, PACKAGE="lsei")["ind"]$ind
}

## # Much slower than indx().
## 
## indx2 = function(x, v) {
##   ox = order(x)
##   vx = c(v,x)
##   o = order(vx)
##   indo = c(rep(1, length(v)), rep(0, length(x)))[o]
##   indx = double(length(x))
##   indx[ox] = cumsum(indo)[indo == 0] 
##   indx
## }

matMaxs = function(x, dim=1) {
  if(length(x) == 0) return(NULL)
  x.mode = storage.mode(x)
  n = nrow(x)
  m = ncol(x)
  v = if(dim == 1) double(n) else double(m)
  storage.mode(dim) = storage.mode(n) = storage.mode(m) = "integer"
  x[x == Inf] = 1e308
  x[x == -Inf] = -1e308
  storage.mode(x) = "double"
  v = .C("matMaxs", x, n, m, v=v, dim, PACKAGE="lsei")["v"]$v
  v[v > 9e307] = Inf
  v[v < -9e307] = -Inf
  storage.mode(v) = x.mode
  v
}
msgf <- function(fmt,...){
  message(sprintf(fmt,...))
}

stopf <- function(fmt,...){
  stop(sprintf(fmt,...), call. = FALSE)
}

warnf <- function(fmt, ...){
  warning(sprintf(fmt, ...), call.=FALSE)
}




replace <- function(call, match, sub){
  if (length(call) == 1){
    if ( identical(call,match) ){
      return(sub)
    } else {
      return(call)
    }
    # Skip formulas. We treat them as literals.
  } else if (call[[1]] != "~") {
    for ( i in seq_along(call)[-1] ){
      call[[i]] <- replace(call[[i]], match, sub)
    }
  }
  call
}


# the pipe action.
pipe <- function(x, y, env=sys.parent()){
  
  e <- new.env(parent=env)
  e$. <- x
  
  if ( class(y) == "call" ){
    y1 <- replace(y, quote(.), quote(x))
    uses_dot <- !identical(y,y1)

    if (uses_dot){
      eval(y, envir=e)
    } else {
      w <- as.list(y1)
      y1 <- as.call(c(w[1],quote(.),w[-1]))
      eval(y1, envir=e)
    }
  } else {
    eval(y, envir = e)
  }
     
    
}
#' @title WeMo Switch Port
#'
#' @description Automatically detects the port used by WeMo Switch smart plugs.
#'
#' @param ip A characted string or vector of character strings representing the
#'   IP address(es) of WeMo Switch smart plug(s).
#'
#' @param timeout Number of seconds to wait for a response until giving up. Can
#'   not be less than 1 ms (default: 0.1).
#'
#' @return A \code{\link[tibble]{tibble}} with two columns:
#'   \describe{
#'     \item{ip}{The IP address of the WeMo Switch smart plug.}
#'     \item{port}{The port at which the WeMo Switch smart plug can be accessed.
#'                 NA will be returned is no WeMo Switch is detected at this IP.}
#'   }
#'
#' @author Simon Garnier, \email{garnier@@njit.edu}
#'
#' @examples
#' \dontrun{
#' wemo_PORT("192.0.1.1")
#' }
#'
#' @export
wemo_PORT <- function(ip, timeout = 0.1) {
  tib <- expand.grid(ip = factor(ip), port = c(49152, 49153, 49154, 49155))
  tib$url <- paste0(tib$ip, ":", tib$port)
  tib$test <- mapply(function(url, handle) {
    tryCatch(httr::GET(url, httr::timeout(timeout))$status_code, error = function(e) 500)
  }, url = tib$url) == 404

  test <- cbind(by(tib, tib[, "ip"], function(x) {
    if (any(x$test)) {
      x$port[x$test]
    } else {
      NA
    }
  }))

  tibble::tibble(ip = row.names(test), port = test[, 1])
}
MB <- 1000 * 1000

reserved_names <- c(".i", ".result", ".result_env")

check_reserved <- function(var_name) {
  if(var_name %in% reserved_names){
    stop(sprintf("Connot use the variable name '%s'.", var_name))
  }
}

remove_myself_from_calling_env <- function(calling_env) {
  rm("for", envir = calling_env)
}

main_func_of <- function(call) {
  call[[1]]
}

to_var_name <- function(statement) {
  names <- names(statement[-1])
  if (is.null(names)) {
    names <- make.names(gsub("\\s+", "", paste(deparse(statement[[-1]]), collapse="")))
  }
  names
}

get_arg_names <- function(statements) {
  arg_names <- names(statements)
  if (is.null(arg_names)) {
    arg_names <- rep("", length(statements))
  }
  if (is.symbol(statements)) statements <- list(statements)
  mapply(function(name, arg) {
    if (name == "") {
      gsub("\\s+", "", deparse(arg))
    } else {
      name
    }
  }, arg_names, statements)
}
#' @importFrom magrittr %>%
#' @export
magrittr::`%>%`

read_path <- function(path){
  image <- if(is.character(path)){
    if(is_url(path)){
      read_url(path)
    } else {
      read_file(path)
    }
  } else if(is.raw(path)){
    path
  } else {
    stop("Parameter 'image' must be an image object, file path or raw vector with image data")
  }
  return(image)
}

is_url <- function(path){
  grepl("https?://", path)
}

replace_url <- function(path){
  if(is_url(path)){
    pattern <- "\\[[-,0-9]+\\]$"
    suffix <- regmatches(path, regexpr(pattern, path))
    path <- sub(pattern, "", path)
    paste0(download_url(path), suffix)
  } else if(grepl("^[^/\\]+:$", path)) {
    # demo images e.g. "logo:" or "wizard:"
    return(path)
  } else {
    normalizePath(path, mustWork = FALSE)
  }
}

download_url <- function(url){
  req <- curl::curl_fetch_memory(url)
  if(req$status >= 400)
    stop(sprintf("Failed to download %s (HTTP %d)", url, req$status))
  headers <- curl::parse_headers_list(req$headers)
  ctype <- headers[['content-type']]
  matches <- match(ctype, mimetypes$type)
  extension <- if(length(matches) && !is.na(matches) && !grepl("(text|octet)", ctype)){
    sub("*.", ".", mimetypes$pattern[matches[1]], fixed = TRUE)
  } else {
    basename(url)
  }
  filename <- tempfile(fileext = extension)
  writeBin(req$content, filename)
  return(filename)
}

read_url <- function(path){
  req <- curl::curl_fetch_memory(path)
  if(req$status >= 400)
    stop(sprintf("Failed to download %s (HTTP %d)", path, req$status))
  return(req$content)
}

read_file <- function(path){
  readBin(normalizePath(path, mustWork = TRUE), raw(), file.info(path)$size)
}

assert_image <- function(image){
  if(!inherits(image, "magick-image"))
    stop("The 'image' argument is not a magick image object.", call. = FALSE)
  if(magick_image_dead(image))
    stop("Image pointer is dead. You cannot save or cache image objects between R sessions.", call. = FALSE)
}
zero.to.inf <- list(
  phi = function(t) exp(pi*sinh(t)/2.0),
  phidash = function(t) pi*cosh(t)*exp(pi*sinh(t)/2.0)/2.0,
  interval = c(-6.8,6.8)
)

minusone.to.one <- list(
  phi = function(t) tanh(pi*sinh(t)/2.0),
  phidash = function(t) pi*cosh(t)*(1/cosh(pi*sinh(t)/2.0))^2/2.0,
  interval = c(-3,3)
)

deformula.weight <- function(f, deformula=zero.to.inf,
  zero=.Machine$double.eps, reltol=sqrt(.Machine$double.eps), ...) {
  d <- 8
  prev <- Inf
  for (k in 1:30) {
    s <- seq(from=deformula$interval[1], to=deformula$interval[2], length.out=d+1)
    h <- (deformula$interval[2] - deformula$interval[1]) / d
    res.w <- numeric(0)
    res.x <- numeric(0)
    for (t in s) {
      x <- deformula$phi(t)
      w <- deformula$phidash(t) * f(x, ...)
      if (is.finite(w) && w > zero) {
        res.w <- c(res.w, w)
        res.x <- c(res.x, x)
      }
    }
    v <- sum(res.w)*h
    aerror <- v - prev
    rerror <- aerror / prev
    if (is.finite(rerror) && abs(rerror) < reltol) {
      break
    }
    d <- d * 2
    prev <- v
  }
  list(x=res.x, weights=res.w, aerror=aerror, rerror=rerror, sum=v)
}
herlang.shape.all <- function(phnum, lbound, ubound) {
  herlang.shape.ipart(1, numeric(phnum), 1, phnum, lbound, ubound, list())
}

herlang.shape.ipart <- function(pos, shape, mini, res, lb, ub, result) {
  if (mini > res) {
    return(result)
  } else {
    for (i in mini:res) {
      shape[pos] <- i
      result <- herlang.shape.ipart(pos+1, shape, i, res-i, lb, ub, result)
    }
    if (lb <= pos && pos <= ub) {
      result <- c(result, list(shape[1:pos]))
    }
    return(result)
  }
}

herlang.shape.increment <- function(shape, ubound, phsize) {
  ## append
  if (length(shape) == ubound || sum(shape) == phsize) {
    return(list())
  }
  result <- c(1, shape)
  retval <- list(result)
  
  ## add
  for (i in unique(shape)) {
    tmp <- shape
    l <- which(tmp == i)
    n <- length(l)
    tmp[l[n]] <- tmp[l[n]] + 1
    retval <- c(retval, list(tmp))
  }
  return(retval)
}

herlang.shape.decrement <- function(shape, lbound) {
  if (length(shape)==1 && shape[1]==1) {
    return(list())
  }
  retval <- list()
  ## subtract
  for (i in unique(shape)) {
    tmp <- shape
    l <- which(tmp == i)
    n <- length(l)
    tmp[l[1]] <- tmp[l[1]] - 1
    tmp <- tmp[tmp != 0]
    if (length(tmp) >= lbound)
      retval <- c(retval, list(tmp))
  }
  return(retval)
}
## This function checks if the length of all vectors in a list
## is either "1" or has the same maximum value
checkVecLength <- function(x) {
  if (!is.list(x)) stop("x must be a list of vectors")
  alleng <- sapply(x, length)
  maxlen <- max(alleng)
  all((alleng == maxlen) | (alleng == 1))
}
#  matchingR -- Matching Algorithms in R and C++
#
#  Copyright (C) 2015  Jan Tilly <jtilly@econ.upenn.edu>
#                      Nick Janetos <njanetos@econ.upenn.edu>
#
#  This file is part of matchingR.
#
#  matchingR is free software: you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation, either version 2 of the License, or
#  (at your option) any later version.
#
#  matchingR is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.

#' Repeat each column of a matrix n times
#'
#' This function repeats each column of a matrix n times
#'
#' @param x is the input matrix
#' @param n is the number of repetitions (can be a vector)
#' @return matrix with repeated columns
repcol = function(x, n){
    s = NCOL(x)
    if(length(n) == 1) {
        return(matrix(x[,rep(1:s, each = n)], nrow = NROW(x), ncol = s*n))
    }
    matrix(x[,rep(1:s, n)], nrow = NROW(x), ncol = sum(n))
}

#' Repeat each row of a matrix n times
#'
#' This function repeats each row of a matrix n times
#'
#' @param x is the input matrix
#' @param n is the number of repetitions (can be a vector)
#' @return matrix with repeated rows
reprow = function(x, n){
    s = NROW(x)
    if(length(n) == 1) {
        return(matrix(x[rep(1:s, each = n),], nrow = s*n, ncol = NCOL(x)))
    }
    matrix(x[rep(1:s, n),], nrow = sum(n), ncol = NCOL(x))
}
# The parent flag is used to search in the parent envir for suitable definitions.
# Set to TRUE if you want to only use the inputs provided
printMatrix <- function(A, parent = TRUE, fractions = FALSE, latex = FALSE, 
						tol = sqrt(.Machine$double.eps)){
	if(parent){
		envir <- as.environment(-1L)
		if(!is.null(envir$fractions)) fractions <- envir$fractions
		if(!is.null(envir$latex)) latex <- envir$latex
		if(!is.null(envir$tol)) tol <- envir$tol
	}
	if (latex) {
		matrix2latex(A, fractions=fractions, digits = round(abs(log(tol,10))))
	} else {
		print(formatNumbers(as.matrix(A), fractions=fractions, tol=tol))
	}
}

formatNumbers <- function(x, fractions=FALSE, tol=sqrt(.Machine$double.eps)){
	ret <- if (fractions) MASS::fractions(x) else round(x, round(abs(log(tol, 10))))
	ret
}

r2d <-function(r) r/pi * 180

d2r <-function(d) pi*d / 180
rowVars <- function(x, na.rm=FALSE) {
  M <- rowMeans(x, na.rm=na.rm)
  n <- rowSums(!is.na(x))-1
  ifelse(n > 0, rowSums((x-M)^2, na.rm=na.rm) / n, NA)
}

rowTables <- function(x) {
  lvl <- sort(unique(as.numeric(x)))
  res <- matrix(numeric(), nrow=nrow(x), ncol=length(lvl))
  colnames(res) <- lvl
  for(i in seq_along(lvl)) {
    res[,i] <- rowSums(x==lvl[i], na.rm=TRUE)
  }
  res
}

showWarning <- function(isWarning, err) {
  if(any(isWarning, na.rm=TRUE)) {
    parentFun <- as.list(sys.call(-1))[[1]]
    n <- sum(isWarning, na.rm=TRUE)
    i <- match(TRUE, isWarning)
    err <- paste0(parentFun, ": ", n, ' of the rows ', err, ".",
                  '\nFirst occurrence at row ', i
                  )
    warning(err, call.=FALSE)
  }
}
#internal test function of expectation for one-inflated distribution

tmean1 <- function(doifun, ...)
  integrate(function(x) x*doifun(x, ...), 0, 1)$value + 1*doifun(x=1, ...)
tmean2 <- function(poifun, ...)
  integrate(function(x) 1-poifun(x, ...), 0, 1)$value
tmean3 <- function(ecoifun, eps=1e-9, ...)
  eps/ecoifun(eps, ...)
# Infinitely differentiable transformations of R into a bounded or half-bounded interval

#Transformation from (-Inf, +Inf) to (-1, 0)
Trans.m10 <- function(x)
  -1/(1+exp(-x))
#Inverse
InvT.m10 <- function(x) 
  log(-x/(1+x))

#Transformation from (-Inf, +Inf) to (0, 1)
Trans.01 <- function(x)
  1/(1+exp(-x))
#Inverse
InvT.01 <- function(x)
  log(x/(1-x))

#Transformation from (-Inf, +Inf) to (0, +Inf)
Trans.0Inf <- function(x)
  exp(x)
#Inverse
InvT.0Inf <- function(x)
  log(x)

#Transformation from (-Inf, +Inf) to (1, +Inf)
Trans.1Inf <- function(x)
  1+exp(x)
#Inverse
InvT.1Inf <- function(x)
  log(x-1)
#likelihood function
LLfunc <- function(obs, theta, dist)
{
  dist <- match.arg(dist, c("oiunif", "oistpareto", "oibeta", "oigbeta", "mbbefd", "MBBEFD", "unif", "stpareto", "beta", "gbeta"))
  ddist <- paste0("d", dist)
  sum(log(do.call(ddist, c(list(obs), as.list(theta)) ) ) )
}

#gradient of the likelihood function
grLLfunc <- function(obs, theta, dist)
{
  dist <- match.arg(dist, c("mbbefd", "MBBEFD")) 
  if(dist == "mbbefd")
  {
    g1 <- function(x, theta)
    {
      a <- theta[1]; b <- theta[2]
      ifelse(x == 1, (b-1)/(a+1)/(a+b), (2*a+1)/(a*(a+1)) - 2/(a+b^x))
    }
    g2 <- function(x, theta)
    {
      a <- theta[1]; b <- theta[2]
      ifelse(x == 1, a/(b*(a+b)), -x/b+1/(b*log(b))+2*a*x/(b*(a+b^x)))
    }
    c(sum(sapply(obs, g1, theta=theta)), sum(sapply(obs, g2, theta=theta)))
  }else
  {
    stop("not yet implemented.")
  }
}

#Hessian of the likelihood function
heLLfunc <- function(obs, theta, dist)
{
  dist <- match.arg(dist, c("mbbefd", "MBBEFD")) 
  if(dist == "mbbefd")
  {
    h11 <- function(x, theta)
    {
      a <- theta[1]; b <- theta[2]
      ifelse(x == 1, 1/(a+b)^2-1/(a+1)^2, 2/(a+b^x)^2-1/a^2-1/(a+1)^2)
    }
    h21 <- function(x, theta)
    {
      a <- theta[1]; b <- theta[2]
      ifelse(x == 1, 1/(a+b)^2, 2*x*b^(x-1)/(a+b^x)^2)
    }
    h22 <- function(x, theta)
    {
      a <- theta[1]; b <- theta[2]
      ifelse(x == 1, 1/(a+b)^2-1/b^2, 
             x/b^2-(log(b)+1)/(b^2*log(b)^2)-2*a*x/(b^2*(a+b^x))-2*a*x^2*b^x/(b^2*(a+b^x)^2))
    }
    rbind(c(sum(sapply(obs, h11, theta=theta)), sum(sapply(obs, h21, theta=theta))),
          c(sum(sapply(obs, h21, theta=theta)), sum(sapply(obs, h22, theta=theta))))
  }else
  {
    stop("not yet implemented.")
  }
}
#integral(from=0, to=1, function(x) a+b^x)
gendilog <- function(a, b, checkparam=TRUE)
{
  if(!(a +1 >0 && b > 0 && a*(1-b) >= 0) && checkparam)
    return(NaN)
  
  if(a == 0)
    return(log(b)/2)
  else if(b == 1)
    return(log(a+1))
  else if(a > 0)
  {
    res <- (dilog(-1/a) - dilog(-b/a))/log(b)+log(a)
  }else
  {
    res <- (dilog(1+b/a) - dilog(1+1/a))/log(b)
    res <- res + log(a+b) - log(-a)*log((a+b)/(a+1))/log(b)
  }
  res
}
#to meet the standard 'fn' argument and specific name arguments, 

#constraint function for MBBEFD(a,b)
constrmbbefd <- function(x, fix.arg, obs, ddistnam)
{
  res <- x[1]*(1-x[2]) #a*(1-b) >= 0
  names(res) <- NULL
  res
}
#domain : (a,b) in (-1, 0) x (1, +Inf)
constrmbbefd1 <- function(x, fix.arg, obs, ddistnam)
{
  res <- c(x[1]+1, -x[1], x[2]-1, x[1]*(1-x[2])) #-1 < a < 0, b > 1, a*(1-b) >= 0
  names(res) <- NULL
  res
}
constrmbbefd1jac <- function(x, fix.arg, obs, ddistnam)
{
  j <- matrix(0, 4, 2)
  j[1,] <- c(1, 0)
  j[2,] <- c(0, -1)
  j[3,] <- c(1, 0)
  j[4,] <- c(-x[2], -x[1])
  dimnames(j) <- NULL
  j
}  

#domain : (a,b) in (0, +Inf) x (0, 1)
constrmbbefd2 <- function(x, fix.arg, obs, ddistnam)
{
  res <- c(x[1], x[1], 1-x[2], x[1]*(1-x[2])) #0 < a , 0 < b < 1, a*(1-b) >= 0
  names(res) <- NULL
  res
}
constrmbbefd2jac <- function(x, fix.arg, obs, ddistnam)
{
  j <- matrix(0, 4, 2)
  j[1,] <- c(1, 0)
  j[2,] <- c(0, 1)
  j[3,] <- c(0, -1)
  j[4,] <- c(-x[2], -x[1])
  dimnames(j) <- NULL
  j
}  


#constraint function for MBBEFD(g,b)
constrMBBEFD <- function(x, fix.arg, obs, ddistnam)
{
  res <- c(x[1]-1, x[2]) #g >= 1, b > 0
  names(res) <- NULL
  res
}
#domain : (g,b) in (1, +Inf) x (1, +Inf) with gb > 1
constrMBBEFD1 <- function(x, fix.arg, obs, ddistnam)
{
  res <- c(x[1]-1, x[2]-1, x[1]*x[2]-1) #g > 1, b > 1, gb > 1
  names(res) <- NULL
  res
}
constrMBBEFD1jac <- function(x, fix.arg, obs, ddistnam)
{
  j <- matrix(0, 3, 2)
  j[1,] <- c(1, 0)
  j[2,] <- c(0, 1)
  j[3,] <- c(x[2], x[1])
  dimnames(j) <- NULL
  j
}

#domain : (g,b) in (1, +Inf) x (0, 1) with gb < 1
constrMBBEFD2 <- function(x, fix.arg, obs, ddistnam)
{
  res <- c(x[1]-1, 1-x[2], x[2], 1-x[1]*x[2]) #g > 1, 1 > b > 0, gb < 1
  names(res) <- NULL
  res
}
constrMBBEFD2jac <- function(x, fix.arg, obs, ddistnam)
{
  j <- matrix(0, 4, 2)
  j[1,] <- c(1, 0)
  j[2,] <- c(0, -1)
  j[3,] <- c(0, 1)
  j[4,] <- c(-x[2], -x[1])
  dimnames(j) <- NULL
  j
}
get_file_basename <- function(filename) {
  tempname <- strsplit(basename(filename), ".RData")[[1]][1]
  basename <- paste(strsplit(tempname, "_")[[1]][1],
                    strsplit(tempname, "_")[[1]][2],
    strsplit(tempname, "_")[[1]][3], strsplit(tempname, "_")[[1]][4],
    sep = "_")
  basename
}

get_project_plate_name <- function(file) {
  tempname <- strsplit(basename(file), ".RData")[[1]][1]
  basename <- paste(strsplit(tempname, "_")[[1]][1],
                    strsplit(tempname, "_")[[1]][2],
    strsplit(tempname, "_")[[1]][3], sep = "_")
  basename
}

.get_all_electrodes <- function(r) {
  plate <- .plateinfo(r$layout$array)
  wells <- as.matrix(sort(plate$wells))
  result <- as.vector(apply(wells, c(1, 2), function(well) {
    .get_electrode_layout(r, well)$electrodes
  }))
  result
}

.get_electrode_layout <- function(r, well) {
  plateinfo <- .plateinfo(r$layout$array)
  d1 <- expand.grid(col = 1:plateinfo$n_elec_c, row = 1:plateinfo$n_elec_r)
  electrodes <- sort(paste(well, "_", d1[, "row"], d1[, "col"], sep = ""))
  layout <- c(plateinfo$n_elec_r, plateinfo$n_elec_c)
  return(list(electrodes = electrodes, layout = layout))
}
#' Center a vector
#'
#' \code{center} returns a numeric vector with centered values.
#'
#' @param x Numeric vector.
center <- function(x) {
    
    centered <- as.vector(scale(x = x, center = TRUE, scale = FALSE))
    
    return(centered)
}
## convert pixel to inch
px2in <- function(x) {
    x * 0.010417
}

##' aspect ratio of meme
##'
##'
##' @title asp
##' @param x meme object
##' @return asp ratio
##' @export
##' @author guangchuang yu
##' @examples
##' \dontrun{
##' f <- system.file("icon.png", package="meme")
##' x <- meme(f, "meme", "produced by meme package")
##' asp(x)
##' }
asp <- function(x) {
    x$height/x$width
}

## ##' @method length meme
## ##' @export
## length.meme <- function(x) {
##     return(1)
## }

##' @importFrom ggplot2 aes
##' @export
ggplot2::aes

##' @importFrom ggplot2 ggsave
##' @export
ggplot2::ggsave
# Generic utiliy functions of the package

# In case of a missing argument, stops execution and prints error message
misssing_msg <- function(string)
  stop(paste0('There is a missing argument: \'', string, '\''), call.=FALSE)
#Functions to switch from relative humidity to specific humidity
.HSHR<-function(Tc, HS, allowSaturated = FALSE){


  #-------------------------------------------------------------
  #D?claration des constantes pour le calcul de l'HR et de la T en ?C
  Mas=28.966 # masse molaire air sec (g/mol)
  Mh2o=18 # masse molaire H2O(g/mol)
  Rgz=8.314472 # %J/mol/K cste gaz parfait
  p_air=101325 #  %en Pa
  #-------------------------------------------------------------

  #Calcul de l'Humidit? relative bas? sur Hs et Tk
  Tk=Tc+273.15
  Dair=((p_air)/(Rgz*(Tk)))*Mas # Calcul de la masse volumique de l'air sec en g.m-3
  masshum=HS*Dair # Masse d'eau dans l'air g.m-3
  nhum=masshum/Mh2o # en mol.m-3
  ea=nhum*(Rgz*(Tk)) # Pression de vapeur r?elle (en Pa)
  es=6.108*exp(17.27*Tc/(237.2+Tc))*100 # Pression de vapeur saturante ? la Temp?rature T (en Pa)
  HR=ea/es*100 #Calcul de l'HR
  if(!allowSaturated) HR[HR>100]=100 # On ne passe pas audessus de 100
  return(HR)
}
.HRHS<-function(Tc, HR){

  #-------------------------------------------------------------
  #D?claration des constantes pour le calcul de l'HR et de la T en ?C
  Mas=28.966 # masse molaire air sec (g/mol)
  Mh2o=18 # masse molaire H2O(g/mol)
  Rgz=8.314472 # %J/mol/K cste gaz parfait
  p_air=101325 #  %en Pa
  #-------------------------------------------------------------

  #Calcul de l'Humidit? relative bas? sur Hs et Tk
  Tk=Tc+273.15

  Dair=((p_air)/(Rgz*(Tk)))*Mas # Calcul de la masse volumique de l'air sec en g.m-3
  es=6.108*exp(17.27*Tc/(237.2+Tc))*100 # Pression de vapeur saturante ? la Temp?rature T (en Pa)
  ea=HR*es/100 #Calcul de l'ea
  nhum=ea/(Rgz*(Tk)) # Pression de vapeur r?elle (en Pa)
  masshum=nhum*Mh2o # en mol.m-3
  HS=masshum/Dair
  return(HS)
}
old.options <- options(
	optim.method = "L-BFGS-B",
	optim.control = list()
)
on.exit(options(old.options), add = TRUE)

printf <- function(msg, ...) {
	cat(sprintf(msg, ...))
}

logger <- function(msg, ...) {
	sys.time <- as.character(Sys.time())
	cat(sys.time, "-", sprintf(msg, ...))
}

#' Normalize
#'
#' Scale a numeric vector by the sum of its elements
#'
#' @param x A numeric vector
#'
#' @return \code{x / sum(x)}
#'
#' @examples
#'   x <- c(1,1,1,1)
#'   normalize(x)
normalize <- function(x) { x / sum(x) }

null.tx <- function(phi) { list() }

my.numerical.format <- function(x, lower = 1e-4) {
	idx1 <- which(abs(x) < lower)
	idx2 <- setdiff(1:length(x), idx1)
	y <- character(length(x))
	y[idx1] <- sprintf("%0.3E", x[idx1])
	y[idx2] <- sprintf("%0.4f", x[idx2])
	names(y) <- names(x)
	return(y)
}

#' Multinomial logit transformation
#'
#' mlogit transforms from probability simplex S^J to R^(J-1)
#' inv.mlogit transforms from R^(J-1) to probability simplex S^J
#'
#' @param x A (J-1)-dimensional numeric vector
#' @param p A J-dimensional numeric vector in the probabiity simplex
#'
#' @return A numeric vector
#'
#' @examples
#'   x <- c(1,1,1,1)
#'   p <- inv.mlogit(x)
#'   x2 <- mlogit(p)
#' @name mlogit
mlogit <- function(p) {
	J <- length(p)
	x <- log(p[-J] / p[J])
	return(x)
}

#' @name mlogit
inv.mlogit <- function(x) {
	z <- exp(x)
	P.J <- 1 / (1 + sum(z))
	p <- c(z * P.J, P.J)
	return(p)
}

# Confluent geometric function of the first kind
hypergeomF1 <- function(x, a, b, log = FALSE) {
	n <- max(length(a), length(b), length(x))
	x <- rep_len(x, n)
	a <- rep_len(a, n)
	b <- rep_len(b, n)
	
	ff <- hyperg_1F1(a, b, x)
	if (log) log(ff)
	else ff
}

mbeta <- function(t, a, b, log = FALSE) {
	hypergeomF1(t, a, a+b, log)
}
raise_placeholder_error = function()
  stop("Placeholder for method. Subclasses should implement this method!")
#' Pipe operator
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @importFrom magrittr %>%
#' @usage lhs \%>\% rhs
#' @export
NULL

#' Compound_pipe
#'
#' @name %<>%
#' @rdname compound_pipe
#' @keywords internal
#' @importFrom magrittr %<>%
#' @usage lhs \%<>\% rhs
#' @export
NULL

#' @title comb_pload
#' @description Internal combine function for foreach loop used in get_payload()
#' @param x target
#' @param ... additional args
#' @keywords internal
#' @export
comb_pload <- function(x, ...) {
    lapply(seq_along(x),
           function(i) c(x[[i]],lapply(list(...), function(y) y[[i]])))
}


#' Internal function to add a column of dates to a list of gids.
#' @param gidlist A list from the internal data set \code{game_id}
#' @param ... additional arguments.
#' @importFrom dplyr rename
#' @importFrom stringr str_replace str_sub
#' @keywords internal
#' @export

gid_date <- function(gidlist=NULL, ...){
    gidlist$date_dt <- stringr::str_sub(gidlist$gameday_link, 5, 14) %>% stringr::str_replace_all("_", "-")
    return(gidlist)
}


#' Internal function to cast the first letter of a word to upper-case.
#' @param x A word or string to capitalize
#' @param ... additional arguments.
#' @keywords internal
#' @export
upperfirst <- function(x) {
    substr(x, 1, 1) <- toupper(substr(x, 1, 1))
    x
}
# show info without if-statement
showInfo = function(show.info, ...) {
  if (show.info)
    messagef(...)
}


# load required extra packages
loadPackages = function(control) {
  if (control$infill.opt == "cmaes")
    requirePackages("cmaesr", why = "proposePoints")
  if (control$n.objectives == 1L && control$propose.points > 1L && control$multipoint.method == "moimbo")
    requirePackages("emoa", why = "proposePoints")
}


# for Parego: calculate all integer vectors of length k with sum n
combWithSum = function(n, k) {
  fun = function(n, k) {
    if (k == 1L)
      list(n)
    else
      unlist(lapply(0:n, function(i) Map(c, i, fun(n - i, k - 1L))),
        recursive = FALSE)
  }
  matrix(unlist(fun(n, k)), ncol = k, byrow = TRUE)
}

getFileBackupName = function(fn) {
  file.path(dirname(fn), sprintf(".~%s", basename(fn)))
}

getRandomSeed = function() {
  if (!exists(".Random.seed", .GlobalEnv))
    set.seed(NULL)
  get(".Random.seed", .GlobalEnv)
}

measureTime = function(expr, ee = parent.frame()) {
  before = proc.time()[3L]
  force(expr)
  as.numeric(proc.time()[3L] - before)
}

# checks if a parameter or par.set is only numeric and has no dependencies/requires
# FIXME: remove as soon as this is in ParamHelper
isSimpleNumeric = function(par) {
  isNumeric(par, include.int = TRUE) && !hasRequires(par)
}

getHyperParsString2 = function(learner, show.missing.values = TRUE) {
  hps = getHyperPars(learner)
  ns = names(hps)
  pars = getParamSet(learner)$pars[ns]
  s = mapply(paramValueToString, pars, hps, MoreArgs = list(show.missing.values = show.missing.values))
  paste(ns, s, sep = "=", collapse = ",")
}
# get one el from each row of a matrix, given indices or col names (factors for colnames are converted to characters)
getRowEls = function(mat, inds) {
  if (is.factor(inds))
    inds = as.character(inds)
  if (is.character(inds))
    inds = match(inds, colnames(mat))
  inds = cbind(seq_row(mat), inds)
  mat[inds]
}

# get one el from each col of a matrix, given indices or row names
getColEls = function(mat, inds) {
  getRowEls(t(mat), inds)
}

# Do fuzzy string matching between input and a set of valid inputs
# and return the most similar valid inputs.
getNameProposals = function(input, possible.inputs, nproposals = 3L) {
  assertString(input)
  assertCharacter(possible.inputs)
  assertInt(nproposals, lower = 1L)

  # compute the approximate string distance (using the generalized Levenshtein / edit distance)
  # and get the nproposals most similar valid inputs.
  indices = order(adist(input, possible.inputs))[1:nproposals]
  possibles = na.omit(possible.inputs[indices])
  return(possibles)
}

# shorter way of printing debug dumps
#' @export
print.mlr.dump = function(x, ...) {
  cat("<debug dump>\n")
  invisible(NULL)
}


# applys the appropriate getPrediction* helper function
getPrediction = function(object, newdata, ...) {
  pred = do.call("predict", c(list("object" = object, "newdata" = newdata), list(...)))
  point = switch(object$task.desc$type,
    "regr" = getPredictionResponse(pred),
    "surv" = getPredictionResponse(pred),
    "classif" = if (object$learner$predict.type == "response")
      getPredictionResponse(pred) else getPredictionProbabilities(pred))

  if (object$learner$predict.type == "se")
    cbind("preds" = point, "se" = getPredictionSE(pred))
  else
    point
}
# sort classes wrt to size
getMinMaxClass = function(y) {
  tab = table(y)
  j.small = getMinIndex(tab)
  ns = names(tab)
  min.name = ns[j.small]
  max.name = ns[-j.small]
  list(
    min.name = min.name,
    min.size = tab[j.small],
    min.inds = which(y == min.name),
    max.name = max.name,
    max.size = tab[-j.small],
    max.inds = which(y == max.name)
  )
}

# @param y binaryclass vec
# @param rate resample rate
# @param cl main class to either down or upsample
# @param resample.other.class sample with replacement from other class?
# @return new y vec
#
# generates a new resampled y:
# a) class cl is either oversampled or downsampled, depending on rate
# b) the other binary class is either copied or bootstrapped (for variance)
sampleBinaryClass = function(y, rate, cl, resample.other.class) {
  inds1 = which(y == cl) # indices for class cl
  inds2 = setdiff(seq_along(y), inds1) # indices for other class
  newsize = round(length(inds1) * rate)
  # undersampling (rate < 1): reduce class1 by selecting newsize elements from it
  if (rate < 1) {
    newinds1 = sample(inds1, newsize, replace = FALSE)
  # oversampling (rate > 1): take existing inds and sample add. inds with repl.
  } else {
    newinds1 = c(inds1, sample(inds1, newsize - length(inds1), replace = TRUE))
  }
  # now either copy or bootstrap other class
  if (resample.other.class)
    newinds2 = sample(inds2, length(inds2), replace = TRUE)
  else
    newinds2 = inds2
  c(newinds1, newinds2)
}
# checks for duplicated entries in learner.names and stops
# with error message containing the learner name that appeared more
# than once
checkDuplicatedLearnerNames = function(learner.names) {
  dupl = duplicated(learner.names)
  if (any(dupl)) {
    dupl.learners = unique(learner.names[dupl])
    stopf("Learner short names are not unique for: %s. \n  Set 'pretty.names = FALSE' to resolve this.",
      collapse(dupl.learners))
  }
}
.is.formula <- function(x) {
    if (is.null(x)) return(FALSE)
    inherits(x, "formula")
}

.is.Surv <- function(x)
    inherits(x, "Surv")

.is.R <- function(x)
    inherits(x, "response")

.type_of_response <- function(y) {
    if (.is.Surv(y)) return("survival")
    if (.is.R(y)) {
        if (any(.exact(y))) {
            y <- y$exact[.exact(y)]
        } else {
            y <- y$cleft[.cleft(y)]
        }
    }
    if (storage.mode(y) == "double") return("double")
    if (is.integer(y)) return("integer")
    if (is.ordered(y)) return("ordered")
    if (is.factor(y)) return("unordered")
    return(NA)
}

.checkR <- function(x, weights = NULL) {
    if (!.is.R(x)) return(FALSE)
    if (is.null(weights)) weights <- 1
    if (all(.cleft(x) & !.cright(x) & weights > 0)) {
        warning("response contains left-censored observations only")
        return(FALSE)
    }
    if (all(!.cleft(x) & .cright(x) & weights > 0)) {
        warning("response contains right-censored observations only")
        return(FALSE)
    }
    return(TRUE)
}

.exact_subset <- function(exact, subset = NULL) {

    iex <- inex <- NULL
    if (any(exact))
        iex <- which(exact)
    if (any(!exact))
        inex <- which(!exact)
    if (is.null(subset))
        return(list(full_ex = iex, full_nex = inex))

    full_ex <- redu_ex <- full_nex <- redu_nex <- NULL
    if (length(iex) > 0) {
        full_ex <- iex[iex %in% subset]
        redu_ex <- (1L:length(iex))[iex %in% subset]
    }
   if (length(inex) > 0) {
        full_nex <- inex[inex %in% subset]
        redu_nex <- (1L:length(inex))[inex %in% subset]
    }
    return(list(full_ex = full_ex, redu_ex = redu_ex,
                full_nex = full_nex, redu_nex = redu_nex))
}

if (FALSE) {
exact <- c(TRUE, FALSE)[c(1, 2, 1, 1, 2, 2)]
.exact_subset(rep(TRUE, 3))
.exact_subset(rep(FALSE, 3))
.exact_subset(exact)
.exact_subset(exact, 1:2)
.exact_subset(exact, 3:6)
}
################################################################################

ERROR_NLINE <- "Error when getting the number of lines of the file."
ERROR_FILE  <- "Error with file. Lines not equal? No last empty line?"
ERROR_DIM   <- "Error when guessing the dimensions of the file."

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

CODE_012    <- rep(NA_integer_, 256); CODE_012[49:51]    <- 0:2
CODE_DIGITS <- rep(NA_integer_, 256); CODE_DIGITS[49:58] <- 0:9

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

is_int <- function(x) floor(x) == x

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

stop2 <- function(msg) stop(msg, call. = FALSE) 
warning2 <- function(msg) warning(msg, call. = FALSE) 

################################################################################
#' @importFrom mvtnorm GenzBretz
#' @export
mvtnorm::GenzBretz
## default loss functions based
defaultLoss = function(x, y) UseMethod("defaultLoss")
defaultLoss.numeric = function(x, y) mean((x - y)^2)
defaultLoss.factor = function(x, y) mean(x != y)
defaultLoss.integer = function(x, y) defaultLoss.numeric(x, y)
defaultLoss.ordered = function(x, y) defaultLoss.numeric(x, y)
defaultLoss.character = function(x, y) defaultLoss.factor(x, y)
## assumes first argument is the matrix
defaultLoss.matrix = function(x, y) apply(x, 2, function(z) defaultLoss(z, y))
## Not for public use.
characterize <- function(S1,S2){
  if(is.null(ncol(S1))){  ## simple point process without marks
    n.mark <- 0
    N1 <- length(S1);N2 <- length(S2)
    T1 <- S1;T2 <- S2
  }else{
    n.mark <- ncol(S1)-1  # dimension of marks
    N1 <- nrow(S1); N2 <- nrow(S2)
    T1 <- S1$time;T2 <- S2$time
  }
  return(list(T1=T1,T2=T2,N1=N1,N2=N2,n.mark=n.mark))
}


## Heaviside step function
hev<-function(t){ifelse(t>0,1,0)}
vlapply <- function(X, FUN, ..., USE.NAMES = TRUE) {
  vapply(X = X, FUN = FUN, FUN.VALUE = logical(1L), ..., USE.NAMES = USE.NAMES)
}

stopc <- function(...) {
  stop(..., call. = FALSE, domain = NA)
}

warningc <- function(...) {
  warning(..., call. = FALSE, domain = NA)
}

names2 <- function(x) {
  names(x) %||% rep("", length(x))
}

"%||%" <- function(x, y) if(is.null(x)) y else x
#' Pipe operator
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @export
#' @importFrom magrittr %>%
#' @usage lhs \%>\% rhs
NULL

#' @importFrom purrr map reduce compact %||%
NULL

reduce_common <- function(x, msg = "Objects must be identical",
                          operator = identical) {
  reduce(x, function(.x, .y) {
    if (!operator(.x, .y)) {
      stop(msg, call. = FALSE)
    }
    .y
  })
}


has_name <- function(x) {
  nms <- names(x)
  if (is.null(nms)) {
    rep(FALSE, length(x))
  } else {
    !(is.na(nms) | nms == "")
  }
}

big_mark <- function(x, ...) {
  mark <- if (identical(getOption("OutDec"), ",")) "." else ","
  formatC(x, big.mark = mark, ...)
}

id <- function(n) {
  width <- nchar(n)
  sprintf(paste0("%0", width, "d"), seq_len(n))
}
find_symbols <- function(lang) {
  if (is.call(lang)) {
    find_symbols_call(lang)
  } else if (is.symbol(lang)) {
    as.character(lang)
  } else {
    character(0)
  }
}

find_symbols_call <- function(lang) {
  fun_name <- as.character(lang[[1]])

  if (fun_name %in% c("$", "@")) {
    as.character(lang[[2]])
  } else if (fun_name %in% c("::", ":::")) {
    character(0)
  } else {
    res <- map(as.list(lang[-1]), find_symbols)
    purrr::flatten_chr(res)
  }
}

f_zap_lhs <- function(f) {
  lazyeval::f_new(lazyeval::f_rhs(f), env = lazyeval::f_env(f))
}

is_formula <- function(f) {
  inherits(f, "formula")
}
list2mkm <- function(list_of_models){ #rever e completar os outros slots
  model <- methods::new('mkm')
  model@km <- list_of_models
  model@design <- as.data.frame(list_of_models[[1]]@X)
  model@response <- as.data.frame(lapply(list_of_models, function(model) model@y))
  model@d <- ncol(model@design)
  model@n <- nrow(model@design)
  model@m <- length(model@objective)
  model@j <- length(model@km) - model@m
  return(model)
}

mco2ps <- function(mco){
  if(all(class(mco)!='mco'))
    stop('object must be of "mco" class')
  ps <- NULL
  ps$set <- mco$value
  ps$x <- mco$par
  ps$index <- NULL
  ps$n <- nrow(ps$set)
  ps$m <- ncol(ps$set)
  class(ps) <- 'ps'
  return(ps)
}

normalize <- function(data, ran = NULL){
  if (is.null(ran))
    ran <- apply(data, 2, range)
  data <- data.frame(t(apply(data, 1, function(data) (data - ran[1,])/(ran[2,]-ran[1,]))))
  return(data)
} # arrumar problema de NA (divizao por 0 )
#A collection of methods used to compute moments/cumulants.

#ensure the coefficients are all positive
#returns TRUE if error, FALSE if no error
checkCoeffsArePositiveError <- function(coeff){
	if (length(coeff)==0){
        return(TRUE)
	}
	
	if ( !(all(coeff>0)) ){
        return(TRUE)
	}
    return(FALSE)
}

getCoeffError <- function(coeff){
	if (length(coeff)==0){
		return("empty coefficient vector.")
	}
	
	if ( !(all(coeff>0)) ){
		return("not all coefficients > 0.")
	}
    return("unknown error.")
}


#ensure the x-values are all positive
checkXvaluesArePositiveError <- function(x){
	if (length(x)==0){
        return(TRUE)
	}
	
	if ( !(all(x>0)) ){
        return(TRUE)
	}
    return(FALSE)
}

getXvaluesError <- function(x){
	if (length(x)==0){
		return("empty x vector.")
	}
	
	if ( !(all(x>0)) ){
		return("not all x-values > 0.")
	}
    return("unknown error.")
}
#' @importFrom stats as.formula
#' @importFrom data.table as.data.table dcast.data.table setorderv
#' @importFrom htmltools htmlEscape
shape_as_series <- function(x){
  dataset <- as.data.table(x$data)
  dataset <- setorderv(dataset, c(x$x, x$group) )

  if( !is.null(x$group)){
    dataset[[x$group]] <- htmlEscape(dataset[[x$group]])
    form_str <- sprintf("%s ~ %s", x$x, x$group)
    dataset <- dcast.data.table(dataset, formula = as.formula(form_str),
                                fun.aggregate = function(x) {x},
                                fill = NA, value.var = x$y )
  } else {
    dataset <- dataset[, c(x$x, x$y), with = FALSE ]
  }
  as.data.frame(dataset)
}



fmt_name <- function( x ){

  if( inherits(x, "Date") )
    "date_fmt"
  else if( is.factor(x) || is.character(x) )
    "str_fmt"
  else if( is.integer(x) )
    "integer_fmt"
  else if( is.double(x) )
    "double_fmt"
  else stop("unknow type of data")

  x
}

serie_builtin_class <- function( x ){

  if( inherits(x, "Date") )
    str_ref
  else if( is.factor(x) || is.character(x) )
    str_ref
  else if( is.integer(x) )
    num_ref
  else if( is.double(x) )
    num_ref
  else stop("unknow type of data")
}

is_valid_color = function(x) {
  sapply(x, function( x ) {
    tryCatch( is.matrix( col2rgb( x ) ), error = function( e ) FALSE )
  })
}

pretty_num_axes <- function(x){
  range_x <- pretty(x$data[[x$x]])
  range_y <- pretty(x$data[[x$y]])
  x <- chart_ax_x(x, limit_min = range_x[1], limit_max = range_x[length(range_x)])
  x <- chart_ax_y(x, limit_min = range_y[1], limit_max = range_y[length(range_y)])
  x
}
ff <- function(fun, col) {

        ## Create function filter as string for filtering values
        paste0(fun, "(", col, ")")


}

# pct <- function(numerator, denominator, decimals = 2) {
#
#         p <- format(round((numerator/denominator) * 100, decimals), nsmall=decimals)
#         p
# }

validate.level.criteria <- function(level.criteria = NULL) {

      # cannot be NULL if there is one or more columns needing it
      if(is.null(level.criteria)) {
        stop("level.criteria cannot be NULL when there are columns in node.levels ",
                    "that require criteria specifications.")
      }

      if(!inherits(level.criteria,"data.frame")) {
        # must be a df
        stop("level.criteria must be a data.frame")
      }

      if(ncol(level.criteria) != 4) {
        # must have 4 cols (col, oper, val, label)
        stop("The level.criteria data.frame requires 4 columns that contain: ",
             "the column name, an operator, a value, and a node title for that criteria condition")
      }

}
# Key value iteration
# 
# Create a list with `k` and `v` elements useful for iteration
# 
# @param x object such as vector or list to separate into key value pairs
# @param ... additional args
# 
# @details 
# 
# No magic here, just something simple to convert `x` into a list of 
# lists. Each element of `x` is broken into a list with elements `k` 
# (key) and `v` (value). See examples.
#
# For many cases, key-value iteration can be done with `*apply` or
# `paste` functions. This is made to be explicit and work on a variery of
# objects.  
# 
# @references 
# * [SO: for-loop-in-r-with-key-value](http://stackoverflow.com/questions/18572921/for-loop-in-r-with-key-value)
# * [SO: iterate-over-key-value-pair-from-a-list](http://stackoverflow.com/questions/4500106/iterate-over-key-value-pair-from-a-list)
# 
# @return  
# A named list of list; each element of `x` becomes a one element list 
# with elements `k` and `v` representing the keys and values
# 
# @author
# This function is taken from the *kv* package and is used with permission.
#   
# @examples 
# 
#   # Lists
#   li <- list(a=1,b=2,c=3) 
#   kv(li)
# 
#   for( kv in kv(li) )
#     cat( kv$k, ":", kv$v, "\n")
# 
# 
#   # vectors 
#   v <- c(a=1, b=2, c=3 )
#   kv(li)
# 
#   for( kv in kv(li) )
#     cat( kv$k, ":", kv$v, "\n")
# 
# @md

kv <- function(x, ...) UseMethod('kv')

# @export
# @rdname kv

kv.default <- function(x) { 
  kv <- list() 
  for( i in 1:length(x) ) { 
    kv[[i]] = list( k=names(x)[[i]], v=x[[i]] )  
  }
  names(kv)=names(x)  
  return(kv)
}



# @author decision patterns / christopher brown
# Taken from the base.tools package with permission 
qw <- function (...) 
  as.character(match.call())[-1]


# mode of a object
# 
# @keywords internal
# @author decision patterns / christopher brown 
# Taken from the dimensional package with permission  
# 

most_freq <- function (x, na.action = na.pass) 
  as(names(which.max(table(na.action(x), useNA = "always"))), class(x))
# patch over an issue with trailing separators on Windows
file.exists <- function(...) {
  x=unlist(pairlist(...), use.names = FALSE)
  if (.Platform$OS == "windows") {
    x=sub("[/\\]$","", x)
  }
  base::file.exists(x)
}
## https://gist.github.com/mdsumner/c086a5005c59373f4965fa6afd0d5a7c#gistcomment-2132051
fast_tibble <- function(x) {
  stopifnot(length(unique(unlist(lapply(x, length)))) == 1L)
  structure(x, class = c("tbl_df", "tbl", "data.frame"), row.names = as.character(seq_along(x[[1]])))
}
# use with caution!  this will cause problems if a ragged list is given ...
faster_as_tibble <- function(x) {
  ## stopifnot(length(unique(lengths(x))) == 1L)
  
  structure(x, class = c("tbl_df", "tbl", "data.frame"), row.names = as.integer(seq_along(x[[1]])))
}

split_fast_tibble <- function (x, f, drop = FALSE, ...) 
  lapply(split(x = seq_len(nrow(x)), f = f,  ...), 
         function(ind) faster_as_tibble(lapply(x, "[", ind)))

we_are_raady <- function() {
  fp <- getOption("default.datadir")
  #print(fp)
  stat <- FALSE
  if (!is.null(fp) && file.exists(file.path(fp, "data"))) stat <- TRUE
  stat
}
#' cache_path
#'
#' Return path to OS agnostic cache location specified by the rappdirs package
#'
#' @export
cache_path <- function() paste0(rappdirs::user_data_dir(
  appname   = "NES",
  appauthor = "NES"), .Platform$file.sep)

temp_path <- function() tempdir()

get_if_not_exists <- function(id, target, versioned_path){
  if(all(!file.exists(unlist(target)))){
    cn <- dataone::CNode("PROD")
    mn <- dataone::getMNode(cn, "urn:node:KNB")

    dt <- dataone::getPackage(mn, paste0("resourceMap_", id))
    td <- tempdir()
    unzip(dt, exdir = td)
    unzip(list.files(td,
                     recursive = TRUE, pattern = "NES",
                     include.dirs = TRUE, full.names = TRUE),
          exdir = versioned_path)
  }else{
    message(paste0("A local copy of the NES data already exists at one of: ",
                   paste(unlist(target, use.names = FALSE), collapse = " ")))
  }
}

stop_if_not_exists <- function(src_path) {
  if(!file.exists(src_path)){
    stop(paste0("Dataset not found at: ", src_path,
          "\n Try running the appropriate `get*` and/or `compile` commands."))
  }
}

get_version_list <- function(...){
  list.files(cache_path(), pattern = ".rds$", ...)
}
#' Exit R Without Saving
#'
#' Exit R without saving workspace, using the ubiquitous UNIX syntax.
#'
#' @details This function is merely a call to \code{q("no")}.
#'
#' @export

exit <- function() q("no")


#' View HTML Version of Help Files
#'
#' View the HTML version of a help file while running R from the terminal.
#'
#' @param ... Help topics.
#'
#' @details
#' Calls function \code{\link[utils]{help}} using argument \code{htmlhelp=TRUE}.
#'
#' @export
#'
#' @examples
#' \dontrun{hweb(read.table)}
#'
#' @seealso
#' \code{\link[utils]{help}}, \code{\link[utils]{help.start}}

hweb <- function(...) {
    utils::help(..., help_type = "html")
}


#' Clear the Current Screen/Buffer
#'
#' Clear the screen with a call to \code{\link[base]{system}} and \code{clear}.
#'
#' @details This function is merely a call to \code{system("clear")}
#'
#' @export
#'
#' @examples
#' \dontrun{system("clear")}

clear <- function() system("clear")


#' Open a File
#'
#' Open a file using \code{\link[base]{system}} and \code{open}.
#'
#' @param file File name (as character string).
#'
#' @details Open files from R by using the default operating system program.
#'
#' @export
#'
#' @examples
#' \dontrun{openfile("myplot.pdf")}

openfile <- function(file) {
    system( paste("open", file) )
}
parse.formula <- function (formula, ...) {
  op <- formula[[1]]
  condition <- NULL
  if (length(formula) == 2) {
    rhs <- formula[[2]]
    lhs <- NULL
  }
  else if (length(formula) == 3) {
    rhs <- formula[[3]]
    lhs <- formula[[2]]
  }
  else {
    stop("Invalid formula type.")
  }
  if (inherits(rhs, "call") && rhs[[1]] == "|") {
    condition <- rhs[[3]]
    rhs <- rhs[[2]]
  }

list(op = op, lhs = lhs, rhs = rhs, condition = condition)
}

#'@importFrom graphics polygon
addpoly <- function(x,y1,y2,col="#BEBEBEB3",...){
  ii <- order(x)
  y1 <- y1[ii]
  y2 <- y2[ii]
  x <- x[ii]
  polygon(c(x,rev(x)), c(y1, rev(y2)), col=col, border=NA,...)
}

recycle <- function(x,n){
  len <- length(x)
  rep(x, ceiling(n/len))[1:n]
}

set_cols <- function(cols1, cols2, pal){

  if(is.null(cols1))cols1 <- cols2
  if(is.null(cols2))cols2 <- cols1
  if(is.null(cols1) && is.null(cols2)){
    cols1 <- cols2 <- pal
  }
  return(list(cols1=cols1, cols2=cols2))
}


fitgam <- function(X,Y,dfr, k=-1, R=NULL){
  dfr$Y <- dfr[,Y]
  dfr$X <- dfr[,X]
  if(!is.null(R)){
    dfr$R <- dfr[,R]
    model <- 2
  } else model <- 1

  dfr <- droplevels(dfr, except=which(sapply(dfr, is.ordered)))

  if(model ==1){
    g <- gam(Y ~ s(X, k=k), data=dfr)
  }
  if(model ==2){
    g <- gamm(Y ~ s(X, k=k), random = list(R=~1), data=dfr)
  }

  return(g)
}
#' @importFrom nlstools confint2
#' @export
nlstools::confint2

#' @importFrom dplyr %>%
#' @export
dplyr::`%>%`
# importFrom("graphics", "abline", "layout", "legend", "lines", "par", "plot", "plot.new")
# importFrom("stats", "IQR", "as.formula", "dist", "fft", "lm", "median", "rnorm", "runif", "sd", "ts")
#' @importFrom graphics abline layout legend lines par plot plot.new
#' @importFrom stats IQR as.formula dist fft lm median rnorm runif sd ts
NULL

vectorizePar = function(par, N, default=1:N){
  if (is.null(par)) par=default
  if (length(par) < N) par=rep(par,length.out=N)
  par
}
                        

propagateTakensAttr = function(x, takens){
  attr(x, "id") = attr(takens,"id")
  attr(x, "time.lag") = attr(takens, "time.lag")
  attr(x, "embedding.dim") = attr(takens, "embedding.dim")
  x
}
## Function to check if x is of good dimension
f.error.multivariate = function(x){
  if (!is.vector(x) && dim(x)[2] != 1) {
    stop("this function only handle univariate time-series")
  }
}

## Function to convert nse type into sandwich type
f.type.sandwich = function(type.in) {
  type.in = type.in[1]
  if (type.in == "bartlett") {
    type.out = "Bartlett"
  } else if (type.in == "parzen") {
    type.out = "Parzen"
  } else if (type.in == "tukey") {
    type.out = "Tukey-Hanning"
  } else if (type.in == "qs") {
    type.out = "Quadratic Spectral"
  } else if (type.in == "trunc") {
    type.out = "Truncated" 
  } else {
    stop("Invalid type : must be one of c('bartlett', 'parzen', 'tukey', 'qs', 'trunc')")
  }
  return(type.out)
}
## weighted histogram

whist = function(x, w=1, breaks="Sturges", plot=TRUE, freq=NULL, 
                 xlim=NULL, ylim=NULL, xlab="Data", ylab=NULL, main=NULL,
                 add=FALSE, col=NULL, border=NULL, lwd=1, ...) {
  r = hist(x, breaks=breaks, plot=FALSE)
  breaks = r$breaks
  i = cut(x, breaks, include.lowest=TRUE)
  f = tapply(rep(w,len=length(i)), i, sum)            # frequency
  f[is.na(f)] = 0
  dimnames(f)[[1]] = NULL
  d = f / sum(f) / (breaks[2] - breaks[1])            # density
  if(! is.null(freq) && ! freq) {
    y = d
    if(is.null(ylab)) ylab = "Density"
  }
  else {
    y = f
    if(is.null(ylab)) ylab = "Frequency"
  }
  ny = length(y)
  if (is.null(xlim)) xlim = range(breaks)
  if(is.null(ylim)) ylim = range(0, y, finite=TRUE)
  else {
    ymax = max(y)
    ylim = c(0, pmin(pmax(ymax, max(ylim)), 2*ymax))
  }
  if(plot) {
    if(!add) plot(r$mids, y, xlim=xlim, ylim=ylim, type="n", frame.plot=FALSE,
                  xlab=xlab, ylab=ylab, main=main, ...)
    rect(breaks[-(ny+1)], 0, breaks[-1], y, col=col, border=border, lwd=lwd)
    lines(range(breaks), c(0,0), col=border)
  }
  else list(breaks=breaks, counts=f, density=d,
            mids=breaks[-(ny+1)] + diff(breaks) * .5)
}
comparefilelist<-function(files,files2)
  {
  w<-unlist(lapply(files,cfl.helper,files2))
  return(files[!w])
}
  
cfl.helper<-function(file, files2)
{
  return(any(file==substr(files2,1,str_length(file))))
}

find.mode<-function(x)
{
  d<-density(x)
  return(d$x[which(d$y==max(d$y))[1]])
}
extract_digit <- function(x, n) x %/% 10^(n-1) %% 10

strip_numeric <- function(x) {
  x <- as.character(x)
  lx <- Map(function(ix) substr(x, ix, ix), seq_len(nchar(x)))
  as.integer(unlist(lx))
}


#' @export
#' @rdname is.valid
is.valid <- function(x) UseMethod('is.valid', x)
## Hijack a function
## see: http://stackoverflow.com/a/25366322/1000343
hijack <- function(FUN, ...){

    .FUN <- FUN

    args <- list(...)
    invisible(lapply(seq_along(args), function(i) {
        formals(.FUN)[[names(args)[i]]] <<- args[[i]]
    }))

    .FUN
}


## Hijack a function
functionize <- function(FUN, ...){

    function(...){
        hijack(FUN, ...)
    }
}

## remove NA elements
rm_na <- function(x) {
    x[!is.na(x)]
}


## determine if month char vector is month, month_abbreviated, or other (NA)
check_month_type <- function(x, threshold = .6, ...){
    if (mean(as.character(rm_na(x)) %in% mnthqrt) > threshold) {
        return('month')
    }
    if (mean(as.character(rm_na(x)) %in% mnthqrt2) > threshold) {
        return('month_abbreviated')
    }
    return(NA)
}

mnthqrt <- month.name
names(mnthqrt) <- rep(1:4, each = 3)

mnthqrt2 <- month.abb
names(mnthqrt2) <- rep(1:4, each = 3)

mnthqrt3 <- 1:12
names(mnthqrt3) <- rep(1:4, each = 3)
#' Utility function that generates file paths
#' @description Take in arguments common to all three functions 
#' (e.g. years, months, types) as well as the stem of the URL and 
#' return the matched file paths.
#' @inheritParams etl_extract.etl_nyctaxi
#' @param path path to desired file
#' @export
#' @examples 
#' get_file_path(2017, 1:6, "yellow", "~/")
#' 

get_file_path <- function(years, months, types, path) {
  
  get_dates <- function(types, years, months) {
    valid_year_month(years, months) %>%
      mutate(type = types)
  }
  
  lapply(types, get_dates, years, months) %>%
    bind_rows() %>%
    mutate_(src = ~file.path(path, paste0(type, "_tripdata_", year, "-", 
                        stringr::str_pad(month, 2, "left", "0"), ".csv")))
}
#
#  Copyright (C) 2005-2008 Friedrich Leisch

MClapply <- function(X, FUN, multicore=TRUE, ...)
{
    if(inherits(multicore, "cluster"))
        parLapply(multicore, X, FUN)
    else if(multicore)
        mclapply(X, FUN, ...)
    else
        lapply(X, FUN, ...)
}
has_names <- function(x) {
  nms <- names(x)
  if (is.null(nms)) {
    rep(FALSE, length(x))
  } else {
    !(is.na(nms) | nms == "")
  }
}

`%||%` <- function(x, y) if (is.null(x)) y else x

string_values <- function(x) {

  # TODO: Throw a condition object that can be caught for debugging purposes
  x <- tryCatch(x, error = function(x) "")
  unique(x[nzchar(x)])
}

# version of iconv that respects input Encoding, which bare iconv does not.
enc2iconv <- function(x, to, ...) {
  encodings <- Encoding(x)
  for (enc in unique(encodings)) {
    if (enc == to) {
      next
    }
    current <- enc == encodings
    if (enc == "unknown") {
      enc <- ""
    }
    x[current] <- iconv(x[current], from = enc, to = to, ...)
  }
  x
}

choices_rd <- function(x) {
  paste0(collapse = ", ", paste0("\\sQuote{", x, "}"))
}

lengths <- function(x) {
  vapply(x, length, integer(1))
}
fs <- function() {
  x <- rep("  ")
  return(x)
}

fg <- function(x, w) {
  z <- as.character(x)
  y <- format(z, width = w, justify = "right")
  return(y)
}

fl <- function(x, w) {
  x <- as.character(x)
  ret <- format(x, width = w, justify = "left")
  return(ret)
}

fc <- function(x, w) {
  x <- as.character(x)
  ret <- format(x, width = w, justify = "centre")
  return(ret)
}

fw <- function(x, w) {
  z <- format(as.character(x), width = w, justify = "right")
  return(z)
}

formatter_t <- function(x, w) {
  ret <- format(x, width = w, justify = "centre")
  return(ret)
}

formatter_n <- function(x, w) {
  ret <- format(x, nsmall = 3)
  ret1 <- format(ret, width = w, justify = "centre")
  return(ret1)
}

format_cil <- function(x, w) {
  ret <- format(x, nsmall = 3)
  ret1 <- format(ret, width = w, justify = "centre")
  return(ret1)
}

format_ciu <- function(x, w) {
  ret <- format(x, nsmall = 3)
  ret1 <- format(ret, width = w, justify = "centre")
  return(ret1)
}

formats_t <- function() {
  x <- rep("  ")
  return(x)
}

#' Model data
#'
#' Returns the data used in the model.
#'
#' @param model An object of class \code{lm}.
#'
#' @noRd
#'
mod_sel_data <- function(model) {

  eval(model$call$data)

}

l <- function(x) {
  x <- as.character(x)
  k <- grep("\\$", x)
  if (length(k) == 1) {
    temp <- strsplit(x, "\\$")
    out <- temp[[1]][2]
  } else {
    out <- x
  }
  return(out)
}
`%din%` <- function(x, y) {
    by <- intersect(names(x), names(y))
    nx <- nrow(x <- as.data.frame(x))
    ny <- nrow(y <- as.data.frame(y))
    bx <- x[,by,drop=FALSE]
    by <- y[,by,drop=FALSE]
    names(bx) = names(by) <- paste("V", seq_len(ncol(bx)), sep="")
    bz <- do.call(paste, c(rbind(bx, by), sep="\r"))
    bx <- bz[seq_len(nx)]
    by <- bz[nx + seq_len(ny)]
    comm <- match(bx, by, 0)
    x[comm > 0,]
}

na.count <- function(X, margin, fraction=TRUE) {
    result <- apply(is.na(X), margin, sum)
    if (fraction) {
        result <- result / prod(dim(X)[-margin])
    }
    result
}

re.match <- function(pattern, x, ...) {
    do.call(rbind, regmatches(x, regexec(pattern, x, ...)))
}
read_tag_dictionary <-
function(dict) {
    it <- dict$iterator()
    tags <- words <- list()
    while(it$hasNext()) {
        w <- .jcall(it, "Ljava/lang/Object;", "next")
        words <- c(words, list(.jsimplify(w)))
        tags <- c(tags, list(dict$getTags(w)))
    }
    names(tags) <- unlist(words)
    tags
}
rotation.angle <- function(x) {
    x <- rotmatrix(x)@x
    apply(x,3,function(A) acos((sum(diag(A)) - 1)/2))
}

rotation.distance <- function(x, y)
{
    	x <- rotmatrix(x)@x
    	y <- rotmatrix(y)@x
    	sapply(1:dim(x)[3],
	    function(i) { 
	   	trace <- sum(x[,,i] * y[,,i])
		acos((trace - 1)/2)
       	    })
}

nearest.orthog <- function(x)
{
    d <- dim(x)
    if (length(d) < 3) d <- c(d,1)
    a <- array(x, d)
    array(apply(a,3,function(amat) {
	    sva <- La.svd(amat)
	    sva$u %*% sva$vt
       	 }),dim(a))
}

nearest.SO3 <- function(x)
{
    d <- dim(x)
    if (length(d) < 3) d <- c(d,1)
    a <- array(x, d)
    rotmatrix(array(apply(a,3,function(amat) {
	    sva <- La.svd(amat)
	    signs <- rep(1,length(sva$d))
	    if (det(amat) < 0) signs[which.min(sva$d)] <- -1
	    sva$u %*% diag(signs) %*% sva$vt
        }),dim(a)))
}
#' Wrap a Function in a Try Statement
#'
#' Function factory that generates versions of functions wrapped in \code{try}.
#'
#' @param fun A \code{function} to be wrapped in a \code{try} statement.
#' @param ... Additional arguments passed to the previous argument \code{fun}.
#'
#' @export
#
wrap_in_try <- function(fun, ...) {
  wrapped <- function(...)
    try({
      fun(...)
    }, silent = TRUE)
  return(wrapped)
}

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

#' Build a Fold Object from a Fold Vector
#'
#' For V-fold type cross-validation. This takes a fold vector (validation set
#' IDs) and builds a fold object for fold V.
#'
#' @family fold generation functions
#'
#' @param v An identifier of the fold in which observations fall for CV.
#' @param folds A vector of the fold status for each observation for CV.
#'
#' @export
#
fold_from_foldvec <- function(v, folds) {
  training_set <- which(folds != v)
  validation_set <- which(folds == v)
  make_fold(v, training_set, validation_set)
}

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

#' Build a Fold Vector from a Fold Object
#'
#' For V-fold type cross-validation. This takes a fold object and returns a fold
#' vector (validation set IDs) for use with other tools like \code{cv.glmnet}.
#'
#' @family fold generation functions
#'
#' @param folds A \code{fold} object as produced by \code{make_folds}, from
#'  which a \code{numeric} vector of the validation set fold IDs are returned.
#'
#' @export
#
folds2foldvec <- function(folds) {
  fold_vec <- lapply(folds, function(fold) {
    validation()
  })
  len <- sapply(fold_vec, length)
  nums <- rep(seq_along(fold_vec), len)
  fold_index <- unlist(fold_vec)
  fold_id <- nums[order(fold_index)]
  return(fold_id)
}
list_to_df <- function(input){
  if(!length(input)){
    return(NA)
  }
  input <- unlist(input)
  new_names <- unique(names(input))
  output = vector("list", length(new_names))

  # I cannot believe I am using a for loop please nobody judge me
  for(i in seq_along(new_names)){
    output[[i]] <- unname(input[names(input) == new_names[i]])
  }
  output <- as.data.frame(output, stringsAsFactors = FALSE)
  names(output) <- new_names
  return(output)
}

clean_license <- function(license){
  return(list(
    id = license$id,
    identifiers = list_to_df(license$identifiers),
    links = list_to_df(license$links),
    name = license$name,
    other_names = ifelse(length(license$other_names), license$other_names, NA),
    superseded_by = ifelse(is.null(license$superseded_by), NA, license$superseded_by),
    keywords = unname(unlist(license$keywords)),
    text = list_to_df(license$text)
  ))
}

#'@importFrom httr GET stop_for_status user_agent content
query_osi <- function(params, ...){
  results <- httr::GET(paste0("https://api.opensource.org/", params),
                       httr::user_agent("R API connector - https://www.github.com/Ironholds/osi"),
                       ...)
  httr::stop_for_status(results)
  return(httr::content(results))
}

query_other <- function(url, ...){
  results <- httr::GET(url,
                       httr::user_agent("R API connector - https://www.github.com/Ironholds/osi"),
                       ...)
  httr::stop_for_status(results)
  return(suppressWarnings({httr::content(results, as = "text", encoding = "UTF-8")}))
}
#' @importFrom stats pnorm pt
#' @importFrom stats coefficients df.residual fitted.values
#' @importFrom stats model.matrix vcov AIC
NULL

#' @importFrom utils tail
NULL

#' @importFrom sandwich sandwich
NULL


#' @importFrom magrittr %>%
NULL



lazy_rbind <- function(a, b, fill = NA)
{
  if (is.null(a)) return(b)
  if (is.null(b)) return(a)

  vars <- setdiff(names(b), names(a))
  for (j in vars) a[[j]] <- fill
  vars <- setdiff(names(a), names(b))
  for (j in vars) b[[j]] <- fill

  b <- b[names(a)]
  rbind(a, b)
}



make_unique <- function(x)
{
  stopifnot(is.character(x))
  while (TRUE)
  {
    flg <- duplicated(x)
    if (!any(flg)) break

    i <- which(flg)[1]
    suf <- 2
    while (TRUE)
    {
      a <- paste(x[i], suf, sep = '_')
      if (!(a %in% x)) {
        x[i] <- a
        break
      }
      suf <- suf + 1
    }
  }
  x
}



unfactor_df <- function(x)
{
  stopifnot(is.data.frame(x))
  for (j in seq_along(x))
  {
    if (is.factor(x[[j]])) x[[j]] <- as.character(x[[j]])
  }
  x
}




get_not_displayed <- function(displayed, ...)
{
  # returns stats names not to display
  out <- .not_displayed_default %>% unlist()

  displayed <- c(displayed, list(...))
  for (i in seq_along(displayed))
  {
    v <- displayed[[i]]
    if (is.logical(v) || !is.na(v)) {
      if (!v) {
        out <- union(out, names(displayed)[i])
      } else {
        out <- setdiff(out, names(displayed)[i])
      }
    }
  }
  out
}


replace_duplicate <- function(x, by = '')
{
  x[duplicated(x)] <- by
  x
}
# If a is null, then b
if_null <- function(a, b) {
  if (!is.null(a)) {
    a
  } else {
    b
  }
}

str_replace <- function(x, pattern, replacement) {
  gsub(pattern, replacement, x)
}
addAggInfo = function(W, aggInfoType=NULL, sizeKeepingMethod=NULL)
{
  if (!is.null(aggInfoType))
  {
    if (is.null(sizeKeepingMethod) || sizeKeepingMethod == 'splitTrainEvaluate' || sizeKeepingMethod == 'penalty')
    {
      W = cbindAggInfo(W, aggInfoType)
    }
    else
    {
      stop('addAggInfo error')
    }
  }
  
  return(W)
}


cbindAggInfo = function(W, aggInfoType)
{
  # Adding aggregated information within the conditioning set
  
  aggInfo = which(aggInfoType==c('none','meanAll','meanPairwise'),arr.ind=TRUE)
  if (ncol(W)>1)
  {
    if (aggInfo==2)
    {
      xx = as.data.frame(rowMeans(W))
      names(xx) = paste("Mean(", paste(names(W),collapse=", "), ")", sep="")
      
      W = cbind(W,xx)
    }
    else
    {
      if (aggInfo==3)
      {
        xx = as.data.frame(combn(ncol(W), 2L, function(x) rowMeans(W[,x])))
        names(xx) = combn(names(W),2, function(x) paste("Mean(",x[1],", ",x[2],")",sep=""))
        
        W = cbind(W,xx)
      }
    }
  }
  
  return(W);
}
extractSubTree = function(RVM, tree, copulaNumber, data)
{
  d <- dim(RVM$Matrix)[1]
  
  newMatrix = matrix(0,nrow=tree+1,ncol=tree+1)
  newFamily = matrix(0,nrow=tree+1,ncol=tree+1)
  newPar = matrix(0,nrow=tree+1,ncol=tree+1)
  newPar2 = matrix(0,nrow=tree+1,ncol=tree+1)
  
  newMatrix[,1] = RVM$Matrix[c(d-tree+1-copulaNumber,(d-tree+1):d),(d-tree+1-copulaNumber)]
  
  newFamily[2:(tree+1),1] = RVM$family[c((d-tree+1):d),(d-tree+1-copulaNumber)]
  newPar[2:(tree+1),1] = RVM$par[c((d-tree+1):d),(d-tree+1-copulaNumber)]
  newPar2[2:(tree+1),1] = RVM$par2[c((d-tree+1):d),(d-tree+1-copulaNumber)]
  
  m = RVM$MaxMat[(d-tree+1), (d-tree+1-copulaNumber)]
  for (k in 1:(tree-1))
  {
    newMatrix[(k+1):(tree+1),(k+1)] = RVM$Matrix[c((d - m + 1),(d-tree+k+1):d),(d - m + 1)]
    
    xx = (d-tree+k+1):d
    
    
    newFamily[(k+2):(tree+1),(k+1)] = RVM$family[xx,(d - m + 1)]
    newPar[(k+2):(tree+1),(k+1)] = RVM$par[xx,(d - m + 1)]
    newPar2[(k+2):(tree+1),(k+1)] = RVM$par2[xx,(d - m + 1)]
    
    m = RVM$MaxMat[(d-tree+k+1), (d - m + 1)]
  }
  newMatrix[(tree+1),(tree+1)] = setdiff(newMatrix[(1:(tree+1)),1],diag(newMatrix[(1:tree),(1:tree)]))
  
  xx = diag(newMatrix)
  newNames = RVM$names[xx[length(xx):1]]
  newData = data[,xx[length(xx):1]]
  
  if (max(newMatrix)>(tree+1))
  {
    for (i in 1:(tree+1))
    {
      if (!any(newMatrix == i))
      {
        xx = newMatrix[newMatrix>i]
        xx = min(xx)
        newMatrix[newMatrix==xx] = i
      }
    }
  }
  
  return(list(RVM=RVineMatrix(newMatrix,newFamily,newPar,newPar2,names=newNames),data=newData))
  
}
#' Count the number of missing landmarks in an array
#'
#'@param A An N x 3 x M array where N is the number of landmarks, 3 is the number of dimensions, and M is the number of specimens.
#'
#'@return A length n vector giving the number of missing landmarks for each specimen.
#'@export
#'@examples
#'
#'
#'
#'  A <- array(1:(3*6*7), dim = c(7, 3, 6))
#'  A[2, , 1] <- NA
#'  countMissing(A)

countMissing <- function(A){
  stopifnot(is.numeric(A), length(dim(A)) == 3, dim(A)[2] == 3)
  completeLandmarks(A)
  
  # Find landmarks with missing data
  miss <- apply(A, c(3, 1), function(x) any(is.na(x)))

  # Get counts for each specimen
  counts <- rowSums(miss)

  # How many at least one missing
  nIncomplete <- sum(counts > 0)

  # MAX
  whichMax <- which.max(counts)
  maxMissing <- max(counts)

  message('')
  message(paste(nIncomplete, 'specimens have missing data.'))
  message(paste('Max missing: specimen', whichMax, 'with', maxMissing, 'missing landmarks.\n'))
  
  return(counts)
  
}
.datetimeFrom <- function(x) {
  as.POSIXct(x, tz = "UTC")
}
# show message if OPTION show.info is TRUE
#  show.info ARGUMENT provides an immediate OVERRIDE to that option
showInfoMessage = function(msg, ..., show.info=NA) {
  if (ifelse(is.na(show.info), getPMOptShowInfo(), show.info))
    messagef(msg, ...)
}

showStartupMsg = function(mode, cpus, socket.hosts) {
  if (mode != MODE_LOCAL) {
    if (mode %in% c(MODE_MULTICORE, MODE_MPI) ||
      (mode == MODE_SOCKET && !is.na(cpus))) {
      showInfoMessage("Starting parallelization in mode=%s with cpus=%i.",
        mode, cpus)
    } else if (mode == MODE_SOCKET) {
      showInfoMessage("Starting parallelization in mode=%s on %i hosts.",
        mode, length(socket.hosts))
    } else if (mode == MODE_BATCHJOBS) {
      showInfoMessage("Starting parallelization in mode=%s-%s.",
        mode, BatchJobs::getConfig()$cluster.functions$name)
    }
  }
}

# either the option level is not set or it is and the level of parmap matches
isParallelizationLevel = function(level) {
  optlevel = getPMOptLevel()
  is.na(optlevel) || (!is.na(level) && level == optlevel)
}

exportToSlavePkgParallel = function(objname, objval) {
  # clusterExport is trash because of envir argument, we cannot easily export
  # stuff defined in the scope of an R function
  # cl = NULL is default cluster, pos=1 is always globalenv
  # I really hope the nextline does what I think in all cases...
  clusterCall(cl=NULL, assign, x=objname, value=objval, pos=1)
}
#' @noRd
paste0_stop <- function(...) stop(paste0(...), call. = FALSE)

#' @noRd
paste0_msg <- function(...) message(paste0(...))

#' @noRd
asrt <- function(expr, ...) if (!expr) paste0_stop(...)

#' @noRd
parse_resp <- function(resp) {
  j <- httr::content(resp, as = "text", encoding = "UTF-8")
  jsonlite::fromJSON(
    j, simplifyVector = TRUE, simplifyDataFrame = TRUE, simplifyMatrix = TRUE
  )
}

#' @noRd
format_num <- function(x) format(
    x, big.mark = ",", scientific = FALSE, trim = TRUE
  )

#' @noRd
validate_endpoint <- function(endpoint) {
  ok_ends <- get_endpoints()

  asrt(
    all(endpoint %in% ok_ends, length(endpoint) == 1),
    "endpoint must be one of the following: ", paste(ok_ends, collapse = ", ")
  )
}

#' @noRd
validate_groups <- function(groups) {
  ok_grps <- unique(fieldsdf$group)
  asrt(
    all(groups %in% ok_grps),
    "group must be one of the following: ", paste(ok_grps, collapse = ", ")
  )
}

#' @noRd
validate_pv_data <- function(data) {
  asrt(
    "pv_data_result" %in% class(data),
    "Wrong input type for data...See example for correct input type"
  )
}
get_machine_eps <- function()
{
    .Machine$double.eps
}
is.badval <- function(x)
{
	is.na(x) || is.nan(x) || is.infinite(x)
}

is.inty <- function(x)
{
	abs(x - round(x)) < 1e-10
}

is.zero <- function(x)
{
	abs(x) < 1e-10
}

is.negative <- function(x)
{
	x < 0
}

is.annoying <- function(x)
{
	length(x) != 1 || is.badval(x)
}

is.string <- function(x)
{
	if (!is.character(x) || is.annoying(x))
		FALSE
	else
		TRUE
}



check.is.string <- function(x, msg=NULL)
{
	if (!is.string(x))
	{
		if (is.null(msg))
		{
			nm <- deparse(substitute(x))
			stop(paste0("argument '", nm, "' must be a single string"), call.=FALSE)
		}
		else
			stop(msg, call.=FALSE)
	}
	
	invisible(TRUE)
}

check.is.posint <- function(x, msg=NULL)
{
	if (!is.numeric(x) || is.annoying(x) || !is.inty(x) || is.negative(x) || is.zero(x))
	{
		if (is.null(msg))
		{
			nm <- deparse(substitute(x))
			stop(paste0("argument '", nm, "' must be a positive integer"), call.=FALSE)
		}
		else
			stop(msg, call.=FALSE)
	}
	
	invisible(TRUE)
}

check.is.flag <- function(x, msg=NULL)
{
	if (!is.logical(x) || is.annoying(x))
	{
		if (is.null(msg))
		{
			nm <- deparse(substitute(x))
			stop(paste0("argument '", nm, "' must be TRUE or FALSE"), call.=FALSE)
		}
		else
			stop(msg, call.=FALSE)
	}
	
	invisible(TRUE)
}
.verifyLength <- function(length, warningMessage) {
  # If the length is zero, return an empty list with a warning message
  if (length <= 0) {
    warning(warningMessage)
    return(list())
  }
}

.isOSWindows <- function() {
  return(.Platform$OS.type == "windows")
}

.establishFifo <- function(description) {
  # Try to establish a fifo
  progressFifo <- fifo(description, open = "w+b", blocking = T)

  return(progressFifo)
}

.updateProgress <- function(length, progressFifo, mc.style, mc.substyle) {
  pb <- progressBar(0, length, style = mc.style, substyle = mc.substyle)
  setTxtProgressBar(pb, 0)
  progress <- 0
  hasError <- F

  while (progress < length) {
    progressUpdate <- readBin(progressFifo, "integer", n = 100)

    # Check if any warning or error in the update
    if (any(progressUpdate == -1)) {
      hasError <- T
      break()
    }

    progress <- progress + sum(progressUpdate)
    setTxtProgressBar(pb, progress)
  }

  # Print an line break to the stdout
  cat("\n")

  # Return error status
  return(hasError)
}
# Return end of annual date
year_end <- function(date) {
  as.Date(ISOdate(year(date),12,31))
}

# Return end of semiannual date
halfyear_end <- function(date) {
  day_lookup <- c(30,30,30,30,30,30,31,31,31,31,31,31)
  months <- (floor((month(date)-1)/6)+1)*6
  days <- day_lookup[months]
  as.Date(ISOdate(year(date),months,days))
}

# Return end of quarter date
quarter_end <- function(date) {
  day_lookup <- c(31,31,31,30,30,30,30,30,30,31,31,31)
  months <- (floor((month(date)-1)/3)+1)*3
  days <- day_lookup[months]
  as.Date(ISOdate(year(date),months,days))
}

# Return end of month date
month_end <- function(date) {
  day(date) <- days_in_month(date)
  date
}
remove_indent <- function(x, sel_element) {
  x_tmp <- x[sel_element == 3]
  blank_first <- sapply(seq_along(x_tmp), function(tt) x_tmp[[tt]][1] == '')
  x_tmp2 <- x_tmp[blank_first]
  x_tmp2 <- lapply(seq_along(x_tmp2), function(tt) x_tmp2[[tt]][-1])
  x_tmp[blank_first] <- x_tmp2
  x[sel_element == 3] <- x_tmp
  return(x)
}

collapse_columns <- function(x_list, lengths) {
  do.call('c', 
          do.call('c',
                  lapply(1:max(lengths), function(ii)
                    lapply(seq_along(x_list), function(xx) 
                      x_list[[xx]][ii]
                    ))
          )
  )
}
convert.cutpoint <- function(cutpoint, benefit.scores)
{
    if (is.character(cutpoint))
    {
        if (cutpoint == "median")
        {
            cutpoint <- median(benefit.scores, na.rm = TRUE)
        } else if (grepl("^quant[0-9]+$", cutpoint))
        {
            matches <- gregexpr('[0-9]+', cutpoint)
            qval    <- as.numeric(regmatches(cutpoint, matches)[[1]])
            if (qval >= 100 | qval < 1) stop("Invalid quantile value for cutpoint.")
            qval <- qval / 100
            cutpoint <- quantile(benefit.scores, probs = qval)
        } else
        {
            stop("Invalid cupoint supplied.")
        }
    } else if (is.numeric(cutpoint))
    {
        cutpoint <- cutpoint[1]
    } else
    {
        stop("Invalid value specified for cutpoint.")
    }
    cutpoint
}
#' @title Unpack an example
#' @description Examples are zipped to save disk space and prevent R complaining
#' while creating the package
#' @param which_one example number to use
#' @importFrom utils unzip
#' @export
use_example <- function(which_one = NULL) {
    if (is.null(which_one)) stop("an example number must be supplied")
    if (which_one == 1) unzip_this("3_pages_conference.zip")
    else stop("example not implemented")
}


unzip_this <- function(a_zip_file) {
    unzip(paste(system.file("extdata", package = "petro.One"),
                a_zip_file, sep = "/"))
}


expect_equal_scale <- function(object, expected, ..., tolerance_pct) {
    tolerance <- tolerance_pct
    scale <- object
    testthat::expect_equal(object, expected, tolerance, scale, check.attributes = TRUE)
}
util.geoco2gk <- function(x,y, meridian=4) {
	sy <- meridian
	rho <- 180 / pi
	e2 <- 0.0067192188
	c <- 6398786.849

	for(i in 1:length(x)) {
    		bf <- as.numeric(y[i]) / rho
    		g <- 111120.61962 * y[i] -15988.63853 * 
			sin(2 * bf) + 16.72995 * 
			sin(4 * bf) - 0.02178 * 
			sin(6 * bf) +0.00003 * 
			sin(8 * bf)
    		co <- cos(bf)
    		g2 <- e2 * (co^2)
    		g1 <- c / sqrt(1+g2)
    		t_mod <- sin(bf) / cos(bf)
    		dl <- x[i] - sy * 3
    		fa <- co * dl / rho
    		y[i] <- g + (fa^2) * t_mod * 
			g1 / 2 + (fa^4) * t_mod * 
			g1 * (5 - (t_mod^2) + 9 * g2) / 24
    		rm_mod <- fa * g1 + (fa^3) * g1 * 
			(1 - (t_mod^2) + g2) / 6 + (fa^5) * 
			g1 * (5 - 18 * (t_mod^6)) / 120
    		x[i] <- rm_mod + sy * 1000000 + 500000
	}

 	result <- cbind(x,y)
 	return(result)
}
util.isLeapYear <- function(year){
	res <- vector(mode="logical", length=length(year))
	res <- rep(FALSE, length(res))
	res[which((year %% 4) == 0)] <- TRUE
	res[which((year %% 100) == 0)] <- FALSE
	res[which((year %% 400) == 0)] <- TRUE
	return(res)
}
# phylotate
# Copyright (c) 2017 Daniel Beer
#
# Permission is hereby granted, free of charge, to any person obtaining a
# copy of this software and associated documentation files (the
# "Software"), to deal in the Software without restriction, including
# without limitation the rights to use, copy, modify, merge, publish,
# distribute, sublicense, and/or sell copies of the Software, and to
# permit persons to whom the Software is furnished to do so, subject to
# the following conditions:
#
# The above copyright notice and this permission notice shall be included
# in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
# OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
# IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
# CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
# TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
# SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

########################################################################
# Given a boolean vector, return an integer vector of the same size
# where each element maps its index to the location of the previous/next
# TRUE item in the original vector. For example:
#
#    Index:      1     2     3     4      5     6     7     8     9
#    Input:  FALSE FALSE FALSE  TRUE  FALSE FALSE  TRUE FALSE FALSE
#    Prev:      NA    NA    NA     4      4     4     7     7     7
#    Next:       4     4     4     4      7     7     7    NA    NA
########################################################################

index.of.prev <- function (m) { c(NA, which(m))[cumsum(m) + 1] }
index.of.next <- function (m) { length(m) - rev(index.of.prev(rev(m))) + 1 }
vlapply <- function(X, FUN, ...) {
  vapply(X, FUN, logical(1), ...)
}
viapply <- function(X, FUN, ...) {
  vapply(X, FUN, integer(1), ...)
}
vnapply <- function(X, FUN, ...) {
  vapply(X, FUN, numeric(1), ...)
}
vcapply <- function(X, FUN, ...) {
  vapply(X, FUN, character(1), ...)
}

pastec <- function(...) {
  paste(..., collapse=", ")
}
split_genus <- function(str) {
  str_split <- strsplit(str, "[_ ]+")
  vcapply(str_split, "[[", 1L)
}

## Ape's version is too slow; this is around 10x faster.
is_monophyletic <- function(phy, tips) {
  if (length(tips) == 1L) {
    TRUE
  } else {
    tips_i <- match(tips, phy$tip.label)
    mrca <- mrca_tipset(phy, tips_i)
    desc <- get_descendants(mrca, phy, tips.only=TRUE)
    all(desc %in% tips_i)
  }
}

is_monophyletic_group <- function(group, table, phy) {
  is_monophyletic(phy, phy$tip.label[table == group])
}

## Find the things that make a group non-monophyletic
find_paraphyletic <- function(group, table, phy) {
  tips <- phy$tip.label[table == group]
  if (length(tips) == 1L) {
    character(0)
  } else {
    tips_i <- match(tips, phy$tip.label)
    mrca <- mrca_tipset(phy, tips_i)
    desc <- get_descendants(mrca, phy, tips.only=TRUE)
    setdiff(table[desc], group)
  }
}

## Find the largest clade in phy that includes the tip species `tip`
## but does not include any species listed in the vector `exclude`.
find_exclusive_clade <- function(tip, exclude, phy) {
  i <- match(tip, phy$tip.label)
  if (is.na(i)) {
    character(0)
  } else {
    ret <- list(species=tip, node=i)
    exclude <- setdiff(exclude, tip)

    repeat {
      i_parent <- phy$edge[match(i, phy$edge[, 2]), 1]
      if (is.na(i_parent)) {
        ## Hit the root:
        return(ret)
      }
      desc <- get_descendants_names(i_parent, phy)
      if (any(desc %in% exclude)) {
        return(ret)
      }

      i <- i_parent
      ret <- list(species=desc, node=i)
    }
  }
}
#' @title age from birth and reference dates
#' @param birth.date Date of birth, either as a \code{Date} or something which
#'   will be converted to a \code{Date}
#' @param ref.date Date at which to calculate age, defaults to current date,
#'   either as a \code{Date} or something which will be converted to a
#'   \code{Date}
#' @param unit character of length, one of "year" or "day".
#' @return integer vector
#' @examples
#' age_from_dates("2014-11-08", "2014-12-31", unit = "day")
#' age_from_dates("1981-07-09", "2014-06-29", unit = "year")
#' @export
age_from_dates <- function(birth.date, ref.date = Sys.Date(),
                         unit = c("year", "day")) {
  unit <- match.arg(unit)
  birth.date <- as.Date(birth.date)
  ref.date <- as.Date(ref.date)
  pdt <- as.POSIXlt(c(birth.date, ref.date))

  years <- pdt$year[2] - pdt$year[1]
  months <- pdt$mon[2] - pdt$mon[1] # of year
  days <- pdt$mday[2] - pdt$mday[1] # of month
  year.correct <- (months + days / 32) < 0
  if (unit == "year")
    return(years - year.correct)  # not birthday yet this year

  as.integer(ref.date - birth.date) # days
}

# TODO: print class to show days to 30d, months to 24 months, then years
# automatically
cat_line <- function(...) {
  cat(..., "\n", sep = "")
}

str_trunc <- function(x, width) {
  if (is.infinite(width)) return(x)

  str_width <- utf8::utf8_width(crayon::strip_style(x), encode = FALSE)

  too_wide <- which(!is.na(x) & str_width > width)
  x[too_wide] <- paste0(crayon::col_substr(x[too_wide], 1, width - 1), get_ellipsis())

  x
}

check_sigfig <- function(x) {
  stopifnot(is.numeric(x), length(x) == 1)
  x <- as.integer(x)
  if (x < 1L) {
    stop("Must show at least one significant figure", call. = FALSE)
  }

  x
}

slice <- function(df, index) {
  df[index, , drop = FALSE]
}

get_ellipsis <- function() {
  cli::symbol$continue
}

is_latex_output <- function() {
  if (!("knitr" %in% loadedNamespaces())) return(FALSE)
  get("is_latex_output", asNamespace("knitr"))()
}

remove_as_is_class <- function(x) {
  if (all(class(x) == "AsIs")) return(unclass(x))
  class(x) <- setdiff(class(x), "AsIs")
  x
}
check_string <- function(x) {
  stopifnot(is.character(x), length(x) == 1)
}

`%+%` <- function(lhs, rhs) {
  check_string(lhs)
  check_string(rhs)
  paste0(lhs, rhs)
}

chr <- as.character

int <- as.integer
# compatibility for data.table functions
.datatable.aware <- TRUE

setnames <- `names<-`
setclass <- `class<-`

ndots <- function(dots) {
  any(nzchar(dots))
}

is.formula <- function(expr) {
  inherits(expr, "formula") || (is.call(expr) && expr[[1L]] == "~")
}

is.side_effect <- function(expr) {
  is.formula(expr) &&
    (length(expr) == 2L ||
        length(expr) == 3L &&
        Recall(expr[[2L]]))
}
highlightCode <- function(session, id) {
  session$sendCustomMessage("highlight-code", list(id = id))
}

rCodeContainer <- function(...) {
  code <- HTML(as.character(tags$code(class = "language-r", ...)))
  div(pre(code))
}

renderCode <- function(expr, env = parent.frame(), quoted = FALSE) {
  func <- NULL
  installExprFunction(expr, "func", env, quoted)
  markRenderFunction(textOutput, function() {
    paste(func(), collapse = "\n")
  })
}
#' Check whether a text value is present.
#'
#' \code{isTextValue} is a utility function returns TRUE only when a text value
#' is present.  NULL, NA, character(0) and "" all return FALSE.
#'
#' @param value The value to check.
#' @return TRUE if a non-blank text value is present.

isTextValue <- function(value) {
  if(is.null(value)) return(FALSE)
  l <- length(value)
  if(l==0) return(FALSE)
  else if(l==1) {
    if(is.na(value)) return(FALSE)
    if(nchar(value)==0) return(FALSE)
    else return(TRUE)
  }
  else {
    if(sum(nchar(value), na.rm=TRUE)==0) return(FALSE)
    else return(TRUE)
  }
}

#' Check whether a numeric value is present.
#'
#' \code{isNumericValue} is a utility function returns TRUE only when a numeric value
#' is present.  NULL, NA, numeric(0) and integer(0) all return FALSE.
#'
#' @param value The value to check.
#' @return TRUE if a numeric value is present.

isNumericValue <- function(value) {
  if(is.null(value)) return(FALSE)
  l <- length(value)
  if(l==0) return(FALSE)
  else {
    if(length(value[is.na(value)])>0) return(FALSE)
    if(is.numeric(value)) return(TRUE)
    else return(FALSE)
  }
}

#' Check whether a text value is present in another text value.
#'
#' \code{containsText} is a utility function returns TRUE if one text value is
#' present in another.  Case sensitive.  If textToSearch is a vector, returns
#' TRUE if any element contains textToFind.
#'
#' @param textToSearch The value to be searched.
#' @param textToFind The value to find.
#' @return TRUE if the textToFind value is found.

containsText <- function(textToSearch, textToFind) {
  if(!isTextValue(textToSearch)) return(FALSE)
  if(!isTextValue(textToFind)) return(FALSE)
  r <- regexpr(textToFind, textToSearch, fixed=TRUE)
  return((length(r[r!=-1]))>0)
}
`%||%` <- function(lhs, rhs) {
  if (!is.null(lhs)) { lhs } else { rhs }
}
Warning <- function(...)warning(..., call.=FALSE)
Stop <- function(...)stop(..., call.=FALSE)
#' Function to find marginal effects
#'
#' @noRd

me_one <- function(term1_, int_term_, fitted2_,
                   beta_hat, cov, ci_, obj_)
{
    if (!missing(int_term_)) {
        # Point estimates
        dy_dx <- beta_hat[term1_] + beta_hat[int_term_] * fitted2_

        # Standard error
        se_dy_dx <- sqrt(cov[term1_, term1_] +
                             fitted2_ ^ 2 * cov[int_term_, int_term_] +
                             2 * fitted2_ *cov[term1_, int_term_])
    }

    else if (missing(int_term_)) {
        fitted2_ <- 1
        # Point estimates
        dy_dx <- beta_hat[term1_]

        # Standard error
        all_b_se <- coef(summary(obj_))[, 'Std. Error']
        se_dy_dx <- all_b_se[term1_]
    }

    parts_temp <- data.frame(cbind(fitted2_, dy_dx, se_dy_dx))
    names(parts_temp) <- c('fitted2', names(parts_temp[-1]))
    return(parts_temp)
}
### utils.R  (2017-08)
###
###    Utility functions
###
### Copyright 2017-08 Ghislain DURIF
###
###
### This file is part of the `plsgenomics' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA


safeExp <- function(x) {
     if(x < -27) {
          return(0)
     } else if(x > 27) {
          return(1)
     } else {
          return(exp(x))
     }
}

safeExpMat <- function(X) {
     return(apply(X, c(1,2), safeExp))
}

safeSum <- function(x) {
     if(sum(x) == 0) {
          return(1E-7)
     } else {
          return(sum(x))
     }
}

softMax <- function(eta) {
     t(apply(safeExpMat(eta), 1, function(x) x/safeSum(x)))
}
#' Repeat a data frame n number of times and return as a single data frame
#' @noRd

df_repeat <- function(x, n) {
    do.call('rbind', replicate(n, x, simplify = FALSE))
}

#' Remove b-spline polynomial nameing
#' @noRd

bs_stripper <- function(x) {
    base_names <- gsub('^bs\\(', '', x)
    base_names <- gsub('\\)[1-9]$', '', base_names)
    base_names <- gsub(', degree = [1-9]', '', base_names)
    base_names <- unique(base_names)
    return(base_names)
}
## utils

"%||%" <- function(a, b) if(is.null(a)) b else a

.irreversible <- function(reason)
  stop("Reversal impossible due to ", reason, ".")
#' Determine if a vector is discrete.
#'
#' A discrete vector is a factor or a character vector
#'
#' @param x vector to test
#' @keywords internal
#' @export
#' @examples
#' is.discrete(1:10)
#' is.discrete(c("a", "b", "c"))
#' is.discrete(factor(c("a", "b", "c")))
is.discrete <- function(x) is.factor(x) || is.character(x) || is.logical(x)

#' Un-rowname.
#'
#' Strip rownames from an object
#'
#' @keywords internal
#' @param x data frame
#' @export
unrowname <- function(x) {
  rownames(x) <- NULL
  x
}

#' Function that always returns true.
#'
#' @param ... all input ignored
#' @return \code{TRUE}
#' @keywords internal
#' @seealso \code{\link{colwise}} which uses it
#' @export
true <- function(...) TRUE

#' Compact list.
#'
#' Remove all NULL entries from a list
#'
#' @param l list
#' @keywords manip internal
#' @export
compact <- function(l) Filter(Negate(is.null), l)

#' Number of unique values.
#'
#' Calculate number of unique values of a variable as efficiently as possible.
#'
#' @param x vector
#' @keywords internal
nunique <- function(x) {
  if (is.factor(x)) {
    length(levels(x))
  } else {
    length(unique(x))
  }
}

#' Check if a data frame is empty.
#'
#' Empty if it's null or it has 0 rows or columns
#'
#' @param df data frame to check
#' @keywords internal
#' @export
empty <- function(df) {
  (is.null(df) || nrow(df) == 0 || ncol(df) == 0)
}

#' Is a formula?
#' Checks if argument is a formula
#'
#' @keywords internal
#' @export
is.formula <- function(x) inherits(x, "formula")

"%||%" <- function(a, b) if (is.null(a)) b else a

.matrix_to_df <- function(.data) {
  cnames <- colnames(.data)
  if (is.null(cnames)) cnames <- rep("", ncol(.data))
  .data <- as.data.frame(.data, stringsAsFactors = FALSE)
  colnames(.data) <- cnames
  .data
}
# last modified 29 Mar 07 by J. Fox

binBvn <- function(rho, row.cuts, col.cuts, bins=4){  
    row.cuts <- if (missing(row.cuts)) c(-Inf, 1:(bins - 1)/bins, Inf) else  c(-Inf, row.cuts, Inf)
    col.cuts <- if (missing(col.cuts)) c(-Inf, 1:(bins - 1)/bins, Inf) else  c(-Inf, col.cuts, Inf)
    r <- length(row.cuts) - 1
    c <- length(col.cuts) - 1
    P <- matrix(0, r, c)
    R <- matrix(c(1, rho, rho, 1), 2, 2)
    for (i in 1:r){
        for (j in 1:c){
            P[i,j] <- mvtnorm::pmvnorm(lower=c(row.cuts[i], col.cuts[j]),
                            upper=c(row.cuts[i+1], col.cuts[j+1]),
                            corr=R)
            }
        }
    P
    }
    
chisq <- function(x, y, rho, row.cuts, col.cuts, zerotol=1e-6, bins=4){  
    if (missing(row.cuts)) row.cuts <- qnorm(1:(bins - 1)/bins)
    if (missing(col.cuts)) col.cuts <- qnorm(1:(bins - 1)/bins)
    P <- binBvn(rho, row.cuts, col.cuts, bins=bins)
    if (!is.factor(x)) x <- cut(scale(x), c(-Inf, row.cuts, Inf))
    if (!is.factor(y)) y <- cut(scale(y), c(-Inf, col.cuts, Inf))
    tab <- table(x, y)
    n <- sum(tab)
    2*sum(tab*log((tab + zerotol)/(P*n)))
    }

as.matrix.hetcor <- function(x, ...) x$correlations
## accumulate a la Abelson and Sussman.
accumulate <- function(f, init, x, right = TRUE) {
    if(length(x) == 0)
        return(init)
    f <- match.fun(f)
    if(right)
        f(x[[1]], Recall(f, init, x[-1], right = TRUE))
    else
        Recall(f, f(init, x[[1]]), x[-1], right = FALSE)
}
#' Object Pooling in R.
#'
#' Creates objects pools for various types of objects in R to
#' make it less computationally expensive to get a fetch and
#' release them.
#'
#' @name pool
#' @docType package
#' @import DBI
NULL

#' @import DBI
NULL

#' @import methods
NULL

#' @importFrom R6 R6Class
NULL

#' @importFrom later later
NULL

#' @importFrom dplyr db_analyze
#' @importFrom dplyr db_begin
#' @importFrom dplyr db_commit
#' @importFrom dplyr db_create_index
#' @importFrom dplyr db_create_indexes
#' @importFrom dplyr db_create_table
#' @importFrom dplyr db_data_type
#' @importFrom dplyr db_desc
#' @importFrom dplyr db_drop_table
#' @importFrom dplyr db_explain
#' @importFrom dplyr db_has_table
#' @importFrom dplyr db_insert_into
#' @importFrom dplyr db_list_tables
#' @importFrom dplyr db_query_fields
#' @importFrom dplyr db_query_rows
#' @importFrom dplyr db_rollback
#' @importFrom dplyr db_save_query
#' @importFrom dplyr db_write_table
#' @importFrom dplyr sql_escape_ident
#' @importFrom dplyr sql_escape_string
#' @importFrom dplyr sql_join
#' @importFrom dplyr sql_select
#' @importFrom dplyr sql_semi_join
#' @importFrom dplyr sql_subquery
#' @importFrom dplyr sql_translate_env
NULL

#' @importFrom dplyr tbl
#' @importFrom dplyr copy_to
NULL

#' @importFrom dbplyr db_collect
#' @importFrom dbplyr db_compute
#' @importFrom dbplyr db_copy_to
#' @importFrom dbplyr db_sql_render
#' @importFrom dbplyr sql_escape_logical
NULL
#' @importFrom utils head
#' @export
head.prediction <- function(x, ...) {
    head(`class<-`(x, "data.frame"), ...)
}

#' @importFrom utils tail
#' @export
tail.prediction <- function(x, ...) {
    tail(`class<-`(x, "data.frame"), ...)
}
create_strat_selection_plot = function(params, df) {
  ret = NULL
  if (length(unique(df$preference_effect)) > 1 && 
      length(unique(df$selection_effect)) == 1) {
    ret = ggplot2::ggplot(data=df, 
      ggplot2::aes_string(x="preference_effect", y="sample_size")) +
      ggplot2::geom_line() + ggplot2::xlab("Preference Effect") + 
      ggplot2::ylab("Sample Size")
  }
  else if (length(unique(df$preference_effect)) == 1 &&
           length(unique(df$selection_effect)) > 1) {
    ret = ggplot2::ggplot(data=df, 
      ggplot2::aes_string(x="selection_effect", y="sample_size")) +
      ggplot2::geom_line() + ggplot2::xlab("Selection Effect") + 
      ggplot2::ylab("Sample Size")
  }
  else if (length(unique(df$preference_effect)) > 1 &&
           length(unique(df$selection_effect)) > 1) {
    uss = length(unique(df$sample_size))
    ret=ggplot2::ggplot(data=df, 
      ggplot2::aes_string(x="preference_effect", y="selection_effect", 
      fill="sample_size"))+
      ggplot2::geom_tile() + ggplot2::xlab("Preference Effect") + 
      ggplot2::ylab("Selection Effect") +
      ggplot2::scale_fill_manual(values=rev(grDevices::heat.colors(uss)),
        guide=ggplot2::guide_legend(title="Sample Size"))
      #scale_fill_continuous(guide=guide_legend(title = "Sample Size")) 
  }
  ret
}

create_strat_selection_df = function(params) {
  df = data.frame(
    list(delta_pi=rep(params$delta_pi, each=length(params$delta_nu)),
         delta_nu=rep(params$delta_nu, times=length(params$delta_pi))))
  ss = rep(NA, nrow(df))
  for (i in 1:nrow(df)) {
    ss[i] = 
      ceiling(selection_sample_size(params$power, params$phi, params$sigma2, 
                    df$delta_pi[i], df$delta_nu[i], params$alpha,
                    params$theta, params$xi, params$num_strata))
  }
  df$sample_size = ss
  names(df) = c("preference_effect", "selection_effect", "sample_size")
  df     
}
# Preprocessor functions are adaptations from the RMarkdown package
# (https://github.com/rstudio/rmarkdown/blob/master/R/pdf_document.R)
# to ensure right geometry defaults in the absence of user specified values

pdf_pre_processor <- function(metadata, input_file, runtime, knit_meta, files_dir, output_dir) {
  args <- c()

  # Set margins if no other geometry options specified
  has_geometry <- function(text) {
    length(grep("^geometry:.*$", text)) > 0
  }
  if (!has_geometry(readLines(input_file, warn = FALSE)))
    args <- c(args
              , "--variable", "geometry:left=2.5in"
              , "--variable", "geometry:bottom=1.25in"
              , "--variable", "geometry:top=1.25in"
              , "--variable", "geometry:right=1in"
    )

  # Use APA6 CSL citations template if no other file is supplied
  has_csl <- function(text) {
    length(grep("^csl:.*$", text)) > 0
  }
  if (!has_csl(readLines(input_file, warn = FALSE))) {
    csl_template <- system.file("rmd", "apa6.csl", package = "prereg")
    if(csl_template == "") stop("No CSL template file found.")
    args <- c(args, c("--csl", rmarkdown::pandoc_path_arg(csl_template)))
  }

  args
}
is_interactive <- function() interactive()

is_terminal <- function() {
  isatty(stdin()) &&
    Sys.getenv("RSTUDIO") != 1 &&
    Sys.getenv("R_GUI_APP_VERSION") == "" &&
    .Platform$GUI != "Rgui" &&
    !identical(getOption("STERM"), "iESS") &&
    Sys.getenv("EMACS") != "t"
}
#' @importFrom assertthat assert_that is.string

`%s%` <- function(lhs, rhs) {
  assert_that(is.string(lhs))
  list(lhs) %>%
    c(as.list(rhs)) %>%
    do.call(what = sprintf)
}

`%+%` <- function(lhs, rhs) {
  paste0(lhs, rhs)
}

assert_diff_time <- function(x) {
  stopifnot(inherits(x, "difftime"))
}
check <- function(n) {
  is.int <- ((n %% 1) == 0)
  if (!is.int) stop("n should be an integer")
  
  is.pos <- (n > 0)
  if (!is.pos) stop("n should be positive")
  
  return()
}
#' @importFrom rlang sym
#'

case_id_ <- function(eventlog) sym(case_id(eventlog))
activity_id_ <- function(eventlog) sym(activity_id(eventlog))
activity_instance_id_ <- function(eventlog) sym(activity_instance_id(eventlog))
resource_id_ <- function(eventlog) sym(resource_id(eventlog))
timestamp_ <- function(eventlog) sym(timestamp(eventlog))
lifecycle_id_ <- function(eventlog) sym(lifecycle_id(eventlog))

deprecated_y_arg <- function(s, ...) {
	l <- list(...)
	if(length(l) > 0 && any(stringr::str_detect("y",names(l)))) {
		warning("Arguments y is deprecated. Use sort instead.")
		l[stringr::str_detect("y",names(l))][[1]]
	} else {
		s
	}
}



summary_statistics <- function(vector) {


	s <- summary(vector)
	s <- c(s, St.Dev = sd(vector))
	s <- c(s, IQR = s[5] - s[2])
	names(s) <- c("min","q1","median","mean","q3","max","st_dev","iqr")
	return(s)
}
os_type <- function() {
  .Platform$OS.type
}

is_linux <- function() {
  identical(tolower(Sys.info()[["sysname"]]), "linux")
}

isFALSE <- function(x) {
  identical(FALSE, x)
}

`%||%` <- function(l, r) if (is.null(l)) r else l

last_char <- function(x) {
  nc <- nchar(x)
  substring(x, nc, nc)
}
copy_template_files <- function(from, to) {
    template_files <- system.file('templates', from,
                                  package = 'prodigenr')
    template_files <- list.files(template_files, all.files = TRUE,
                                 full.names = TRUE,
                                 include.dirs = FALSE)[-1:-2]
    file.copy(template_files, to, recursive = TRUE)
}
prop <- function(x) x / sum(x, na.rm = TRUE)

cv <- function(x, na.rm = FALSE) stats::sd(x, na.rm = na.rm) / mean(x, na.rm = na.rm)

uniquecols <- function(df) {
  one_val <- vapply(df, function(x) length(unique(x)) == 1, logical(1))
  unrowname(df[, one_val, drop = FALSE])
}
split_rows <- function(x) {
  split(x, seq_len(nrow(x)))
}

merge_rows <- function(x) {
  tibble::as_tibble(do.call(rbind, x))
}
# Drop NULLs from a list
drop_nulls <- function(x) {
  x[!vapply(x, is.null, logical(1))]
}


# Everything above this function in the stack will be hidden by default in the
# flamegraph.
..stacktraceoff.. <- function(x) x

is_installed <- function(pkg) {
  found <- TRUE
  tryCatch(utils::packageVersion(pkg),
    error = function(e) found <<- FALSE
  )
  found
}
#' @importFrom magrittr %>%
#' @export
magrittr::`%>%`

length_list <- function(vec){
  if(length(vec) == 0){
    return(NA)
  } else {
    unlist(lapply(vec, length))
  }
}
## wrappers for class dist
##
## note that all type checking and coercing
## is now done in C, as well as handling of
## attributes.
##
## fixme: create generic functions?
##
## ceeboo 2007

dim.dist <-
function(x)
    rep.int(attr(x, "Size"), 2)         # works with nrow and ncol

dimnames.dist <-
names.dist <-
function(x)
    attr(x, "Labels")

"dimnames<-.dist" <-
"names<-.dist" <-
function(x, value)
{
    if (is.null(value))
        attr(x, "Labels") <- NULL
    else {
        if (length(value) != attr(x, "Size"))
            stop("dimension of 'x' and length of 'value' do not conform")
        attr(x, "Labels") <- as.character(value)
    }
    x
}

row.dist <-
function(x)
    .Call(R_row_dist, x, FALSE)

col.dist <-
function(x)
    .Call(R_row_dist, x, TRUE)

##

subset.dist <-
"[[.dist" <-
function(x, subset, ...)
{
    if (missing(subset))
        return(x)
    .Call(R_subset_dist, x, unique(subset))
}

##

rowSums.dist <-
colSums.dist <-
function(x, na.rm = FALSE)
    .Call(R_rowSums_dist, x, na.rm)

##

rowMeans.dist <-
colMeans.dist <-
function(x, na.rm = FALSE, diag = TRUE)
{
    if (!is.logical(diag))
        stop("'diag' not of type logical")
    s <- rowSums.dist(x, na.rm)
    if (na.rm) {
        x[!(is.na(x) | is.nan(x))] <- 1
        s / (rowSums.dist(x, na.rm) + (diag == TRUE))
    } else
        s / (length(s) - (diag == FALSE))
}

###
all_named <- function(x) {
  if (length(x) == 0) return(TRUE)
  !is.null(names(x)) && all(names(x) != "")
}

"%||%" <- function(x, y) if (is.null(x)) y else x

compact <- function(x) Filter(Negate(is.null), x)

to_env <- function(x, quiet = FALSE) {
  if (is.environment(x)) {
    x
  } else if (is.list(x)) {
    list2env(x)
  } else if (is.function(x)) {
    environment(x)
  } else if (length(x) == 1 && is.character(x)) {
    if (!quiet) message("Using environment ", x)
    as.environment(x)
  } else if (length(x) == 1 && is.numeric(x) && x > 0) {
    if (!quiet) message("Using environment ", search()[x])
    as.environment(x)
  } else {
    stop("Input can not be coerced to an environment", call. = FALSE)
  }
}
#' Complete Stems
#' @param words character vector of words
#' @param stems character vector of stems
complete_stems <- function(words, stems){
  stem_word <- dplyr::data_frame(words = words, stems = stems) %>%
    dplyr::group_by(words) %>%
    dplyr::mutate(n_word = n()) %>%
    dplyr::ungroup() %>%
    dplyr::group_by(stems) %>%
    dplyr::summarise(new_stems = dplyr::first(words, order_by = -n_word)) %>%
    dplyr::select(stems, new_stems)
  return(stem_word)
}

#' Extract words
#' Extracts all words from a character string of texts.
#' @param texts character vector of texts
#' @note it uses the regex \code{\\b[:alpha:]+\\b} to extract words.
extract_words <- function(texts){
  words <- tokenizers::tokenize_words(texts) %>%
    unlist() %>%
    unique()
  return(words)
}
.verifyChar <- function(vec) {
	if (!is.atomic(vec)) stop("Must be an atomic vector!", call. = FALSE)
	OUT <- as.character(vec)
	return(OUT)
}

.verifyNum <- function(vec) {
	if (!is.atomic(vec)) stop("Must be an atomic vector!")
	OUT <- suppressWarnings(as.numeric(vec))
	if (length(OUT[!is.na(OUT)]) == 0) stop("Does not contain any numeric elements!", call. = FALSE)
	return(OUT)
}
#' Pipe operator
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @export
#' @importFrom magrittr %>%
#' @usage lhs \%>\% rhs
NULL

names2 <- function(x) {
  names(x) %||% rep("", length(x))
}

`%||%` <- function(x, y) {
  if (is.null(x)) {
    y
  } else {
    x
  }
}

isFALSE <- function(x) identical(x, FALSE)

ndots <- function(...) nargs()

inv_which <- function(x, sel) {
  if (is.character(sel)) {
    names <- names(x)
    if (is.null(names)) {
      stop("character indexing requires a named object", call. = FALSE)
    }
    names %in% sel
  } else if (is.numeric(sel)) {
    seq_along(x) %in% sel
  } else {
    stop("unrecognised index type", call. = FALSE)
  }
}

deprecate <- function(...) {
  # No message for now
}

as_function <- function(...) {
  if (utils::packageVersion("purrr") >= "0.2.2.9000") {
    purrr::as_mapper(...)
  } else {
    purrr::as_function(...)
  }
}
## Paste an Unspecified Number Of Text Columns
## 
## \code{paste2} - Paste unspecified columns or a list of vectors together.
paste2 <-
function(multi.columns, sep=".", handle.na=TRUE, trim=TRUE){
    if (is.matrix(multi.columns)) {
        multi.columns <- data.frame(multi.columns)
    }
    if (trim) multi.columns <- lapply(multi.columns, function(x) {
            gsub("^\\s+|\\s+$", "", x)
        }
    )
    if (!is.data.frame(multi.columns) & is.list(multi.columns)) {
        multi.columns <- do.call('cbind', multi.columns)
    } 
    m <- if (handle.na){
                 apply(multi.columns, 1, function(x){
                     if (any(is.na(x))){
                         NA
                     } else {
                         paste(x, collapse = sep)
                     }
                 }
             )   
         } else {
             apply(multi.columns, 1, paste, collapse = sep)
    }
    names(m) <- NULL
    return(m)
}




## Remove Leading/Trailing White Space
## 
## Remove leading/trailing white space.
Trim <-
function (x) gsub("^\\s+|\\s+$", "", x)

hijack <- function(FUN, ...){

    .FUN <- FUN

    args <- list(...)
    invisible(lapply(seq_along(args), function(i) {
        formals(.FUN)[[names(args)[i]]] <<- args[[i]]
    }))
    
    .FUN
}
# appropriate from the RSAGA pkg with :heart:

to_xyz <- function (data, header, varname = "z", colnames = c("x", "y", varname)) {

  header <- list(ncols = ncol(data),
                 nrows = nrow(data),
                 xllcenter = 0, yllcenter = 0,
                 cellsize = 1, xllcorner = -0.5,
                 yllcorner = -0.5)

  data <- data.frame(x = header$xllcenter +
                       rep(seq(0, (header$ncols - 1) * header$cellsize, by = header$cellsize),
                           header$nrows),
                     y = rep(header$yllcenter +
                               seq((header$nrows - 1) * header$cellsize,
                                   0, by = -header$cellsize), each = header$ncols),
                     z = as.vector(t(data)))

  colnames(data) = colnames

  data

}
## Holds some convenience wrappers for various objects

##' Get the dimensions of rectangles and rectangular objects
##'
##' @param x A rectangular object, like \code{QRect} or \code{QGraphicsItem}
##' @method dim QRectF
##' @rdname dim-methods
dim.QRectF <- function(x) c(x$width(), x$height())
##' @method dim QRect
##' @rdname dim-methods
dim.QRect <- dim.QRectF
##' @method dim QGraphicsScene
##' @rdname dim-methods
dim.QGraphicsScene <- function(x) dim(x$sceneRect)
##' @method dim QGraphicsItem
##' @rdname dim-methods
dim.QGraphicsItem <- function(x) dim(x$boundingRect)
##' @method dim QGraphicsView
##' @rdname dim-methods
dim.QGraphicsView <- function(x) dim(x$viewport()$rect)

##' Finds a child \code{QObject} by name. Mirrors a function in Qt
##' that is inaccessible via the ordinary interface because it is a
##' template.
##'
##' This is particularly useful when working with QtDesigner, where
##' objects in the UI file are named.
##' @title Find child by name
##' @param x The parent \code{QObject}
##' @param name The name of the child
##' @return The child \code{QObject}
##' @author Michael Lawrence
##' @examples
##' parent <- Qt$QObject()
##' child <- Qt$QObject(parent)
##' child$objectName <- "foo"
##' qfindChild(parent, "foo")

qfindChild <- function(x, name) {
  ## not exactly sure how to use this one
  Qt$QGlobalSpace$qt_qFindChild_helper(x, name, x$metaObject())
}

mapRTypeToQtType <- function(x) {
  map <- c("raw" = "unsigned char *",
           "logical" = "bool",
           "integer" = "int",
           "numeric" = "double",
           "character" = "QString")
  map[x]
}
DropMissing <- function(cross, pheno.names)
{
  ## drop subjects with missing phenotype or covariate values
  as.vector(attr(na.omit(cross$pheno[, pheno.names]), "na.action"))
}
##############################################################################
normal.trans <- function (x) 
{
  x <- rank(x, na.last = "keep")
  qnorm(x/(1 + sum(!is.na(x))))
}
DropMissing <- function(cross, pheno.names)
{
  ## drop subjects with missing phenotype or covariate values
  as.vector(attr(na.omit(cross$pheno[, pheno.names]), "na.action"))
}
##############################################################################
normal.trans <- function (x) 
{
  x <- rank(x, na.last = "keep")
  qnorm(x/(1 + sum(!is.na(x))))
}
recycleVector <- function(x, len) {
  xlen <- length(x)
  if (xlen == len)
    return(x)
  if (!len)
    return(rep(x, 0))
  if (xlen > len) {
    warning("the length of 'x' is already longer than 'len'")
    return(x)
  }
  if (!xlen)
    stop("cannot recycle a zero length vector")
  times <- as.integer(len %/% xlen)
  if (times * xlen != len) {
    warning("longer argument not a multiple of shorter argument length")
    return(rep(x, length = len))
  }
  rep.int(x, times) # 100 X faster when length(x) is 1
}
# Scale to range ----------------------------------------------------------

scale_runif <- function(x, new_min, new_max) {
  (new_max - new_min) * (x - 1) + new_max
}
setClassUnion("characterOrMissing", c("character", "missing"))
setClassUnion(name = "listOrCharacter", members = c("list", "character"))
setClassUnion("logicalOrMissing", c("logical", "missing"))
setClassUnion("numericOrCharacter", c("numeric", "character"))
setClassUnion("characterOrNULL",members=c("character", "NULL"))
#' Conversion of \code{data.frame} to \code{rules} from \code{arules}
#'
#' @param model \code{data.frame} with rules
#' @return \code{arules} \code{rules} representation
#' @export
#' @examples
#' library("rCBA")
#' data("iris")
#'
#' output <- rCBA::buildFPGrowth(iris[sample(nrow(iris), 50),], "Species")
#' model <- output$model
#'
#' rules <- rCBA::frameToRules(model)
#' inspect(rules)
#'
#' @include init.R
frameToRules <- function(model){
  # export quality measures
  quality<-model[,2:4]
  # parse text
  rowItems <- lapply(model$rules,function(x) {
    x <- as.character(x)
    pattern <- "[[:space:]]*\\{(.*)\\}[[:space:]]*=>[[:space:]]*\\{(.*)\\}[[:space:]]*"
    m <- regexec(pattern, x)
    strRule <- regmatches(x, m)
    ant <- strsplit(strRule[[1]][2],",")[[1]]
    cons <- strsplit(strRule[[1]][3],",")[[1]]
    list(ant=ant,cons=cons)
  })
  # unique lhs and rhs items
  antItems <- unique(unlist(sapply(rowItems, function(x) x$ant)))
  consItems <- unique(unlist(sapply(rowItems, function(x) x$cons)))
  # all items
  items <- c(antItems, consItems)
  # prepare matrices for antecedents(lhs) and consequents(rhs)
  antM <- matrix(0, ncol=length(items), nrow = nrow(model))
  dimnames(antM) <- list(NULL, items)
  consM <- matrix(0, ncol=length(items), nrow = nrow(model))
  dimnames(consM) <- list(NULL, items)
  # set presence of items in lhs and rhs
  sapply(seq_len(nrow(model)), function(x){
    row <- unname(rowItems[x])[[1]]
    antM[x,match(row$ant,items)] <<- 1
    consM[x,match(row$cons,items)] <<- 1
    NULL
  })
  # convert to item matrix
  antI <- as(antM, "itemMatrix")
  consI <- as(consM, "itemMatrix")
  # create rules
  rules <- new("rules", lhs=antI, rhs=consI, quality = quality)
  rules
}
.verifyChar <- function(vec) {
	if (!is.atomic(vec)) stop("Must be an atomic vector!", call. = FALSE)
	OUT <- as.character(vec)
	return(OUT)
}

.verifyNum <- function(vec) {
	if (!is.atomic(vec)) stop("Must be an atomic vector!")
	OUT <- suppressWarnings(as.numeric(vec))
	if (length(OUT[!is.na(OUT)]) == 0) stop("Does not contain any numeric elements!", call. = FALSE)
	return(OUT)
}
# utils.R

#' showMethods2
#'
#' Get the methods in a class. But only those specific to the class
#'
#' @param theClass class to analyze
#'
#' @importFrom methods showMethods
#' @export
showMethods2 <- function(theClass) {
    # get the method printout
    mtext <-  showMethods(classes=theClass, printTo = FALSE )

    # extract only what is between "Function :" and " (pack ... .GlobalEnv)"
    fvec  <- gsub( "Function(\\:\\s|\\s\\\")(.+)(\\s\\(|\\\")(.+$)",
                   "\\2", mtext[grep("^Function: ", mtext)] )

    fvec

    # vector comparison of methods
    # expect_equal(fvec, c("getStepSize", "init", "setStepSize", "step"))
}

#' importFromExamples
#'
#' Source the R script
#'
#' @param aClassFile a file containing one or more classes
#' @param aFolder    a folder where examples are located
#' @export
importFromExamples <- function(aClassFile, aFolder = "examples") {
    source(paste(system.file(aFolder, package = "rODE"),
                 aClassFile,
                 sep ="/"), echo = FALSE)
}


#' run_test_applications
#'
#' Run test all the examples
#'
#' @export
run_test_applications <- function() {
    test_ex_dir  <- system.file("test_examples", package="rODE")
    examples_dir <- system.file("examples", package = "rODE")
    source(paste(test_ex_dir, "run_test_applications.R", sep = "/"))
}


release_questions <- function() {
    c(
        "Have you add the names for the vignettes?",
        "Do the examples have App in them?"
    )
}



get_list_examples <- function(aPackage) {
    # this is where examples live
    examples_dir <- system.file("examples", package = aPackage)

    # get all the scripts that `App` in them
    list.files(path = examples_dir, pattern = "*App", all.files = FALSE,
                           full.names = FALSE, recursive = FALSE, ignore.case = FALSE,
                           include.dirs = FALSE, no.. = FALSE)
}
library(futile.logger)

#' Constant to define when times are considered so close to each other
#'  that they should be treated as simultaneous, in terms of significant
#'  digits
#' @export TIME_RESOLUTION_SIGNIF_DIGITS
TIME_RESOLUTION_SIGNIF_DIGITS = 7

#' Constant to define when times are considered so close to each other
#'  that they should be treated as simultaneous
#' @export TIME_RESOLUTION_FACTOR
TIME_RESOLUTION_FACTOR = 10^(-TIME_RESOLUTION_SIGNIF_DIGITS)

log_layout_fcn = function(level, msg, ...)
{
  if (length(list(...)) > 0) {
    parsed <- lapply(list(...), function(x) ifelse(is.null(x),
                                                   "NULL", x))
    msg <- do.call(sprintf, c(msg, parsed))
  }
  sprintf("%s %s\n", names(level), msg)
}

flog.layout(log_layout_fcn, name='ragtop')
flog.layout(log_layout_fcn)

size_in_dimension = function(x,d=1)
{
  n = dim(x)[d]
  if (is.null(n)) {
    n = nrow(x)
  }
  if (is.null(n)) {
    n = length(x)
  }
  n
}
#' @keywords internal
add_dots <- function(x, pos = 3) {
  if (length(x) > pos) {
    c(x[seq_len(pos-1)], "...", x[length(x)])
  } else {
    x
  }
}


#' @keywords internal
desc_mat <- function(x) {
  # paste(paste(dim(x), collapse = " by "), "matrix of", paste0(typeof(x), "s"))
  paste(paste(dim(x), collapse = " x "), "matrix of", paste0(typeof(x), "s:"))
}
#' @export 
plot.rankFD <- function (x, ...) {
  
  object <- x
  dots <- list(...)
  a <- object$plotting
  
  # default values
  args <- list(nf = a$nf, fac_names = a$fac_names, n.hypotheses = a$n.hypotheses,
               Descriptive.Factors = a$Descriptive.Factors, CI.method = a$CI.method)
  
  args[names(dots)] <- dots
  
  do.call(plotting, args = args)
}

#' @export
print.rankFD <- function (x, ...) {
  cat("\n", "Descriptive:", "\n", sep = "")
  print(x$Descriptive)
  cat("\n", "Wald-Type Statistic (WTS):", "\n", sep = "")
  print(x$Wald.Type.Statistic)
  cat("\n", "ANOVA-Type Statistic (ATS):", "\n", sep = "")
  print(x$ANOVA.Type.Statistic)
}
#' @rdname absolute_path
#' @name absolute_path
#' @title Absolute Path
#' @description
#' This function is used to convert relative file paths to absolute file paths
#' without checking if the file exists as tools::file_as_absolute_path does
#'
#' @param filename name of a file, absolute or relative to a folder
#' @param dirname name of a folder where the file is supposed to be
#' @keywords internal
absolute_path <- function(filename, dirname){
  if (missing(dirname)){
    dirname <- ""
  }
  if (substr(filename, 1, 1) == "/"){
    #the filename is already absolute
    result <- normalizePath(filename, "/", FALSE)
  } else {
    if (nchar(dirname) == 0){
      result <- normalizePath(filename, "/", FALSE)
    } else {
      result <- normalizePath(paste(dirname, filename, sep = "/"), "/", FALSE)
    }
  }
  return(result)
}
# Must match parser name & q 1.0 mimetype listed at:
# http://librdf.org/raptor/api/raptor-formats-types-by-parser.html
# 3 turtle options listed but only text/turtle works. 
# support may depend on libs avialable depending on when and how redland is compiled
rdf_mimetypes <- c("nquads" = "text/x-nquads",
                   "ntriples" = "application/n-triples",
                   "rdfxml" = "application/rdf+xml",
                   "trig" = "application/x-trig",
                   "turtle" = "text/turtle")

## My redland version does not find support for these, probably optional 
## additional dependency needed when compiling redland
# - trig  (application/x-trig)
# - n3 (text/n3) 
# - rdfa (application/xhtml+xml, or text/html)
# - rss (application/rss+xml or text/rss)



guess_format <- function(doc){
  switch(gsub(".*\\.(\\w+)$", "\\1", basename(doc)),
         "xml" = "rdfxml",
         "rdf" = "rdfxml",
         "json" = "jsonld",
         "nq" = "nquads",
         "nt" = "ntriples",
         "ttl" = "turtle",
         "jsonld" = "jsonld",
         "quads" = "nquads",
         "turtle" = "turtle",
         "rdfxml")
}


## Don't explicitly type characters as strings, since this is default
xs_class <- function(x){
  
    type <- switch(class(x)[[1]],
                   "numeric" = "xs:decimal",
                   "factor" = "xs:string",
                   "logical" = "xs:boolean",
                   "integer" = "xs:integer",
                   "Date" = "xs:date",
                   "POSIXct" = "xs:dateTime",
                   NULL
    )
  
  
  string <- gsub("^xs:", 
                 "http://www.w3.org/2001/XMLSchema#",
                 type)
  ## consistent return length, character(1)
  if(length(string) == 0){
    string <- as.character(NA)
  }
  string
}
#'@importFrom httr stop_for_status GET content user_agent
guardian_query <- function(path, ...){
  url <- paste0("https://content.guardianapis.com/", path)
  result <- httr::GET(url)
  httr::stop_for_status(result)
  content <- httr::content(result)
  if(length(content$response$results) == 0){
    stop("No results found")
  }
  return(content)
}

date_convert <- function(date){
  
  if(any(c("POSIXlt", "POSIXct") %in% class(date))){
    date <- as.Date(date)
  }
  return(as.character(date))
}

# Merges multiple args
merge_multis <- function(args){
  return(paste0(args, collapse = ","))
}
flesch_kincaid_ <- function(n.words, n.sents, n.sylls, ...){
    (.39*(n.words/n.sents)) + (11.8*(n.sylls/n.words)) - 15.9
}

gunning_fog_ <- function(n.words, n.sents, n.complexes, ...){
    .4*((n.words/n.sents) + (100*(n.complexes/n.words)))
}

coleman_liau_ <- function(n.words, n.sents, n.chars, ...) {
    (0.0588 * ((100 * n.chars)/n.words)) - (0.296 * ((100 * n.sents)/n.words)) - 15.8
}

smog_ <- function(n.sents, n.polys) {
    (1.043 * sqrt(n.polys * (30/n.sents))) + 3.1291
}


#automated_readability_index_  <- function(n.words, n.sents, n.chars){
#    4.71 * (n.chars/n.words) + 0.5 * (n.words/n.sents) - 21.43
#}

automated_readability_index_  <- function(n.words, n.sents, n.chars){
    out <- 4.71 * (n.chars/n.words) + 0.5 * (n.words/n.sents) - 21.43
    ceiling(ifelse(out < 1, 1, out)) - 1
}

SE <- function(x) sqrt(stats::var(x)/length(x))

digit_format <- function (x, digits = 1) {
    if (is.null(digits))
        digits <- 3
    if (length(digits) > 1) {
        digits <- digits[1]
        warning("Using only digits[1]")
    }
    x <- round(as.numeric(x), digits)
    if (digits > 0)
        x <- sprintf(paste0("%.", digits, "f"), x)
    out <- gsub("^0(?=\\.)|(?<=-)0", "", x, perl = TRUE)
    out[out == "NA"] <- NA
    out
}
# Silence R CMD check note
#' @importFrom tibble tibble
NULL

isFALSE <- function(x) identical(x, FALSE)

is.connection <- function(x) inherits(x, "connection")

`%||%` <- function(a, b) if (is.null(a)) b else a

is_syntactic <- function(x) make.names(x) == x

show_progress <- function() {
  isTRUE(getOption("readr.show_progress")) && # user disables progress bar
  interactive() && # an interactive session
  is.null(getOption("knitr.in.progress")) # Not actively knitting a document
}

deparse2 <- function(expr, ..., sep = "\n") {
  paste(deparse(expr, ...), collapse = sep)
}

is_integerish <- function(x) {
  floor(x) == x
}
check_file <- function(path) {
  if (!file.exists(path)) {
    stop("'", path, "' does not exist",
      if (!is_absolute_path(path))
        paste0(" in current working directory ('", getwd(), "')"),
      ".",
      call. = FALSE)
  }

  normalizePath(path, "/", mustWork = FALSE)
}

is_absolute_path <- function(path) {
  grepl("^(/|[A-Za-z]:|\\\\|~)", path)
}

isFALSE <- function(x) identical(x, FALSE)

is_integerish <- function(x) {
  floor(x) == x
}
#
#   This work was created by the National Center for Ecological Analysis and Synthesis.
#
#     Copyright 2015 Regents of the University of California
#
#   Licensed under the Apache License, Version 2.0 (the "License");
#   you may not use this file except in compliance with the License.
#   You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
#   Unless required by applicable law or agreed to in writing, software
#   distributed under the License is distributed on an "AS IS" BASIS,
#   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
#   See the License for the specific language governing permissions and
#   limitations under the License.
#
#' Determine whether an externalptr object is NULL.
#' 
#' The pointer is treated as an externalptr and checked via a call in C to see if it is NULL.
#' @param pointer externalptr to be checked for NULL value
#' @return logical TRUE if the pointer is NULL, otherwise FALSE
#' @export
is.null.externalptr <- function(pointer) {
    if (class(pointer)!="externalptr") stop("pointer is not an externalptr.")
    rv <- .Call("isnull", pointer)
    return(rv)
}
vcapply <- function(X, FUN, ...) {
  vapply(X, FUN, character(1), ...)
}
viapply <- function(X, FUN, ...) {
  vapply(X, FUN, integer(1), ...)
}
vlapply <- function(X, FUN, ...) {
  vapply(X, FUN, logical(1), ...)
}

Sys_getenv <- function(x, unset = NULL) {
  assert_scalar_character(x)
  ret <- Sys.getenv(x, NA_character_)
  if (is.na(ret)) unset else ret
}

modify_list <- function(x, val, name = deparse(substitute(x))) {
  warn_unknown(name, val, names(x))
  modifyList(x, val)
}

capture_args <- function(f, name) {
  args <- capture.output(args(f))
  sub("function ", name,
      paste0(paste(args[-length(args)], collapse = "\n"), "\n"))
}
# Function that attempts to merge common business name suffixes within a
# character string.
business_suffix <- function(vect) {
  vect <- gsub(" incorporated| incorporate", " inc", vect, perl = TRUE)
  vect <- gsub(" corporation| corporations", " corp", vect, perl = TRUE)
  vect <- gsub(" company| companys| companies", " co", vect, perl = TRUE)
  vect <- gsub(" limited liability co", " llc", vect, fixed = TRUE)
  vect <- gsub(" limited$", " ltd", vect, perl = TRUE)
  vect <- gsub(" division| divisions", " div", vect, perl = TRUE)
  vect <- gsub(" enterprises| enterprise", " ent", vect, perl = TRUE)
  vect <- gsub(" limited partnership", " lp", vect, fixed = TRUE)
  vect <- gsub(" and ", " & ", vect, fixed = TRUE)
  return(vect)
}

# Flatten a nested list such that each character vector occupies its own
# element in the return list. Can handle lists that have inconsistent nesting
# levels.
flatten_list <- function(list_obj) {
  more_lists <- vapply(list_obj, is.list, logical(1), USE.NAMES = FALSE)
  out <- c(list_obj[!more_lists], unlist(list_obj[more_lists], FALSE, FALSE))
  if(sum(more_lists)){
    Recall(out)
  } else {
    return(out)
  }
}
namer <- function(x, ...){
    if (is.null(names(x))) names(x) <- rep("", length(x))
    x
}
 

get_comment <- function(x, ...) {
     attributes(x)[["comment"]]
}


is.regex <- function (pattern) {
    out <- suppressWarnings(try(gsub(pattern, "", "hello", perl = TRUE), 
        silent = TRUE))
    ifelse(inherits(out, "try-error"), FALSE, TRUE)
}
## This should be in base R!
.FUNCall <- function(f) function(...) f(...)
## unexported utility functions
##
hasContent <- function(y){
   # << Returns printable character strings of a character vector if any, else NULL>>
   #
   ok <- nzchar(sub("[^[:graph:]]+","",y), keepNA = TRUE)
   ok[is.na(ok)] <- FALSE
   y <- y[ok]
   if(!length(y)) NULL else y
}

stripFun<- function(string,open = "(", close =")"){
   ##  <<Strips out everything from beginning of a character string through
   ## all characters from first open substring to matching closing substring.>>
   ## <<Primarily intended to strip out function call from source code character string returned by
   ## paste(deparse(f,control = "useSource",width = 132L),collapse= " ")  >>
   ## get substring from first match to open on
   string <- substring(string,regexpr(open,string,fixed =TRUE))
   ## vectorize substring from first match
   string_vec <- strsplit(string,"")[[1]]
   substring(string,which.min(cumsum(
      (string_vec == open) - (string_vec == close)))+1)
}
#' Options for saving ERDDAP datasets.
#'
#' @export
#' @param path Path to store files in. A directory, not a file.
#' Default: the root cache path, see \code{\link{cache_setup}}
#' @param overwrite (logical) Overwrite an existing file of the same name?
#' Default: \code{TRUE}
disk <- function(path = NULL, overwrite = TRUE) {
  path <- setup_cache_path(path_suffix = path)
  if (is.null(path)) {
    # path is NULL - use cache path already setup
    path <- rrcache$cache_path_get()
  }
  list(store = "disk", path = path, overwrite = overwrite)
}

#' @export
#' @rdname disk
memory <- function() list(store = "memory")
"%||%" <- function(a, b) if (!is.null(a)) a else b

all_identical <- function(xs) {
  if (length(xs) <= 1) return(TRUE)
  for (i in seq(2, length(xs))) {
    if (!identical(xs[[1]], xs[[i]])) return(FALSE)
  }
  TRUE
}

## Get the attributes if common, NULL if not.
normalize_melt_arguments <- function(data, measure.ind, factorsAsStrings) {

  measure.attributes <- lapply(measure.ind, function(i) {
    attributes(data[[i]])
  })

  ## Determine if all measure.attributes are equal
  measure.attrs.equal <- all_identical(measure.attributes)

  if (measure.attrs.equal) {
    measure.attributes <- measure.attributes[[1]]
  } else {
    warning("attributes are not identical across measure variables; ",
      "they will be dropped", call. = FALSE)
    measure.attributes <- NULL
  }

  if (!factorsAsStrings && !measure.attrs.equal) {
    warning("cannot avoid coercion of factors when measure attributes not identical",
      call. = FALSE)
    factorsAsStrings <- TRUE
  }

  ## If we are going to be coercing any factors to strings, we don't want to
  ## copy the attributes
  any.factors <- any( sapply( measure.ind, function(i) {
    is.factor( data[[i]] )
  }))

  if (factorsAsStrings && any.factors) {
    measure.attributes <- NULL
  }

  list(
    measure.attributes = measure.attributes,
    factorsAsStrings = factorsAsStrings
  )

}

is.string <- function(x) {
  is.character(x) && length(x) == 1
}
### =========================================================================
### Low-level utilities
### -------------------------------------------------------------------------

raggedListToDF <- function(x, keepAlwaysNULL = TRUE, ...) {
  nms <- unlist(lapply(x, names))
  uniq.nms <- unique(nms)
  ind <- match(nms, uniq.nms)
  cols <- .Call(R_raggedListToDF, x, uniq.nms, ind)
  nulls <- vapply(cols, is.null, logical(1L))
  if (keepAlwaysNULL) {
      cols[nulls] <- list(rep(NA, length(x)))
  } else {
      cols[nulls] <- NULL
  }
  as.data.frame(cols, ...)
}

setMethod("unstrsplit", "AsIs", function(x, sep = "") {
              unstrsplit(unclass(x), sep=sep)
          })
p <- function(...) {
  regex(paste(sep = "", collapse = "", ...))
}

#' Pipe operator
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @export
#' @importFrom magrittr %>%
#' @usage lhs \%>\% rhs
NULL

`%==%` <- function(x, y) {
  identical(x, y)
}
`%||%` <- function(a,b) if(is.null(a)) b else a
clean_json <- function(x, verbose = options()$rgho.verbose,
                       n_print = 10) {
  stopifnot(length(x) == 1)

  pattern <- '(\\S)\\"\\"'

  if (verbose) {
    pos <- gregexpr(pattern, x)[[1]]
    if (any(pos > 0)) {
      message(sprintf(
        "Corrected json errors in %i place(s):",
        length(pos)))
      for (i in pos) {
        message(sprintf(
          "\n%s\n",
          substr(
            x,
            max(i-n_print, 1),
            min(i+n_print, nchar(x))
          )
        ))
      }
    }
  }

  gsub(pattern, '\\1\\"', x)
}
update <- function(original, new) {

  if (length(new)) {
    if (length(original)) assert_that(is_named(original))
    assert_that(is_named(new))
    original[names(new)] <- new
  }

  original
}

#' @importFrom rematch re_match

parse_email <- function(x) {
  unname(
    re_match(pattern = "<(?<email>[^>]+)>", x)[, "email"]
  )
}

`%||%` <- function(l, r) if (is.null(l)) r else l

#' @importFrom desc desc_get_maintainer
#' @importFrom utils untar

get_maintainer_email <- function(path) {
  path <- normalizePath(path)
  if (is_dir(path)) {
    if (!file.exists(file.path(path, "DESCRIPTION"))) {
      stop("No 'DESCRIPTION' file found")
    }
    parse_email(desc_get_maintainer(path))
  } else {
    dir.create(tmp <- tempfile())
    files <- untar(path, list = TRUE, tar = "internal")
    desc <- grep("^[^/]+/DESCRIPTION$", files, value = TRUE)
    if (length(desc) < 1) stop("No 'DESCRIPTION' file in package")
    untar(path, desc, exdir = tmp, tar = "internal")
    parse_email(desc_get_maintainer(file.path(tmp, desc)))
  }
}

needs_compilation <- function(path) {
  path <- normalizePath(path)
  if (is_dir(path)) {
    file.exists(file.path(path, "src"))
  } else {
    dir.create(tmp <- tempfile())
    files <- untar(path, list = TRUE, tar = "internal")
    any(grepl("^[^/]+/src/?$", files))
  }
}

`%:::%` <- function(p, f) {
  get(f, envir = asNamespace(p))
}

is_interactive <- function() {
  interactive()
}

is_dir <- function(x) {
  file.info(x)$isdir
}

data_frame <- function(...) {
  data.frame(stringsAsFactors = FALSE, ...)
}

drop_nulls <- function(x) {
  x [ ! vapply(x, is.null, TRUE) ]
}
assert_scalar_logical <- function(x, name = deparse(substitute(x))) {
  assert_scalar(x, name)
  assert_logical(x, name)
  assert_nonmissing(x, name)
}
assert_logical <- function(x, name = deparse(substitute(x))) {
  if (!is.logical(x) && !is.na(x)) {
    stop(sprintf("%s must be logical", name), call. = FALSE)
  }
}
assert_scalar <- function(x, name = deparse(substitute(x))) {
  if (length(x) != 1) {
    stop(sprintf("%s must be a scalar", name), call. = FALSE)
  }
}
assert_nonmissing <- function(x, name = deparse(substitute(x))) {
  if (any(is.na(x))) {
    stop(sprintf("%s must not be NA", name), call. = FALSE)
  }
}

assert_function <- function(x, name = deparse(substitute(x))) {
  if (!is.function(x)) {
    stop(sprintf("%s must be a function", name), call. = FALSE)
  }
}

assert_character <- function(x, name = deparse(substitute(x))) {
  if (!is.character(x) && !is.na(x)) {
    stop(sprintf("%s must be a character", name), call. = FALSE)
  }
}

## Like with older Rcpp:
include_flags <- function(stdout = TRUE) {
  value <- paste0("-I", system.file("include", package = "ring"))
  if (stdout) {
    cat(value)
  } else {
    value
  }
}

`%||%` <- function(a, b) {
  if (is.null(a)) b else a
}

match_value <- function(x, choices, name = deparse(substitute(x))) {
  assert_character(x, name)
  assert_scalar(x, name)
  if (!(x %in% choices)) {
    stop(sprintf("Invalid value for '%s'; must be one of %s", name,
                 paste(dQuote(choices), collapse = ", ")))
  }
}

## This one is a bit different as I've tuned it for speed
C_assert_size <- function(x, name) {
  .Call(Cassert_scalar_size, x, name)
}
### Computes Tukey's biweight rho function with constant `c` for all
### values in the vector `x`.
rho.biweight <- function(x, c) {
  hulp <- x^2/2 - x^4/(2 * c^2) + x^6/(6 * c^4)
  ifelse(abs(x) < c, hulp, c^2/6)
}


## Computes the first derivative of Tukey's biweight psi function with
## constant `c` for all values in vector `x`.
psi.prime <- function(x, c) {
  psi.bisquare(x, c, deriv=TRUE)
}


IF.obs <- function(x, B, const, c) {
  p <- length(x)
  norm.x <- sqrt(sum(x^2))
  ifs0 <- ((x %*% t(x)/norm.x^2) -
           diag(p)/p) * psi.bisquare(norm.x, c) * norm.x^2 * p/const$gamma1 +
           (2/const$gamma3) * (rho.biweight(norm.x, c) - const$b0) * diag(p)
  ifs <- B %*% ifs0 %*% t(B)
  ifs
}


## Performs matrix multiplication of each slices the 'x' array
## along the Z-axis and B
multarray <- function(x, B) {
  result <- apply(x, 3, '%*%', B)
  dim(result) <- c(dim(x)[1], ncol(B), dim(x)[3])
  result
}


## Performs matrix multiplication of B and each slices the 'x' array
## along the Z-axis
tmultarray <- function(x, B) {
  result <- apply(x, 3, function(x.slice) B %*% x.slice)
  dim(result) <- c(nrow(B), dim(x)[2], dim(x)[3])
  result
}
#' Try to get the value of a symbol if exists or return a default value
#' @details
#' By default, the symbol is examined in \code{envir} without inheritance,
#' that is, if the symbol does not exist in \code{envir} the default value
#' \code{def} will be returned.
#' @param symbol the symbol to examine
#' @param def the default value if the symbol does not exist
#' @param ... additional parameters passed to \code{exists} and \code{get}
#' @param envir the environment to examine whether the symbol exists
#' and get the symbol
#' @export
#' @examples
#' x <- list(a=c(x=1,y=2),b=c(x=2,p=3))
#' list.map(x, tryGet(y,0))
tryGet <- function(symbol, def = NULL, ..., envir = parent.frame()) {
  symbol <- substitute(symbol)
  if (is.symbol(symbol)) symbol <- as.character(symbol)
  if (is.character(symbol)) {
    if (exists(symbol, inherits = FALSE, ..., envir = envir))
      get(symbol, inherits = FALSE, ..., envir = envir) else def
  } else stop("symbol must be a name or character", call. = FALSE)
}

#' Try to evaluate an expression and return a default value if
#' an error occurs or otherwise return its value.
#' @param expr the expression to evaluate
#' @param def the default value if an error occurs in the evaluation
#' of \code{expr}
#' @export
#' @examples
#' x <- list(a=c(x=1,y=2),b=c(x=2,p=3))
#' list.map(x, tryEval(x+y, NA))
tryEval <- function(expr, def = NULL) {
  x <- try(expr, silent = TRUE)
  if (is.error(x)) def else x
}
asInteger <- function(x)
    as.integer(round(x))

invDiag <- function(x) {
    vec <- integer(x ^ 2)
    vec[cumsum(rep(x - 1, x)) + 1] <- 1
    matrix(vec, nrow = x)
}

"%out%" <- function(x, y)
    ! x %in% y

nameToString <- function(x)
    deparse(substitute(x))

rmAttr <- function(x, except = "class") {
    nAttr <- names(attributes(x))
    attributes(x) <- attributes(x)[except]
    x
}

Rnumber <- function()
    paste((v <- R.Version())$major, v$minor, sep = ".")

Rname <- function()
    R.Version()$nickname

closest <- function(x, y, tol = +Inf)
    (d <- abs(x - y)) == min(d) & (d < tol)

locf <- function(x)
    (x2 <- na.omit(x))[length(x2)]

colClasses <- function(x)
    unlist(lapply(lapply(x, class), function(x) x[length(x)]))

nDistinct <- function(x)
    length(table(x))

interleave <- function(x, y) {
  iX <- 2 * seq_along(x) - 1
  iY <- 2 * seq_along(y)
  c(x, y)[order(c(iX, iY))]
}
# meta
oadoi_baseurl <- function()
  "https://api.oadoi.org/"
# API version
oadoi_api_version <- function()
  "v2"
# If you require access to more data, please use the data dump
api_limit <- 100000

# user agent, so oaDOI can track the usage of this client
ua <- httr::user_agent("https://github.com/ropensci/roadoi")

#' Email checker for roadoi API
#'
#' It implementents the following regex stackoverflow solution
#' http://stackoverflow.com/a/25077140
#'
#' @param email email address (character string)
#'
#' @noRd
val_email <- function(email) {
  if (is.null(email) && !is.character(email))
    stop("An email address is required to use oaDOI API", call. = FALSE)
  if (!grepl(email_regex(), email))
    stop("Email address seems not properly formatted - Please check!",
         call. = FALSE)
  return(email)
}

#' Email regex
#'
#' From \url{http://stackoverflow.com/a/25077140}
#'
#' @noRd
email_regex <-
  function()
    "^[_a-z0-9-]+(\\.[_a-z0-9-]+)*@[a-z0-9-]+(\\.[a-z0-9-]+)*(\\.[a-z]{2,4})$"
print.robreg3S <- function(x, digits = max(3, getOption("digits") - 3), ...)
{
  cat("Coefficients:\n")
  print(format(x$Summary.Table, digits = digits), print.gap = 2, quote = FALSE)
  cat("\n")
  invisible(x)
}

coef.robreg3S <- function(object, ...) object$coef

summary.robreg3S <- function(object, ...) object$Summary.Table

confint.robreg3S <- function(object, ...) {
	if( all(is.na(object$Summary.Table[,2] )) ) return( NA )
	cbind( object$Summary.Table[,1] - qnorm(0.975) * object$Summary.Table[,2],
		object$Summary.Table[,1] + qnorm(0.975) * object$Summary.Table[,2] )
	
}
# Error function
#' @importFrom stats pnorm
erf <- function(x) 2*pnorm(sqrt(2)*x) - 1

# Special cases for single Wishart----
F22 <- function(x) {
    1 - sqrt(x*pi*0.5)*exp(-0.5*x)*erf(sqrt(0.5*x)) - exp(-x)
}
F25 <- function(x) {
    1 - exp(-x)*(2*exp(0.5*x)*x^2 + x^2 + 6*x + 6)/6
}
F33 <- function(x) {
    exp(-1.5*x)*(exp(0.5*x) * (exp(x) - x - 1) * erf(sqrt(0.5*x)) -
                     sqrt(2*x/pi)*(exp(x)*(x - 1) + 1))
}
F44 <- function(x) {
    exp(-2*x)*(sqrt(2)*(4*exp(2*x) -
                            exp(x)*(x^3 + 2*x^2 + 2*x + 8) + 2*x + 4) -
                   sqrt(pi*x)*exp(0.5*x)*(exp(x)*(x^2 - 4*x + 6) -
                                              2*x - 6)*erf(sqrt(0.5*x)))/sqrt(32)
}

# Check if we have an integer----
isWhole <- function(x, tol = .Machine$double.eps^0.5)  abs(x - round(x)) < tol

# Adaptive selection of precision type----
precSingleWishart_bool <- function(n_min, n_max) {
    multiPrec <- FALSE

    if (n_max > 17) multiPrec <- TRUE else {
        if (n_min >= 15) multiPrec <- TRUE
        if (n_min == 14 & (n_max %in% 15:16)) multiPrec <- TRUE

    }
    return(multiPrec)
}

precDoubleWishart_bool <- function(p, n, m) {
    multiPrec <- FALSE

    if (p > 12 || m > 250 || n > 40) multiPrec <- TRUE
    if (abs(p - n) > 2) multiPrec <- TRUE

    return(multiPrec)
}
set_collate <- function(locale) {
  cur <- Sys.getlocale(category = "LC_COLLATE")
  Sys.setlocale(category = "LC_COLLATE", locale = locale)
  cur
}

with_collate <- function(locale, code) {
  old <- set_collate(locale)
  on.exit(set_collate(old))

  force(code)
}

sort_c <- function(x) with_collate("C", sort(x))
`%||%` <- function(a,b) if(is.null(a)) b else a
first <- function(...) head(..., n = 1)
but_last <- function(...) head(..., n = -1)
last <- function(...) tail(..., n = 1)

length_zero <- function(x) length(x) == 0
length_one <- function(x) length(x) == 1

is_list_of <- function(xs, classes) {
  assert_that(is.list(xs))
  all(vapply(xs, function(x) inherits(x, classes), logical(1)))
}

merge_lists <- function(x, y) {
  x[names(y)] <- y
  x
}

#' Higher-order functions for dealing with lists
#'
#' These functions were inspired by underscore.js.
#'
#' @name list_functions
#' @param key the name of a value in a list
#' @param keys a character vector of names in a list
#' @param xss a list of lists
#' @return \code{pluck} returns an unnamed value and \code{pluck_apply} returns
#'   a list of unnamed values. \code{pick} returns a simplified version of the
#'   original list. \code{pick_apply} returns a list of simplified lists.
#'
#' @details \itemize{ \item \code{pluck}: Pluck a named value from a list \item
#'   \code{pick}: Simplify a list by picking out whitelisted names}
#'
#'   The simple versions of \code{pluck} and \code{pick} are curried functions,
#'   meaning that they return a function which can be applied to a list. See the
#'   syntax in the usage section.
#' @keywords internal
NULL

#' @rdname list_functions
pluck <- function(key) {
  function(xs) xs[[key]]
}

#' @rdname list_functions
pluck_apply <- function(key, xss) {
  assert_that(is_list_of(xss, "list"))
  lapply(xss, pluck(key))
}

#' @rdname list_functions
pick <- function(keys) {
  function(xs) {
    classes <- class(xs)
    xs <- xs[is.element(names(xs), keys)]
    class(xs) <- classes
    xs
  }
}

#' @rdname list_functions
pick_apply <- function(keys, xss) {
  assert_that(is_list_of(xss, "list"))
  classes <- class(xss)
  xss <- lapply(xss, pick(keys))
  class(xss) <- classes
  xss
}
.isSingular <- function(mat)
{
##    return( - (determinant(mat, logarithm = TRUE)$modulus[1] - 0)/ncol(mat) > 50)
    p <- ncol(mat)
    if(!is.qr(mat))
        mat <- qr(mat)
    return(mat$rank < p)
}

.check_vars_numeric <- function(mf)
{
    ## we need to test just the columns which are actually used.
    mt <- attr(mf, "terms")
    mterms <- attr(mt, "factors")
    mterms <- rownames(mterms)[apply(mterms, 1, any)]
    any(sapply(mterms, function(x) is.factor(mf[,x]) || !is.numeric(mf[,x])))
}

vecnorm <- function(x, p=2) sum(x^p)^(1/p)

##
## Several Matlab-like utility functions ======================================================
##
##
## Return the square root of a symetric positive definite matrix
sqrtm <- function(A){
    ##
    ## [E D] = eig(A); sqrtm(A) = E * sqrt(D) * E'
    ##
    if(!is.matrix(A) || ncol(A) != nrow(A))
        stop("The matrix A must be a square matrix\n")

    ee <- eigen(A)
    if(any(ee$values < 0)) {
        stop("The matrix A must be positive definite.")
    }

    ee$vectors %*% diag(sqrt(ee$values)) %*% t(ee$vectors)
}

## Return an n by p matrix of ones
##ones <- function(n=1, p=1){
##    matrix(1, nrow=n, ncol=p)
##}

## Return an n by p matrix of zeros
##zeros <- function(n=1, p=1){
##    matrix(0, nrow=n, ncol=p)
##}

##  <Matlab>
##      a=[1 2 ; 3 4];
##      repmat(a,2,3)
##
##  <R>
##      a <- matrix(1:4,2,byrow=T)
##      repmat(a,2,3)
##
##
##  a <- 1:4; n=10
##  matrix(rep(a, times=n), nrow=n, byrow=TRUE)
##

##repmat <- function(A, n, p) {
##
##    if(is.vector(A))    # we need a column matrix, not a vector, speaking in R terms
##        A <- t(A)
##    kronecker(matrix(1,n,p), A)
##}
## lnorm
lnorm <- function(a, p = 1)
{
  (sum(abs(a) ^ p)) ^ (1. / p)
}

## Vectorization a matrix by row
mstack <- function(S)
{
  as.vector(t(S))
}


## Autoregressive covariance structure
CorrAR <- function(p, rho)
{
  Sigma <- matrix(nrow = p, ncol = p, NA)
  for (i in seq_len(p)) {
    for (j in seq_len(p)) {
      Sigma[i,j] <- rho ^ (abs(i - j))
    }
  }
  Sigma
}


CorrCS <- function(p, rho)
{
  Sigma <- matrix(nrow = p, ncol = p, rho)
  diag(Sigma) <- 1
  Sigma
}
#' @importFrom magrittr %>%
#' @export
magrittr::`%>%`

#' @importFrom httr GET
#' @importFrom httr content
#' @importFrom jsonlite fromJSON
#' @importFrom lazyeval interp

## paste pipes
`%+%`  <- function(a,b) paste(a, b, sep = '')
`%+|%` <- function(a,b) paste(a, b, sep = '|')
`%+&%` <- function(a,b) paste(a, b, sep = '&')
all_finite <- function(x){
   stopifnot(is.numeric(x))
   storage.mode(x) <- "double"
   .Call("all_finite_double",x)
}

# code copied from print.proc.time...
getDuration <- function(x){
    y <- x
    if (!is.na(y[4L]))
        y[1L] <- y[1L] + y[4L]
    if (!is.na(y[5L]))
        y[2L] <- y[2L] + y[5L]
    y <- y[1L:3L]
    names(y) <- c("user", "system", "elapsed")
    y
}
#' Set verbosity of trim model functions
#'
#' Control how much output \code{\link{trim}} writes to the screen while
#' fitting the model. By default, \code{trim} only returns the output
#' and does not write any progress to the screen. After calling
#' \code{set_trim_verbose(TRUE)}, \code{trim} will write information
#' about running iterations and convergence to the screen during optmization.
#' 
#'
#'
#' @param verbose \code{[logical]} toggle verbosity. \code{TRUE} means: be
#' verbose, \code{FALSE} means be quiet (this is the default).
#' @family modelspec
#' @export
set_trim_verbose <- function(verbose=FALSE){
  stopifnot(isTRUE(verbose)|!isTRUE(verbose))
  options(trim_verbose=verbose)
}

# Convenience function for console output during runs
rprintf <- function(fmt,...) { if(getOption("trim_verbose")) cat(sprintf(fmt,...)) }

# Similar, but for object/summary printing
printf <- function(fmt,...) {cat(sprintf(fmt,...))}
##' load function from package
##'
##'
##' @title get_fun_from_pkg
##' @param pkg package
##' @param fun function
##' @return function
##' @export
##' @author guangchuang yu
get_fun_from_pkg <- function(pkg, fun) {
    ## requireNamespace(pkg)
    ## eval(parse(text=paste0(pkg, "::", fun)))
    require(pkg, character.only = TRUE)
    eval(parse(text = fun))
}

##' open working directory
##'
##' 
##' @title o
##' @return NULL
##' @author Guangchuang Yu
##' @export
o <- function() {
    os <- Sys.info()[1]
    if (os == "Darwin") {
	system("open .")
    } else if (os == "Linux") {
        system("xdg-open . &")
    } else if (os == "Windows") {
	wd <- sub("/", "\\", getwd())
	cmd <- paste("explorer", wd)
	suppressWarnings(shell(cmd))
    }
}

##' read clipboard
##'
##' 
##' @title read.cb
##' @param ... parameters for read.table
##' @return data.frame
##' @author Guangchuang Yu
##' @importFrom utils read.table
##' @export
read.cb <- function(...) {
    os <- Sys.info()[1]
    if (os == "Darwin") {
        read.table(pipe("pbpaste"), ...)
    } else {
        read.table("clipboard", ...)
    }
}
"%||%" <- function(a, b) if (length(a) == 0) b else a

vpluck_with_default <- function(xs, i, default) {
  extract <- function(x) {
    if (i %in% names(x)) {
      x[[i]]
    } else {
      default
    }
  }
  vapply(xs, extract, FUN.VALUE = default)
}

format_list <- function(x, indent = 0) {
  spaces <- paste(rep("  ", indent), collapse = "")

  formatted <- vapply(x, format, character(1))
  paste0(spaces, formatted, collapse = "\n")
}

#' Pipe operator
#'
#' See \code{\link[magrittr]{\%>\%}} for more details.
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @export
#' @importFrom magrittr %>%
#' @usage lhs \%>\% rhs
NULL


#' Extract elements of a list by position.
#'
#' @param x A list
#' @param i A string or integer.
#' @param type Type of output, if known
#' @export
pluck <- function(x, i, type) {
  if (missing(type)) {
    lapply(x, .subset2, i)
  } else {
    vapply(x, .subset2, i, FUN.VALUE = type)
  }
}
#' @import graphics
#' @import grDevices

#' @title trace on id colection
#'
#' @description Start collecting id of an rvg device.
#' @export
rvg_tracer_on <- function(){

  dl <- dev.list()
  if( length( dl ) < 1 )
    stop("cannot find any open graphical device")
  dev_num <- as.integer(dev.cur()-1L)
  if( .Device == "dsvg_device" ) set_tracer_on(dn = dev_num)
  invisible()
}

#' @title trace off id colection
#'
#' @description get collected id of an rvg device and
#' stop collecting.
#' @return graphical elements id as integer values.
#' @export
rvg_tracer_off <- function(){

  dl <- dev.list()
  if( length( dl ) < 1 )
    stop("cannot find any open graphical device")
  if( .Device == "dsvg_device" ) {
    dev_num <- as.integer(dev.cur()-1L)
    ids <- collect_id(dev_num)
    set_tracer_off(dn = dev_num)
  } else ids = integer(0)

  ids

}


#' @title set attributes to graphical elements
#'
#' @description set attributes with javascript instructions
#' to graphical elements.
#' @param ids integer vector of graphical elements identifiers (returned by
#' \code{\link{rvg_tracer_off}}).
#' @param attribute name of the attribute to set.
#' @param str values to set for the attribute.
#'
#' @export
set_attr = function( ids, attribute, str ){
  stopifnot( .Device == "dsvg_device" )
  if( is.factor(str) )
    str = as.character( str )
  if( is.factor(attribute) )
    str = as.character( attribute )

  stopifnot( is.character(attribute) )
  stopifnot( is.character(str) )
  stopifnot( is.numeric(ids) )
  if( length(ids) != length(str) ){
    stop("ids don't have the same length than str (most often, it occurs because of clipping)")
  }
  stopifnot( length(attribute) == 1 )

  if( any( grepl(pattern = "'", str) ) )
    stop("str cannot contain single quote \"'\".")
  dev_num <- as.integer(dev.cur()-1L)
  add_attribute(dn = dev_num,
               id = as.integer( ids ),
               str = str,
               name = attribute
               )

  invisible()
}
#Backend for all API calls.
#'@importFrom httr stop_for_status content GET user_agent
query <- function(url_params, ...){
  if(grepl(x = url_params, pattern = "http")){
    url <- url_params
  } else {
    url <- paste0("http://swapi.co/api", url_params)
  }
  result <- GET(url, user_agent("rwars - https://github.com/Ironholds/rwars"), ...)
  stop_for_status(result)
  return(content(result))
}

#Parse the *_schema results
schema_parse <- function(result){
  result$required <- unlist(result$required)
  result['$schema'] <- NULL
  return(result)
}

#Safe parser base for entries
parser_base <- function(result, field){
  if(length(result[field]) > 0){
    result[[which(names(result) == field)]] <-  unname(unlist(result[field]))
  } else {
    result[field] <- NA
  }
  return(result)
}

planet_entry_parse <- function(result){
  result <- parser_base(result, "residents")
  result <- parser_base(result, "films")
  return(result)
}
species_entry_parse <- function(result){
  result <- parser_base(result, "people")
  result <- parser_base(result, "films")
  return(result)
}

film_entry_parse <- function(result){
  result <- parser_base(result, "characters")
  result <- parser_base(result, "planets")
  result <- parser_base(result, "starships")
  result <- parser_base(result, "vehicles")
  result <- parser_base(result, "species")
  return(result)
}

vehicle_entry_parse <- function(result){
  result <- parser_base(result, "films")
  result <- parser_base(result, "pilots")
  return(result)
}

person_entry_parse <- function(result){
  result <- parser_base(result, "films")
  result <- parser_base(result, "species")
  result <- parser_base(result, "vehicles")
  result <- parser_base(result, "starships")
  return(result)
}
to_symmetric <- function(mat) {
  mat[lower.tri(mat)] <- 0
  lower <- t(mat)
  diag(lower) <- 0
  mat + lower
}

compute_l1_norm <- function(mat) {
  sum(abs(mat))
}

# Eq. 4 (Sec. 3.1)
compute_mean <- function(x, m, A, w) {
  K <- length(m)
  M <- ncol(x)
  lapply(1:K, function(k) {
    tmp <- t(apply(x, 1, function(row) row - m[[k]])) %*% A[[k]]
    do.call(cbind, lapply(1:M, function(i) - tmp[,i] * w[[k]][i] + x[,i]))
  })
}

# Eq. 5 (Sec. 3.1)
compute_variance <- function(A) {
  lapply(A, function(a) 1 / diag(a))
}

# Eq. 17 (Sec. 3.2)
#' @importFrom stats dnorm
compute_gating_function <- function(x, theta, u, w, i) {
  K <- length(u)
  mat <- do.call(cbind, lapply(1:K, function(k) {
    theta[k] * dnorm(x[,i], mean = u[[k]][,i], sd = w[[k]][i])
  }))
  denom <- rowSums(mat)
  g <- apply(mat, 2, function(col) col / denom)
  list(g = g, mat = mat)
}
# Copyright 2014-2014 Steven E. Pav. All Rights Reserved.
# Author: Steven E. Pav
#
# This file is part of sadists.
#
# sadists is free software: you can redistribute it and/or modify
# it under the terms of the GNU Lesser General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# sadists is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser General Public License
# along with sadists.  If not, see <http://www.gnu.org/licenses/>.

# Created: 2014.02.23
# Copyright: Steven E. Pav, 2014
# Author: Steven E. Pav
# Comments: Steven E. Pav

# compute the log (gamma(a) / gamma(b))
lgamrat <- function(a,b) {
	return(lgamma(a) - lgamma(b))
}
# compute the ratio gamma(a) / gamma(b)
gamrat <- function(a,b) {
	return(exp(lgamrat(a,b)))
}

# eventually this will go away b/c rchisq was fixed in 3.2?
# rchisq is currently broken for df=0,ncp=0
# this is a not-recycled chisquare generator
# which irons over the df=0,ncp=0 case.
unbroken_rchisq <- function(n,df,ncp=0) {
	retv <- rchisq(n,df=df,ncp=ncp)
	retv[df==0 & ncp==0] <- 0
	retv
}

#for vim modeline: (do not edit)
# vim:fdm=marker:fmr=FOLDUP,UNFOLD:cms=#%s:syn=r:ft=r
`%||%` <- function(l, r) {
  if (is.null(l)) r else l
}

null_or_any_na <- function(x) {
  is.null(x) || any(is.na(x))
}

#' @importFrom utils head

drop_last <- function(x) {
  head(x, length(x) - 1)
}
## Do not edit this file manually.
## It has been automatically generated from *.org sources.

## taken from "pcts"
.reportClassName <- function(object, class, trailer = "\n"){
    if(class(object) == class)
        cat('An object of class "', class, '"', trailer, sep = "")
    NULL
}

## s - character string.
## v - numeric vector.
## none - character string.
.formatNameNumeric <- function(s, v, none = " <None>"){
    if(length(v) == 0)
        paste0(s, none)
    else{
        wrk <- paste0(v, collapse=" ")
        paste0(s, wrk)
    }
}

.capturePrint <- function(x){ # used by show() methods to print polynomials
    capture.output(print(x))
}

# stats:::format.perc() is not exported, copy it here.
.stats.format.perc <- function (probs, digits)
    paste(format(100 * probs, trim = TRUE, scientific = FALSE, digits = digits), "%")

diagOfVcov <- function(object, ...){
    diag(vcov(object, ...))
}

setGeneric("diagOfVcov")
#' Load SAS Code in
#'
#' @param sasPath SAS file location
#' @importFrom readr read_file
#' @return Character string containing contents of the file
#' @export
#' @examples 
#' sasPath <- system.file('examples/SAScode/Macros/fun2.SAS', package='sasMap')
#' loadSAS(sasPath)
loadSAS <- function(sasPath){
  
  # Read in SAS code
  rawFile <- readr::read_file(sasPath)
  
  # Ensure correct encoding
  rawFile <- iconv(rawFile, to = "ASCII//TRANSLIT")
  
  # Divide up
  sasCode <- splitIntoStatements(rawFile)
  
  # Put all in lower case
  sasCode <- tolower(sasCode)
  
  # Paste back together
  sasCode <- paste(sasCode, collapse = "")
  
  sasCode
}

#' Split SAS code into statements
#'
#' @param sasCode Character string containing SAS code
#' @importFrom stringr str_split
#' @export
#' @examples
#' sasPath <- system.file('examples/SAScode/Macros/fun2.SAS', package='sasMap')
#' sasCode <- loadSAS(sasPath)
#' splitIntoStatements(sasCode)
splitIntoStatements <- function(sasCode){
  unlist(stringr::str_split(sasCode, "(?<=[;])"))
}
round_digit <- function (d) {
    i <- 0
    while (d < 1) {
        d <- d * 10
        i <- i + 1
    }
    round(d)/10^i
}


is_fixed_radius <- function(rvar) {
    x <- suppressWarnings(as.numeric(rvar))
    if (is.na(x)) {
        return(FALSE)
    }
    return(TRUE)
}
sealr_timestamp <- function(quiet = FALSE) {
    utils::timestamp(
      stamp = Sys.Date(),
      prefix = paste0("#' ",
                      clisymbols::symbol$info,
                      ": Labeling on "),
      suffix = paste0(
        " by the sealr package (v",
        as.character(utils::packageVersion("sealr")),
        ")"
      ),
      quiet = quiet
    )
}

obj_eval <- function(df) {
  df %>%
    dplyr::mutate(
      eval = purrr::pmap(.,
                         ~ get(..2)
      )
    )
}

#' Catch lhs object which exclude function
#'
#' @noRd
lhs_obj <- function(x) {
  environment <- name <- hash <- NULL

  load_envs <- search()

  res <- tibble::data_frame(
    environment = load_envs %>%
      purrr::map(~ rep(.x[1], times = length(ls(
        .x[1]
      )))) %>%
      purrr::flatten_chr(),
    name = load_envs %>%
      purrr::map(~ ls(.x)) %>%
      purrr::flatten_chr(),
    class = name %>%
      purrr::map(~ get(..1)) %>%
      purrr::map(class)
  ) %>%
    tidyr::unnest() %>%
    dplyr::filter(class != "function") %>%
    dplyr::mutate(hash = name %>%
                    purrr::map_chr(~ digest::digest(get(.x), algo = "sha256"))) %>%
    dplyr::filter(hash == digest::digest(x, algo = "sha256"))

  if (nrow(res) == 0) {
    rlang::inform("The given object is not stored in any environment.")
  }

  return(res)

}

lhs_name <- function(x) {

  res <- lhs_obj(x)$name

    # FIXME
  if (length(res) > 1 && sum(grepl("^x$", res)) >= 1) {
    res <- res[!res %in% "x"]
  }

  return(res)
}

#' Generate test_that desc text
#'
#' @noRd
label <- function(e, desc) {
  dplyr::if_else(is.null(desc),
                 paste("check", get(".obj", e), "statement"),
                 desc)
}

sealing <- function(x, seal = FALSE, ...) {
  if (rlang::is_true(seal)) {
    seal(x, ...)
  } else {
    x
  }
}
#' Pipe operator
#'
#' See \code{magrittr::\link[magrittr]{\%>\%}} for details.
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @export
#' @importFrom magrittr %>%
#' @usage lhs \%>\% rhs
NULL
create_dir <- function(path) {
  dir.create(path, showWarnings = FALSE, recursive = TRUE)
}

is_dir <- function(x) {
  isTRUE(file.info(x)$isdir)
}

read_raw <- function(path) {
  readBin(path, "raw", n = file.info(path)$size)
}
### Function to colapse into a single data.frame data stored in multiple lists
### Writen by Gustavo Paterno (2017)
recombine <- function(sensi.list, slot1, slot2 = NULL){
  ### Nulling variables:
  is <- NULL
  
  ### One level indexing list[[slot1]]:
  if (is.null(slot2)){
    x <- lapply(sensi.list, function(x) x[[slot1]])
    
    if(is(x[[1]],"list"))
      stop("Please also provide a value for slot2")
    if(is.na(match(class(x[[1]]), c("data.frame", "matrix"))))
      stop("Check if slot indexing returns a valid data.frame or numeric value withn your list")
    
    res <- data.frame(iteration=rep(names(x), sapply(x, nrow)), do.call(rbind, x))
    res$info <- unlist(lapply(x,rownames))
    return(res)
  }
  
  ### Two levels indixing list[[slot1]][[slot2]]
  if(is.null(slot2) == FALSE){ 
    x <- lapply(sensi.list, function(x) x[[slot1]][[slot2]])
    
    if(class(x[[1]]) == "data.frame" | class(x[[1]]) == "matrix" | class(x[[1]]) == "numeric" ){
      n.rows<- nrow(x[[1]])
      
      ### If there is only a single value (e.g. AIC, optpar)
      if(is.null(n.rows)) {
        nam <- as.numeric(names(sensi.list))
        n.rows <- length(x[[1]])
        est.name <- names(sensi.list[[1]][[slot1]])[[slot2]]
        N <- rep(nam, each = n.rows)
        res <- data.frame(iteration = N, do.call("rbind", x))
        colnames(res)[2] <- est.name
        return(res)
      }
      
      else
      res <- data.frame(iteration=rep(names(x), sapply(x, nrow)), do.call(rbind, x))
      res$info <- unlist(lapply(x,rownames))
      return(res)
    }
    else stop("Check if slot indexing returns a valid data.frame or numeric value withn your list") 
  }
}
########################
# char to string
########################

c2s <- function( chars = c("m","e","r","g","e","d") )
{
  return( paste( chars, collapse = "" ) )
}

###########################
# string to char
############################

s2c <- function (string) 
{
  if(is.character(string) && length(string) == 1){
    return(.Call("s2c", string, PACKAGE = "seqinr"))
  } else {
    warning("Wrong argument type in s2c(), NA returned")
    return(NA)
  }
}



###########################
# Conversion of the numeric encoding of a DNA sequence into
# a vector of chars
############################

n2s <- function(nseq, levels = c("a", "c", "g", "t"), base4 = TRUE)
{
  if( base4 )
    levels[nseq + 1]
  else
    levels[nseq]
}



##########################################
# Convert one-letter code to 3-letters code for amino-acids
##########################################

aaa <- function( aa )
{
  aa3 <- c("Stp", "Ala", "Cys", "Asp", "Glu", "Phe", "Gly", "His", "Ile",
           "Lys", "Leu", "Met", "Asn", "Pro", "Gln", "Arg", "Ser", "Thr",
           "Val", "Trp", "Tyr") # One letter code order
  if(missing(aa)) return(aa3)
  aa1 <- a()

  convert <- function( x )
  {
    if( all( x != aa1 ) )
    { 
      warning("Unknown one letter code for aminoacid")
      return( NA )
    }
    else
    {
      return( aa3[which( x == aa1 )] )
    }
  }
  return( as.vector(unlist(sapply( aa, convert ) ) ) )
}

##########################################
# Conversion 3-letters code to one letter code for amino-acids
##########################################

a <- function( aa )
{
  aa1 <- s2c("*ACDEFGHIKLMNPQRSTVWY")
  if(missing(aa)) return(aa1)
  aa3 <- aaa()

  convert <- function( x )
  {
    if( all( x != aa3 ) )
    { 
      warning("Unknown 3-letters code for aminoacid")
      return( NA )
    }
    else
    {
      return( aa1[which( x == aa3 )] )
    }
  }
  return( as.vector(unlist(sapply( aa, convert ) ) ) )
}
try_require <- function(package, fun) {
  if (requireNamespace(package, quietly = TRUE)) {
    library(package, character.only = TRUE)
    return(invisible())
  }

  stop("Package `", package, "` required for `", fun , "`.\n", # nocov start
    "Please install and try again.", call. = FALSE) # nocov end
}
#' @importFrom withr with_collate

sort_ci <- function(x) {
  with_collate("C", x[order(tolower(x), x)])
}

is_string <- function(x) {
  is.character(x) && length(x) == 1 && !is.na(x)
}
# utilities to reset par() and options() to 'factory defaults'
PARDEFAULTS <- list()

.onLoad <- function(libname, pkgname){
  tmpdev <- tempfile()
  on.exit(unlink(tmpdev))
  pdf(file = tmpdev)
  PARDEFAULTS <<- par(no.readonly=TRUE)
  dev.off()
  PARDEFAULTS$new <<- FALSE
  PARDEFAULTS <<- PARDEFAULTS[!names(PARDEFAULTS) %in% c("bg", "fin", "mai", "new", "pin", "plt", "ps")]
}



# set defaults at build time.
OPTIONSDEFAULTS <- options()

#' Reset graphical options in 'par' to factory defaults.
#' 
#' Reset the \code{\link[graphics]{par}} to R's defaults. 
#' 
#' Some of \code{par}'s settings are readonly. These are obviously not reset.
#' 
#' Settings stored in \code{\link[graphics]{par}} are device-dependent. In practice,
#' most settings in \code{par} are initially the same accross devices. Exceptions
#' we noted are: 
#' \itemize{
#' \item{\code{bg}: background color}
#' \item{\code{fin}: figure region dimensions}
#' \item{\code{mai}: margin size (inches)}
#' \item{\code{pin}: current plot dimensions (inches)}
#' \item{\code{plt}: coordinates of the plot region as fractions of the current figure region}
#' \item{\code{ps}: point size of text (but not symbos)}
#' }
#' Consequently, these options are currently not reset by calling \code{reset_par()}  
#' 
#' @seealso \code{\link{reset_options}}, \code{\link[graphics]{par}}
#' @export 
reset_par <- function(){
  par(PARDEFAULTS)
}

#' Reset general options in 'options' to factory defaults.
#' 
#' @seealso \code{\link{reset_par}}
#' @export 
reset_options <- function(){
  options(OPTIONSDEFAULTS)
}
#'Utility Functions
#'
#'Load the shiny drag and drop javascript dependencies
#'@import shiny htmltools
.onAttach <- function(...) {

	# register the js input handler to make the element reactive
	shiny::registerInputHandler("dragdropshiny.dropper", function(data,...) {
		if (is.null(data) | data == "")
	  	return(NULL)
		else
	  	return(data)
	}, force = TRUE)

  # Create link to javascript and css files for package, referenced below
  shiny::addResourcePath("shinydnd", system.file("www", package = "shinyDND"))
}

# htmlDependency js and css will be used in other functions with attachDependency
shinyDNDDep = htmltools::htmlDependency("shinyDND", packageVersion("shinyDND"), 
	src = c("href" = "shinydnd"), script = "dragndrop.js", stylesheet = "dragndrop.css")
# Some utility functions (mostly copied from shiny/R/utils.R)

# Copied from shiny/R/utils.R
`%AND%` <- function(x, y) {
  if (!is.null(x) && !is.na(x))
    if (!is.null(y) && !is.na(y))
      return(y)
  return(NULL)
}

# Copied from shiny/R/input-utils.R
controlLabel <- function(controlName, label) {
  label %AND% tags$label(class = "control-label", `for` = controlName, label)
}

# Given a vector or list, drop all the NULL items in it
# Copied from shiny/R/utils.R
dropNulls <- function(x) {
  x[!vapply(x, is.null, FUN.VALUE=logical(1))]
}

parseTimeFromValue <- function(value){
  if(is.null(value)) return(NULL)
  posixlt_value <- unclass(as.POSIXlt(value))
  time_list <- lapply(posixlt_value[c('hour', 'min', 'sec')], function(x) {
    sprintf("%02d", trunc(x))
  })
  return(time_list)
}

getDefaultTime <- function(){
  return(as.POSIXlt("0:0:0", format = "%H:%M:%S"))
}
getSession <- function() {
  session <- shiny::getDefaultReactiveDomain()

  if (is.null(session)) {
    stop("Could not find a Shiny session object", call. = FALSE)
  }

  session
}
`%OR%` <- function(x, y) {
  if (is.null(x) || isTRUE(is.na(x)))
    y
  else
    x
}

`%AND%` <- function(x, y) {
  if (!is.null(x) && !is.na(x))
    if (!is.null(y) && !is.na(y))
      return(y)
  return(NULL)
}

# Format a number without sci notation, and keep as many digits as possible (do
# we really need to go beyond 15 digits?)
formatNoSci <- function(x) {
  if (is.null(x)) return(NULL)
  format(x, scientific = FALSE, digits = 15)
}


# Given a vector or list, drop all the NULL items in it
dropNulls <- function(x) {
  x[!vapply(x, is.null, FUN.VALUE=logical(1))]
}
#' Test if \code{\link[rms]{rcs}} from the \code{rms} Package was Used in the Fit.
#'
#' @param fit a fit object of class \code{lm}, \code{glm}, \code{coxph}, or \code{mfp}.
#'
#' @return A list with two elements:
#' \tabular{ll}{
#'     [[1]] \tab \code{\link[rms]{rcs}} is included in formula (right-hand side), but not as a variable name.\cr
#'     [[2]] \tab variables with \code{\link[rms]{rcs}}\cr
#' }
#'
#' @keywords internal
#' @export
isrcs <-
  function(fit)
{
  list(any(all.names(fit$call$formula[3]) == "rcs") && !any(all.vars(fit$call$formula[3]) == "rcs"),
       regexpr(
         pattern = "rcs(", fixed = TRUE, text = names(fit$coefficients)
       ) == TRUE)
}
#use cut-off to calculate new probability
rescale <- function(x)
  ifelse(x > 0.025, (x - 0.025)/0.975 * 0.5 + 0.5, x*20)

#later import function from biogram
degenerate <- function(seq, element_groups) {
  tmp_seq <- seq
  if (!all(unique(tmp_seq) %in% unlist(element_groups))) {
    warning("'seq' contains elements not present in 'element_groups'. Such elements will be replaced by NA.")
    tmp_seq[!(tmp_seq %in% unlist(element_groups))] <- NA
  }
  
  if(is.null(names(element_groups))) {
    warning("'element_groups' is unnamed. Assumed names of groups are their ordinal numbers.")
    names(element_groups) <- 1L:length(element_groups)
  }
  
  if(length(unique(names(element_groups))) != length(names(element_groups))) {
    stop("'element_groups' must have unique names.")
  }
  
  for (i in 1L:length(element_groups)) {
    tmp_seq[tmp_seq %in% element_groups[[i]]] <- names(element_groups)[i]
  }
  
  if(class(seq) == "matrix")
    dim(tmp_seq) <- dim(seq)
  
  tmp_seq
}
"%ni%" <- Negate("%in%")

prop_limits <- function(prop) {
  if(prop > .5) {
    u_diff <- 1 - prop
    u_max <- 1
    u_min <- prop - u_diff
  } else {
    u_diff <- 0 + prop
    u_max <- prop + u_diff
    u_min <- 0
  }
  return(c(u_min, u_max))
}

standardize <- function(x, mean, sd) {
  new <- (x - mean) / sd
  return(new)
}

search_factors <- function(x) {
  x <- strsplit(x, ':')
  loc <- lapply(seq_along(x), function(xx) 
    grep("\\.f$|\\.c$|_f$|_c$", x[[xx]], ignore.case = TRUE))
  len <- lapply(x, length)
  for(i in seq_along(x)) {
    x[[i]][loc[[i]]] <- paste0('factor(', x[[i]][loc[[i]]], ')')
    if(len[[i]] > 1) {
      x[[i]] <- paste(x[[i]], collapse = ':')
    }
  }
  x <- as.formula(paste('~', paste(x, collapse = '+')))
  x
}

# Horrible hack to keep CRAN happy and suppress NOTES about
# parts of the code that use non-standard evaluation.
# See:
# http://stackoverflow.com/questions/9439256/how-can-i-handle-r-cmd-check-no-visible-binding-for-global-variable-notes-when
# https://github.com/smbache/magrittr/issues/29
utils::globalVariables(c('test_stat', 'reject'))
# for dplyr
.data <- NULL

#' @export
plot.list <- function(x, ...) {
  if (length(class(x)) == 1) {
    stopifnot(all(class(x[[1]]) == sapply(x, class)))
    plot_list_proxy(x, ...)
  } else NextMethod()
}

plot_list_proxy <- function(x, ...) {
  if (all(sapply(x, inherits, class(x[[1]]))))
    class(x) <- c(class(x), class(x[[1]]))
  plot(x, ...)
}

dispatch_next <- function(.next, ...) {
  caller <- match.call(sys.function(-1), sys.call(-1))
  caller <- as.character(caller)[[1]]
  do.call(paste0(caller, ".", .next), list(...))
}

set_alpha <- function(data) {
  1.0 / (log(max(data$replication)) + 1)
}
merge_named_lists <- function(list1, list2, default = character()) {

  names <- unique(sort(c(names(list1), names(list2))))

  res <- lapply(names, function(n) { c(list1[[n]], list2[[n]]) %||% default })

  names(res) <- names
  res
}

`%||%` <- function(l, r) if (is.null(l)) r else l

#' Create a data frame, more robust than \code{data.frame}
#'
#' It does not create factor columns.
#' It recycles columns to match the longest column.
#'
#' @param ... Data frame columns.
#' @return The constructed data frame.
#'
#' @keywords internal

data_frame <- function(...) {

  args <- list(...)

  ## Replicate arguments if needed
  len <- vapply(args, length, numeric(1))
  stopifnot(length(setdiff(len, 1)) <= 1)
  len <- max(0, max(len))
  args <- lapply(args, function(x) rep(x, length.out = len))

  ## Names
  names <- as.character(names(args))
  length(names) <- length(args)
  names <- ifelse(
    is.na(names) | names == "",
    paste0("V", seq_along(args)),
    names)

  structure(args,
            class = "data.frame",
            names = names,
            row.names = seq_along(args[[1]]))
}

drop_rownames <- function(df) {
  row.names(df) <- NULL
  df
}
q=function(u,p){
	return(p*exp(u)/(1-p+p*exp(u)))
}
K=function(u,n,p){
	return(sum(n*log(1-p+p*exp(u))))
}
Kp=function(u,n,p){
	return(sum(n*q(u,p)))
}
Kpp=function(u,n,p){
	q_=q(u,p)
	return(sum(n*q_*(1-q_)))
}
Kppp=function(u,n,p){
	q_=q(u,p)
	return(sum(n*q_*(1-q_)*(1-2*q_)))
}
Kpppp=function(u,n,p){
	q_=q(u,p)
	return(sum(n*q_*(1-q_)*(1-6*q_*(1-q_))))
}
saddlepoint=function(u,n,p,s){
	return(Kp(u,n,p)-s)
}
# Adapted from
# https://stackoverflow.com/questions/28248457

fix_unicode <- function(char) {
  m <- gregexpr("<U\\+[0-9a-fA-F]{4}>", char)
  codes <- regmatches(char, m)
  chars <- lapply(codes, make_utf8)
  regmatches(char, m) <- chars
  enc2utf8(char)
}

make_utf8 <- function(x) {
  if (length(x) < 1) {
    return(x)
  } else {
    digits <- substring(x, 4, 7)
    integers <- strtoi(sprintf("0x%s", digits))
    purrr::map_chr(integers, intToUtf8)
  }
}

is_windows <- function() {
  tolower(Sys.info()[["sysname"]]) == "windows"
}
paste0_stop <- function(...) stop(paste0(...), call. = FALSE)

asrt <- function (expr, ...) if (!expr) paste0_stop(...)
is_integer <- function(x) {
  is.integer(x) || (is.numeric(x) && all(x == as.integer(x)))
}

is_count <- function(x) {
  is_integer(x) && length(x) == 1 && x >= 0
}

is_flag <- function(x) {
  is.logical(x) && length(x) == 1 && !is.na(x)
}

point_distance <- function(x) {
  d <- diff(x)
  sqrt(d[, 1]^2 + d[, 2]^2)
}

seq_multiple <- function(start, end, n) {
  f <- function(x, y, z) {
    sq <- seq(from = x, to = y, length.out = z)
    # remove start since it will be duplicated by end of previous seqment
    sq[-1]
  }
  # interpolate evenly between a series of points
  sq_mult <- mapply(f, start, end, n, SIMPLIFY = FALSE)
  # combine seqments, need to add overall start point
  c(start[1], do.call(c, sq_mult))
}
describe_df <- function(x) {
  sprintf("\\code{data.frame} with %d observations of the following %d variables,",
          nrow(x), ncol(x))
}

df_format <- function(x) {
  template <- "%s\n\\describe{\n%s\n}"
  items <- sapply(names(x),
                  function(i) sprintf("\\item{\\code{%s}}{%s}", i,
                                      ifelse(is.null(comment(x[[i]])), i, comment(x[[i]]))))
  sprintf(template, describe_df(x), paste(items, collapse="\n"))
}
table.row <- function(vecdat, vect) {
      # vecdat es el vector que se quiere arreglar segun los valores de vect
      table(c(vecdat, vect)) - 1
}
# example: m<-matrix(1:9,3,3) t(apply(m,1,table.row,1:9)) 1 2 3 4 5 6 7 8 9 [1,] 1 0 0 1 0 0 1 0 0 [2,] 0 1 0 0 1 0 0 1 0
# [3,] 0 0 1 0 0 1 0 0 1

# ---------------------------------------------------------------------------------------#

min.greater <- function(v, x, ge = TRUE) {
      # I construct this function to obtain percentiles from a empirical distribution.  This form is to allow obtaining it for
      # a matrix of distributions. v is a vector x is a value
      if (ge) {
            res <- min(which(v >= x))
      } else {
            res <- min(which(v > x))
      }
      res
}
#' Sodium Utilities
#'
#' The functions \code{bin2hex} and \code{hex2bin} convert between binary (raw)
#' vectors and corresponding string in hexadecimal notation. The \code{random}
#' function generates \code{n} crypto secure random bytes.
#'
#' @useDynLib sodium R_sodium_bin2hex
#' @export
#' @rdname helpers
#' @name Sodium utilities
#' @aliases helpers
#' @family sodium
#' @param bin raw vector with binary data to convert to hex string
#' @examples # Convert raw to hex string and back
#' test <- charToRaw("test 123")
#' x <- bin2hex(test)
#' y <- hex2bin(x)
#' stopifnot(identical(test, y))
#' stopifnot(identical(x, paste(test, collapse = "")))
#'
#' # Parse text with characters
#' x2 <- paste(test, collapse = ":")
#' y2 <- hex2bin(x2, ignore = ":")
#' stopifnot(identical(test, y2))
bin2hex <- function(bin){
  stopifnot(is.raw(bin))
  .Call(R_sodium_bin2hex, bin)
}

#' @useDynLib sodium R_sodium_hex2bin
#' @export
#' @rdname helpers
#' @param hex a string with hexadecimal characters to parse into a binary (raw) vector.
#' @param ignore a string with characters to ignore from \code{hex}. See example.
hex2bin <- function(hex, ignore = ":"){
  stopifnot(is.character(hex))
  stopifnot(length(hex) == 1)
  stopifnot(is.character(ignore))
  stopifnot(length(ignore) == 1)
  .Call(R_sodium_hex2bin, hex, ignore)
}

#' @useDynLib sodium R_randombytes_buf
#' @export
#' @rdname helpers
#' @param n number of random bytes or numbers to generate
random <- function(n = 1){
  stopifnot(is.numeric(n))
  .Call(R_randombytes_buf, as.integer(n))
}

#' @useDynLib sodium R_xor
xor <- function(x, y){
  stopifnot(is.raw(x))
  stopifnot(is.raw(y))
  .Call(R_xor, x, y)
}
# Find duplicate values in a list of strings
find_duplicate_strings <- function(x) {
    unique(x[duplicated(x)])
}

# Get an attribute for each element in a list
list_attrs <- function(x, a) {
    sapply(X = x, FUN = function(x) attr(x, a))
}

# Set multiple attributes for an object
set_attributes <- function(x, attrs = list()) {
    for (key in names(attrs)) attr(x, key) <- attrs[[key]]
    x
}

# Raise an error if a required package is not installed
stop_without_package <- function(package) {
    if (!requireNamespace(package, quietly = TRUE)) {
        stop(sprintf("This function requires the '%s' package", package),
             call. = FALSE)
    }
}
#' @importFrom utils modifyList packageVersion

formatSolveBioResponse <- function (res, raw = FALSE) {
    url = res$url
    body = httr::content(res, as="text", encoding="UTF-8")
    if (raw) {
        return(body)
    } else {
        # Only simplify uniform JSON dictionary responses
        # as data frames. These responses include
        # resource GET requests (list and detail)
        # as well as dataset queries.
        res = jsonlite::fromJSON(body,
                                 simplifyVector = FALSE,
                                 simplifyDataFrame = TRUE,
                                 simplifyMatrix = FALSE)
        res$'_url' = url
        return(res)
    }
}

formatSolveBioQueryResponse <- function (res, raw = FALSE) {
    # res will be the output of formatSolveBioResponse
    if (!raw & is.data.frame(res$results)) {
        # Flatten the data frame
        res$results <- jsonlite::flatten(res$results)
    } else {
        res$results <- as.data.frame(res$results)
    }
    return(res)
}

prepareArgs <- function (args) {
    if (!is.null(args) && length(args) > 0) {
        args = args[!sapply(args, is.null)]
        rapply(args, function (x) {
                   ifelse(is.logical(x), x * 1, x)
                                 }, how="replace")
    } else {
        NULL
    }
}
#####################################################
# Name: utils.R                                     #
# Author: Chris Jewell <c.jewell@lancaster.ac.uk>   #
# Created: 20161206                                 #
# Copyright: Chris Jewell 2016                      #
# Purpose: Miscellaneous helper functions           #
#####################################################


isFiniteInteger = function(x)
{
  int = x
  mode(x) = 'integer'
  is.finite(x) & isTRUE(all.equal(x, int))
}
isFiniteLogical = function(x)
{
  is.finite(x) & is.logical(x)
}
isFinitePositive = function(x)
{
  is.finite(x) & x > 0
}
isFinitePositiveInteger = function(x)
{
  isFiniteInteger(x) & isFinitePositive(x)
}
isProb = function(x)
{
  is.finite(x) & x >= 0 & x <= 1
}

arrayextend = function(x, along, size, newdimnames)
{
  oldDims = dim(x)
  newdim = oldDims
  newdim[along] = newdim[along] + size
  rnames = dimnames(x)
  rnames[along] = newdimnames
  newarray = tensorA::to.tensor(NA, dim=rnames)
  args = list(newarray)
  args = append(args, lapply(oldDims, function(x) 1:x))
  args[[length(args)+1]] = x
  do.call('[<-',args)
}

#' Slices a tensorA::tensor
#'
#' Slices a tensorA::tensor, preserving the dimnames.
#' This is a workaround for a buggy implementation of
#' [.tensor as of tensorA v0.36.
#' @param x tensor array to be sliced
#' @param ... arguments used to subset the sensor array
sliceTensor <- function(x,...) {
  class(x) <- 'array'
  x = tensorA::as.tensor.default(x[...])
  class(x) = append(class(x),'array')
  x
}
search_objects <- function() {
  lapply(seq_along(search()), function(i) {
    ls(pos = i, all.names = TRUE)
  })
}
crps <- function(y, y.hat, y.var){
    sd <- sqrt(y.var)
    y.std <- (y-y.hat)/sd
    mean(-sd*(1/sqrt(pi) - 2*dnorm(y.std) - y.std*(2*pnorm(y.std) - 1)))
}

rmspe <- function(y, y.hat){
    sqrt(mean((y-y.hat)^2))
}

get.n.indx <- function(i, m){
    i <- i-1
    if(i == 0){
        return(NA)
    }else if(i < m){
        n.indx.i <- i/2*(i-1)
        m.i <- i
        return((n.indx.i+1):((n.indx.i+1)+i-1))
    }else{
        n.indx.i <- m/2*(m-1)+(i-m)*m
        m.i <- m
        return((n.indx.i+1):((n.indx.i+1)+m-1))
    }
}

mk.n.indx.list <- function(n.indx, n, m){
    n.indx.list <- vector("list", n)
    n.indx.list[1] <- NA
    for(i in 2:n){
        n.indx.list[[i]] <- n.indx[get.n.indx(i, m)]+1
    }
    n.indx.list
}
# ~ try() but catches warnings : 
## Catch *and* save both errors and warnings, and in the case of
## a warning, also keep the computed result.
.tryCatch_W_E <- function(expr) {
  W <- NULL
  w.handler <- function(w){ # warning handler
    W <<- w
    invokeRestart("muffleWarning")
  }
  list(value = withCallingHandlers(tryCatch(expr, error = function(e) e),
   				     warning = w.handler),
       warning = W)
}

.minimalErrorHandler <- function(cond) invisible(structure("See 'condition' attribute", class = "try-error", condition = cond))

## meeting the width.cutoff in deparse :-(
.DEPARSE <- function(expr) { paste(deparse(expr),collapse="") }

overcat <- function(msg, prevmsglength) {
  if (prevmsglength>0) {cat("\r")}    
  cat(msg)
  return(nchar(msg))
}

# removed all 'pastefrom' code in version 2.2.44

## quite ad hoc
.prettify_num <- function(x,nsmall=2L) {
  if (abs(x)>1) {
    Ldigits <- floor(log10(abs(x)))+nsmall+1L
    format(round(x,Ldigits), digits=nsmall, nsmall=nsmall) ## character !
  } else signif(x,6) ## double !
}
# ~ try() but catches warnings : 
## Catch *and* save both errors and warnings, and in the case of
## a warning, also keep the computed result.
.tryCatch_W_E <- function(expr) {
  W <- NULL
  w.handler <- function(w){ # warning handler
    W <<- w
    invokeRestart("muffleWarning")
  }
  list(value = withCallingHandlers(tryCatch(expr, error = function(e) e),
   				     warning = w.handler),
       warning = W)
}

.minimalErrorHandler <- function(cond) invisible(structure("See 'condition' attribute", class = "try-error", condition = cond))

## meeting the width.cutoff in deparse :-(
.DEPARSE <- function(expr) { paste(deparse(expr),collapse="") }

overcat <- function(msg, prevmsglength) {
  if (prevmsglength>0) {cat("\r")}    
  cat(msg)
  return(nchar(msg))
}

# removed all 'pastefrom' code in version 2.2.44

## quite ad hoc
.prettify_num <- function(x,nsmall=2L) {
  if (abs(x)>1) {
    Ldigits <- floor(log10(abs(x)))+nsmall+1L
    format(round(x,Ldigits), digits=nsmall, nsmall=nsmall) ## character !
  } else signif(x,6) ## double !
}
#
#============== Utility functions
#

# showTrace <- function(it)
#   # Print iteration number
# {
#   replicate(expr = {
#     cat( paste0(rep("\b", getOption("width")), collapse = "") )
#     flush.console()
#     }, n = 2 )
#   cat( paste(" MCMC - iter", it, "\n") )
#   flush.console()
# }


list2array <- function(L)
  # Convert a list of matrices to an array
{
  array( unlist(L), dim = c(dim(L[[1]]), length(L)) )
}
which_max <- function(x, tolerance = .Machine$double.eps^0.5) {
  which(abs(max(x) - x) < tolerance)
}

#' @importFrom utils installed.packages

is_installed <- function(pkg) {
  pkg %in% rownames(installed.packages())
}
spark_expect_jobj_class <- get("spark_expect_jobj_class",
                               envir = asNamespace("sparklyr"))

spark_normalize_path <- get("spark_normalize_path",
                            envir = asNamespace("sparklyr"))

spark_sqlresult_from_dplyr <- get("spark_sqlresult_from_dplyr",
                                  envir = asNamespace("sparklyr"))
###################
# DISTANCE RELATED
###################

################## ----------------------------- ########################
#@desc  convertes degrees in radians. similar to the python radians() function
radians <- function( degrees ){
  return( degrees * pi / 180 )
}

################## ----------------------------- ########################
#@desc  
#@source  http://www.movable-type.co.uk/scripts/latlong.html 
p2pdistance <- function(start, end){
  R = 6378 # earth radius in km
  lat1=as.numeric(start[1]); lon1=as.numeric(start[2])
  lat2=as.numeric(  end[1]); lon2=as.numeric(  end[2])
  dlat = radians(lat2-lat1)
  dlon = radians(lon2-lon1)
  a = sin(dlat/2)*sin(dlat/2)+cos(radians(lat1))*cos(radians(lat2))*sin(radians(dlon/2))*sin(radians(dlon/2))
  c = 2* atan2(sqrt(a), sqrt(1-a))
 return( R * c )
}

###################
# MATRIX PROCESSING
###################

################## ----------------------------- ########################
#@desc  
#@source  
matrix_is_na <- function( m ){
  for( i in 1:nrow( m ) )
    for( j in 1:nrow( m ) )
      if( ! is.na( m[i,j] ) ){      
       return( F )
      }
  return( T )
}


##########################
# SNA FUNCTIONS UNASIGNED 
##########################

################## ----------------------------- ########################
#@desc    function that outputs the compound of two networks without including
#         the diagonal.
#@source  90105 Fundamentals of social network homeworks

CR <- function( m1 , m2 , binary=T){
  diag(m1) <- diag(m2)<-0
  m3 <- m1 %*% m2
  diag( m3 )
  if( binary ){
    m3[ m3>0 ] <- 1
  }
  return( m3 )
}
#'
#'   utiloptim.R
#'
#'   Utilities for optimization
#'
#'  $Revision: 1.3 $  $Date: 2017/02/09 00:46:51 $
#'

optimizeWithTrace <- local({

  tracer <- function(x, ..., .TheFunction, .Enviro) {
    y <- .TheFunction(x, ...)
    xx <- get("xx", envir=.Enviro)
    yy <- get("yy", envir=.Enviro)
    assign("xx", c(xx, as.numeric(x)), envir=.Enviro)
    assign("yy", c(yy, y), envir=.Enviro)
    return(y)
  }
  
  optimizeWithTrace <- function(f, interval, ..., 
                                lower = min(interval), upper = max(interval)) {
    e <- new.env()
    assign("xx", numeric(0), envir=e)
    assign("yy", numeric(0), envir=e)
    result <- optimize(tracer, lower=lower, upper=upper,
                       ..., .TheFunction=f, .Enviro=e)
    result$x <- get("xx", envir=e)
    result$y <- get("yy", envir=e)
    rm(e)
    return(result)
  }

  optimizeWithTrace
})
has_names <- function(x) {
  nms <- names(x)
  if (is.null(nms)) {
    rep(FALSE, length(x))
  } else {
    !is.na(nms) & nms != ""
  }
}


has_data <- function(x) .hasSlot(x, "data")

#' @importFrom methods .hasSlot
#' @importFrom sp bbox proj4string 
#' @importFrom tibble as_tibble 
.print_Spatial <- 
  function (x, ...) 
  {
    cat("class       :", class(x), "\n")
    isRaster <- hasData <- FALSE
    nc <- 0
    if (has_data(x)) {
      hasData <- TRUE
      nc <- ncol(x@data)
    }
    ln <- 1
    
    ln <- length(x)
    cat("features    :", ln, "\n")
    
    e <- bbox(x)
    if (ln > 0) {
      cat("extent      : ", e[1, 1], ", ", e[1, 2], ", ", e[2, 
                                                            1], ", ", e[2, 2], "  (xmin, xmax, ymin, ymax)\n", 
          sep = "")
    }
    cat("coord. ref. :", proj4string(x), "\n")
    if (hasData) {
      x <- x@data
      maxnl <- 15
      if (!isRaster) {
        cat("variables   : ", nc, "\n", sep = "")
      }
      if (!inherits(x, "tbl_df")) x <- tibble::as_tibble(x)
      print(x)
    }
  }

#' Sp methods
#' @param object Spatial object
#' @param x Spatial object
#' @param ... ignored
#' @title sp methods
#' @rdname sp-methods
#' @export
#' @importFrom methods show 
setMethod("show", "SpatialPolygonsDataFrame", 
          function(object) {
            .print_Spatial(object)
          }
          
)

#' @rdname sp-methods
#' @export
setMethod("show", "SpatialLinesDataFrame", 
          function(object) {
            .print_Spatial(object)
          }
)

#' @rdname sp-methods
#' @export
setMethod("show", "SpatialPointsDataFrame", 
          function(object) {
            .print_Spatial(object)
          }
)

#' @rdname sp-methods
#' @export
setMethod ('print' , 'Spatial', 
           function(x, ...) {
             .print_Spatial(x)
           }
)
#' @importFrom utils tail
new_name_from_these <- function(x) {
  utils::tail(make.names(c(x, "wasdfjsdk"), unique = TRUE), 1)
}


has_data <- function(x) .hasSlot(x, "data")


#' @importFrom sp bbox proj4string 
#' @importFrom dplyr  group_by
#' @importFrom tibble as_tibble
.print_Spatial <- 
function (x, ...) 
{
  cat("class       :", class(x), "\n")
  hasData <- FALSE
  nc <- 0

  if (has_data(x)) {
    hasData <- TRUE
    nc <- ncol(x@data)
  }
  ln <- 1
  ln <- length(x)
  cat("features    :", ln, "\n")

  e <- bbox(x)
  if (ln > 0) {
    cat("extent      : ", e[1, 1], ", ", e[1, 2], ", ", e[2, 
                                                          1], ", ", e[2, 2], "  (xmin, xmax, ymin, ymax)\n", 
        sep = "")
  }
  cat("coord. ref. :", proj4string(x), "\n")
  if (hasData) {
    x <- x@data
    cat("variables   : ", nc, "\n", sep = "")
    if (!inherits(x, "tbl_df")) x <- as_tibble(x)
    print(x)
  } 
  invisible(NULL)
}

#' Sp methods
#' @param object Spatial object
#' @title sp methods
#' @importFrom methods show .hasSlot
#' @rdname sp-methods
#' @export
setMethod ('show' , 'Spatial', 
           function(object) {
             .print_Spatial(object)
           }
)
#' @rdname sp-methods
#' @export
setMethod ('show' , 'SpatialPoints', 
           function(object) {
             .print_Spatial(object)
           }
)


release_questions <- 
  c("Have you single-quoted package and other non-English names in the DESCRIPTION and TITLE?\nhttps://cran.r-project.org/doc/manuals/r-release/R-exts.html#The-DESCRIPTION-file", 
  c("Have you manually inspected your rendered vignettes?"))
# Copyright 2014 by Dmitry Pavlyuk <Dmitry.V.Pavlyuk@gmail.com>

#
# Routines for logging
#

# Available logging levels
.loggingLevels <- c("quiet","warn","info","debug")

#
# Logs a message, an (optional) object, and caller function's name to console
#
logging <- function(message, obj = NULL, level = "debug", caller = sys.call(-1)){
        lvl <- envirGet("logging")
        if (!is.null(lvl) 
                && ((which(.loggingLevels == lvl) >=    which(.loggingLevels == level)))){
                message(toupper(level)," ", toString(caller[[1]])," (pid=",Sys.getpid(),") ", message)
                if (!is.null(obj)){
                        print(obj)
                }
                flush.console()
        }
}
##' sum specified columns by time
##'
##' @param data a dataframe
##' @param vars column variables in data to sum over
getTimeCounts <- function(data, vars) {
    ## if ( missing(by) ) {
    ##     by <- 'time'
    ## } else {
    ##     by <- c('time', by)
    ## }
    ddply(data, "time", colwise(sum, vars))
}

##' checks convergence of the parameters for the estimation functions
##'
##' @param theta an object, convertible to a matrix, of current parameter values
##' @param theta_old an object, convertible to a matrix, of old parameter values
##' @param eps tolerance to determine convergence
converged <- function(theta, theta_old, eps=1e-5) {
    isTRUE(all.equal(theta, theta_old, tolerance=eps, check.names=F, check.attr=F))
}

## sum over species to get a vector of values for each time period
sumSp <- function(mat) {
    matrix(rowSums(mat), nrow=nrow(mat))
}

## sum over times to get a vector of values for each species
sumT <- function(mat) {
    matrix(colSums(mat), ncol=ncol(mat))
}

sumST <- function(mat) {
    sum(mat)
}

## colors stolen from http://geography.uoregon.edu/datagraphics/color_scales.htm
cols <- c(orange1="#FFBF80", orange2="#FF8000",
          yellow1 = "#FFFF99", yellow2="#FFFF33",
          green1 = "#B2FF8C", green2="#33FF00",
          blue1 = "#A6EDFF", blue2="#1AB2FF",
          purple1 = "#CCBFFF", puple2="#664CFF",
          red1 = "#FF99BF", red2="#E61A33")
#' Convert a Base64 encoded string into an R object
#'
#' A simple wrapper around calls to `openssl::base64_decode()` and
#' `jsonlite::fromJSON()`.
#'
#' @md
#' @param x a string
#' @param flatten flatten JSON structures upon conversion?
#' @param ... passed on to `jsonlite::fromJSON()`
#' @export
json_fromb64 <- function(x, flatten=TRUE, ...) {

  tmp <- openssl::base64_decode(x)
  tmp <- readBin(tmp, "character")
  jsonlite::fromJSON(tmp, flatten=flatten, ...)

}
## This is from 'fBasics',  but so small we will not import
## nor export, but just use it ...

## Now needs R >= 3.1.0 with its new argument(s) 'extendInt' etc
.unirootNA <-
    function(f, interval, ...,
             lower = min(interval), upper = max(interval),
             f.lower = f(lower, ...), f.upper = f(upper, ...),
             extendInt = c("no", "yes", "downX", "upX"),
             check.conv = FALSE,
             tol = .Machine$double.eps^0.25, maxiter = 1000, trace = 0)
{
    # Arguments:
    #   see 'uniroot'

    # Value:
    #   Returns the x value of f where the root is located. If
    #   no root exists,  NA will be returned instead. In that case,
    #   the function doesn't terminate with an error  as
    #   the standard function uniroot().

    # Example:
    #   .unirootNA(sin, c(1, 2)); .unirootNA(sin, c(-1, 1))

    # If there is no Root:
    if(is.na(f.lower) || is.na(f.upper) || f.lower * f.upper > 0)
        return(NA)
    ## else there is one :
    uniroot(f, interval = interval, ...,
            lower=lower, upper=upper, f.lower=f.lower, f.upper=f.upper,
	    extendInt=extendInt, check.conv=check.conv,
	    tol=tol, maxiter=maxiter, trace=trace)$root
}

## Not exported, and only used because CRAN checks must be faster
doExtras <- function() {
    interactive() || nzchar(Sys.getenv("R_STABLEDIST_CHECK_EXTRA")) ||
        identical("true", unname(Sys.getenv("R_PKG_CHECKING_doExtras")))
}
#' Identify date sequences
#'
#' For correctly plotting country-time period spells
#'
#' @param x a Date sequence
#' @param pd what is the time aggregation period in the data?
#'
#' @export
#'
#' @examples
#' library("ggplot2")
#' d1 <- as.Date("2018-01-01")
#' d2 <- as.Date("2025-01-01")
#' seq1 <- seq(d1, d2, by = "year")
#' data.frame(seq1, id=id_date_sequence(seq1, "year"))
#' # With a gap, should be two ids
#' df <- data.frame(date = seq1[-4], id=id_date_sequence(seq1[-4], "year"), cowcode = 999)
#' df
#'
#' # The point is to plot countries with interrupted independence correctly:
#' df$y <- c(rep(1, 3), rep(2, 4))
#' df$id <- paste0(df$cowcode, df$id)
#' df
#' ggplot(df, aes(x = date, y = y, group = cowcode)) + geom_line()
#' ggplot(df, aes(x = date, y = y, group = id)) + geom_line()
id_date_sequence <- function(x, pd) {
  diff_days <- diff(x)
  divisor <- NA
  if (pd=="month") divisor <- 365.25/12
  if (pd=="week") divisor <- 7
  if (pd=="year") divisor <- 365.25
  if (pd=="day") divisor <- 1
  if (is.na(divisor)) stop("Did not recognize time period")
  xx <- c(1, round(diff_days / divisor))
  cumsum(xx!=1) + 1
}
# test if object has attribute
#
# @param x object
# @param which character; names of possible attributes
#
# @note not exported

has_attr <- function(x, which) {

  which %in% names( attributes(x) )

}
# UTILITIES  ---------------------------------------------------------------



skewness <- function(x, na.rm = TRUE) {
  if (na.rm) x <- x[!is.na(x)]
  n <- length(x)
  M3 <- sum((x - mean(x)) ^ 3) / n
  M2 <- sum((x - mean(x)) ^ 2) / n
  skew <- M3 / M2 ^ (3 / 2)
  return(skew)
}

modefreq <- function(x) {
  # compute mode(s) and associated frequency; works with factors and handles NA
  ## adaptation from: https://stackoverflow.com/questions/2547402/is-there-a-built-in-function-for-finding-the-mode
  ux <- unique(x)
  tab <- tabulate(match(x, ux))
  mode <- ux[tab == max(tab)]
  if(is.na(mode[1])) freq=sum(is.na(x))/length(x) else freq=sum(x==mode[1],na.rm=TRUE)/length(x)
  return(list(mode=mode,freq=freq))
}

# #'@export
# install.weirdness <- function(upgrade=FALSE,github=TRUE,...){
#   # check with weirds and (re)install packages
#   # ... : paramaters to be passed to install or install_github (if github=TRUE)
# }
#' @useDynLib strat
#' @importFrom Rcpp evalCpp
NULL


wtd_rank <- function (x, weights = NULL, normwt = FALSE, na.rm = TRUE){
  if (!length(weights))
    return(rank(x, na.last = if (na.rm) NA else TRUE))
  tab <- Hmisc::wtd.table(x, weights, normwt = normwt, na.rm = na.rm)
  freqs <- tab$sum.of.weights
  r <- cumsum(freqs) - 0.5 * (freqs - 1)
  stats::approx(tab$x, r, xout = x, rule = 2)$y
}

clean <- function(outcome, strata, weights = NULL, group = NULL){

    # check input
    if (!length(weights))
        weights <- rep(1, length(outcome))
    if (!length(group))
        group <- rep(1, length(outcome))

    # error messages
    if (!is.numeric(outcome) || !length(outcome))
        stop("outcome has to be a numeric vector")
    if (!is.numeric(weights))
        stop("weights has to be a numeric vector")
    if (length(outcome) != length(strata))
        stop("outcome and strata have to be of equal length")
    if (length(outcome) != length(weights))
        stop("outcome and weights have to be of equal length")
    if (length(outcome) != length(group))
        stop("outcome and group have to be of equal length")

    # return a data frame
    ok <- stats::complete.cases(outcome, strata, weights)
    n <- sum(ok)
    if (n==0) stop("no complete cases!")
    outcome <- outcome[ok]
    strata <- factor(strata[ok])
    weights <- weights[ok]/sum(weights[ok]) * n
    group <- factor(group[ok])
    prank <- wtd_rank(outcome, weights, normwt = TRUE, na.rm=TRUE)/n
    out <- data.frame(prank, strata, weights, group)
    return(out)
}

.onUnload <- function (libpath) {
  library.dynam.unload("strat", libpath)
}
#' Pipe operator
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @export
#' @importFrom magrittr %>%
#' @usage lhs \%>\% rhs
NULL
#' @importFrom magrittr %>%
NULL


#' @useDynLib striprtf
#' @importFrom Rcpp sourceCpp
NULL
is_windows <- function ()
{
  identical(tolower(Sys.info()[["sysname"]]), 'windows')
}

is_linux <- function ()
{
  identical(tolower(Sys.info()[["sysname"]]), 'linux')
}

known_signals <- function ()
{
  .Call("C_known_signals")
}
## helper functions ------------------
min_na <- function(x) {
  min(x, na.rm = TRUE)
}

max_na <- function(x) {
  max(x, na.rm = TRUE)
}

expand.grid2 <- function(...) {
  expand.grid(..., KEEP.OUT.ATTRS = FALSE, stringsAsFactors = FALSE)
}

is_constant <- function(x) {
  return(diff(range(x, na.rm = TRUE)) < .Machine$double.eps ^ 0.5)
}

# Normalise the numerics to range from 0 to 1
normalise <- function(x, xmin = NULL, xmax = NULL) {
  if (is_constant(x)) return(x)
  if (is.null(xmin)) xmin <- min_na(x)
  if (is.null(xmax)) xmax <- max_na(x)
  return((x - xmin) / (xmax - xmin))
}

min_diff <- function(x) {
  return(min(abs(diff(x, na.rm = TRUE))))
}
possibly_quosure <- function(x) {
  check <- try(is_quosure(x), silent = TRUE)
  ifelse(class(check) != "try-error", TRUE, FALSE)
}

possibly_identity <- function(x) { # x can be a list or a vector
  any(vapply(x, function(x) x == 1, logical(1)))
}

dots2str <- function(...) { # list
  peel <- map(..., get_expr) # quosure to expr
  strs <- map_chr(peel, deparse) # expr to string
  return(strs) # return a vector of characters
}
.buildData <- function(date = NULL, lat = NULL, lon = NULL, data = NULL){
  # data control
  if(!is.null(data)){
    if(!is.null(date) | !is.null(lat) | !is.null(lon)){
      stop("Must use only 'data' argument, or 'date', 'lat', and 'lon' together. See examples")
    }
    
    if(!isTRUE(all.equal("data.frame", class(data)))){
      data <- data.frame(data)
    }
    
  } else {
    if(is.null(date) | is.null(lat) | is.null(lon)){
      stop("Must use only 'data' argument, or 'date', 'lat', and 'lon' together. See examples")
    }
    
    if(length(lat) > 1){
      stop("'lat' must be a unique element. Use 'data' for multiple 'lat'")
    }
    if(length(lon) > 1){
      stop("'lon' must be a unique element. Use 'data' for multiple 'lon'")
    }
    data <- data.frame(date = date, lat = lat, lon = lon, stringsAsFactors = FALSE)
  }
  
  stopifnot(all(c("date", "lat", "lon") %in% colnames(data)))
  
  return(data)
}

.buildRequestDate <- function(date){
  if(!any(c("Date", "POSIXct", "character") %in% class(date))){
    stop("date must to be a Date object (class Date) or POSIXct or character")
  }
  request_date <- date
  if("POSIXct" %in% class(date)){
    if(is.null(attr(date, "tzone"))){
      attr(request_date, "tzone") <- "UTC"
      warning("'date' is convert to 'UTC' for request using 'attr(date, 'tzone') <- 'UTC'")
    } else if(attr(date, "tzone") != "UTC"){
      attr(request_date, "tzone") <- "UTC"
      warning("'date' is convert to 'UTC' for request using 'attr(date, 'tzone') <- 'UTC'")
    }
  }
  request_date
}
my.sort <- function(x,index.return=FALSE,decreasing=FALSE) {
	if(decreasing) 
		x <- -x
	y <- sort(x, method="quick", index.return=index.return)
	if(decreasing) 
		y$x <- -y$x
	y
}


################################################################
###				step function                    			 ###
################################################################
## x		- x-Werte
## y		- y-Werte
## z		- neue x-Werte



seval <- function(x,y,z){
	n_x <- length(x)
	n_z <- length(z)
	xz_new <- rep(0,n_x) 
	ans <- .C("step_eval_R",
			  as.numeric(xz_new),
			  as.numeric(z), 
			  as.numeric(x), 
			  as.numeric(y), 
			  as.integer(n_z),
			  as.integer(n_x),
			  PACKAGE="survAUC")
	ans[[1]]
}
mini_plot <- function(...) graphics::plot(..., axes = FALSE, xlab = "", ylab = "")

plot_dim <- function(dim = c(NA, NA)) {
  if (any(is.na(dim))) {
    if (length(grDevices::dev.list()) == 0) {
      default_dim <- c(7, 7)
    } else {
      default_dim <- grDevices::dev.size()
    }

    dim[is.na(dim)] <- default_dim[is.na(dim)]
    dim_f <- prettyNum(dim, digits = 3)

    message("Saving ", dim_f[1], "\" x ", dim_f[2], "\" image")
  }

  dim
}

vapply_chr <- function(.x, .f, ...) {
  vapply(.x, .f, character(1), ...)
}
vapply_lgl <- function(.x, .f, ...) {
  vapply(.x, .f, logical(1), ...)
}
lapply_if <- function(.x, .p, .f, ...) {
  if (!is.logical(.p)) {
    .p <- vapply_lgl(.x, .p)
  }
  .x[.p] <- lapply(.x[.p], .f, ...)
  .x
}
keep <- function(.x, .p, ...) {
  .x[vapply_lgl(.x, .p, ...)]
}
compact <- function(x) {
  Filter(length, x)
}
`%||%` <- function(x, y) {
  if (is.null(x)) y else x
}
is_scalar_character <- function(x) {
  is.character(x) && length(x) == 1
}
names2 <- function(x) {
  names(x) %||% rep("", length(x))
}
ilapply <- function(.x, .f, ...) {
  idx <- names(.x) %||% seq_along(.x)
  out <- Map(.f, names(.x), .x, ...)
  names(out) <- names(.x)
  out
}
ilapply_if <- function(.x, .p, .f, ...) {
  if (!is.logical(.p)) {
    .p <- vapply_lgl(.x, .p)
  }
  .x[.p] <- ilapply(.x[.p], .f, ...)
  .x
}
set_names <- function(x, nm = x) {
  stats::setNames(x, nm)
}
zip <- function(.l) {
  fields <- set_names(names(.l[[1]]))
  lapply(fields, function(i) {
    lapply(.l, .subset2, i)
  })
}

svglite_manual_tests <- new.env()
register_manual_test <- function(file) {
  testthat_dir <- getwd()
  testfile <- file.path(testthat_dir, file)
  assign(file, testfile, svglite_manual_tests)
}
init_manual_tests <- function() {
  remove(list = names(svglite_manual_tests), envir = svglite_manual_tests)
}
open_manual_tests <- function() {
  lapply(names(svglite_manual_tests), function(test) {
    utils::browseURL(svglite_manual_tests[[test]])
  })
}
# This function was 'borrowed' from hadley/devtools
# check whether the specified file ends with newline
ends_with_newline <- function(path) {
  conn <- file(path, open = "rb", raw = TRUE)
  on.exit(close(conn))
  seek(conn, where = -1, origin = "end")
  lastByte <- readBin(conn, "raw", n = 1)
  lastByte == 0x0a
}

# Takes a plain English name and turns it into a more proper 
# file/directory name

#' @importFrom stringr str_trim
make_pathname <- function(name) {
  gsub(" ", "_", str_trim(name))
}

# Borrowed from hadley/devtools
rule <- function(title = "") {
  width <- getOption("width") - nchar(title) - 1
  message("\n", title, paste(rep("-", width, collapse = "")), "\n")
}
#' Package config
#'
#' Shows which features are enabled in the package configuration.
#'
#' @export
#' @rdname config
#' @examples sys_config()
sys_config <- function(){
  list(
    safe = safe_build(),
    apparmor = have_apparmor()
  )
}

#' @rdname config
#' @export
aa_config <- function(){
  status <- aa_getcon()
  list(
    compiled = have_apparmor(),
    enabled = aa_is_enabled(),
    con = status$con,
    mode = status$mode
  )
}

#' @useDynLib sys R_freeze
freeze <- function(interrupt = TRUE){
  .Call(R_freeze, as.logical(interrupt))
}

#' @useDynLib sys R_safe_build
safe_build <- function(){
  .Call(R_safe_build)
}

#' @useDynLib sys R_have_apparmor
have_apparmor <- function(){
  .Call(R_have_apparmor)
}

#' @useDynLib sys R_aa_is_enabled
aa_is_enabled <- function(){
  .Call(R_aa_is_enabled)
}

#' @useDynLib sys R_aa_getcon
aa_getcon <- function(){
  out <- .Call(R_aa_getcon)
  if(!length(out))
    return(out)
  structure(out, names = c("con", "mode"))
}

#' @useDynLib sys R_set_tempdir
set_tempdir <- function(path){
  path <- normalizePath(path)
  if(!file.exists(path))
    dir.create(path)
  .Call(R_set_tempdir, path)
}

#' @useDynLib sys R_set_interactive
set_interactive <- function(set){
  stopifnot(is.logical(set))
  .Call(R_set_interactive, set)
}

#' @useDynLib sys R_aa_change_profile
aa_change_profile <- function(profile){
  stopifnot(is.character(profile))
  .Call(R_aa_change_profile, profile)
}

#' @useDynLib sys R_setuid
setuid <- function(uid){
  stopifnot(is.numeric(uid))
  .Call(R_setuid, as.integer(uid))
}

#' @useDynLib sys R_setgid
setgid <- function(gid){
  stopifnot(is.numeric(gid))
  .Call(R_setgid, as.integer(gid))
}

#' @useDynLib sys R_set_priority
set_priority <- function(priority){
  stopifnot(is.numeric(priority))
  .Call(R_set_priority, as.integer(priority))
}

#' @useDynLib sys R_set_rlimits
set_rlimits <- function(rlimits){
  rlimits <- do.call(parse_limits, as.list(rlimits))
  .Call(R_set_rlimits, rlimits)
}
#' Multiple assignment operator
#' 
#' Assign multiple variables from a list or function return object
#' 
#' @param l the variables to be assigned
#' @param r the list or function-return object
#' 
#' @aliases g
#' 
#' @export
'%=%' = function(l,r) UseMethod('%=%')

# Binary Operator
#' @export
'%=%.lbunch' = function(l,r) {
  Envir = as.environment(-1)
  
#   if (length(r) > length(l))
#     warning("RHS has more args than LHS. Only first", length(l), "used.")
  
  if (length(l) > length(r))  {
    warning("LHS has more args than RHS. RHS will be repeated.")
    r <- extendToMatch(r, l)
  }
  
  for (II in 1:length(l)) {
    do.call('<-', list(l[[II]], r[[II]]), envir=Envir)
  }
}

# Used if LHS is larger than RHS
extendToMatch <- function(source, destin) {
  s <- length(source)
  d <- length(destin)
  
  # Assume that destin is a length when it is a single number and source is not
  if(d==1 && s>1 && !is.null(as.numeric(destin)))
    d <- destin
  
  dif <- d - s
  if (dif > 0) {
    source <- rep(source, ceiling(d/s))[1:d]
  }
  return (source)
}

# Grouping the left hand side
#' @export
g = function(...) {
  List = as.list(substitute(list(...)))[-1L]
  class(List) = 'lbunch'
  return(List)
}
is.fachar <- function(x) is.character(x) | is.factor(x)


replace_style<- function(tableHTML, split, style, condition = NULL){
  
  if (is.null(condition)) {
    condition <- rep(TRUE, attr(tableHTML, "nrows"))
  }
  
  tableHTML <- gsub(paste(split, "style="), 
                    paste0(split), tableHTML)
  
  splits <- strsplit(tableHTML, split)
  
  splits[[1]][2:length(splits[[1]])] <- 
    vapply(2:length(splits[[1]]), function(i) {
      x <- splits[[1]][i]
      #check if style should be applied
      if (condition[i - 1]) {
        paste0(split,' ', style[i - 1], x)
      } else {
        #if not, check if style was applied from previous functions
        # or if rowspan attribute present
        if (substr(x, 1, 1) == ">" | substr(x, 1, 8) == " rowspan") {
          paste0(split, x)
        } else {
          paste0(split, ' style=', x)
        }
      }
      
    }, FUN.VALUE = character(1))
  
  gsub(';""', ';', paste(splits[[1]], collapse = ''))
  
}

convert_type <- function(v, type, levels) {
  switch(type,
         numeric = as.numeric(v),
         integer = as.integer(v),
         factor = if (is.null(levels)) {
           as.factor(v)
         } else {
           factor(v, levels = levels)
         },
         character = as.character(v))
}
## last modified 1-22-10 MF: fixed bug in transpose

# Transpose an array of 2 or 3 dimensions,
# where transposition is carried out on the first two dimensions:
transpose <- function(x) {
	# TODO: check for class matrix or array or something else suitable
	if (length(dim(x))==2) result = t(x)
	else if (length(dim(x))==3) result = aperm(x, c(2,1,3))
	else stop("Can't transpose")
	result
}

## Function to calculate a congruence coefficient
congruence.coef <- function(a,b){
	(t(a)%*%b) / sqrt( (t(a)%*%a) * (t(b) %*% b) )
	}
cg.cf <- congruence.coef

identity.coef <- function(a,b){
	2 * (t(a)%*% b) / ( (t(a)%*%a) + (t(b)%*%b) )
	}
id.cf <- identity.coef

## Function to facilitate the comparison of two or more factor patterns
## stored as a 3-dimensional array; if only two patterns, a matrix of 
## differences are calculated; if three of more patterns, a matrix of
## standard deviations are calculated

compare <- function(X){
	
	d1 <- dim(X)[1]
	d2 <- dim(X)[2]
	d3 <- dim(X)[3]
	
	if (d3 == 2) {
		
		Y <- array(NA, c(d1+1, (d2*2)+3, d3))
		Y[1:d1,1:d2,1:d3] <- X
		
		Y[1:d1, (d2+3):(dim(Y)[2]-1), 1] <- X[,,1]-X[,,2]
		for (i in 1:d1) { Y[i,d2+1,1] <- congruence.coef(X[i,,1], X[i,,2])*100 }
		for (j in 1:d2) { Y[d1+1,j,1] <- congruence.coef(X[,j,1], X[,j,2])*100 }
		Y[d1+1,d2+1,1] <- congruence.coef(as.vector(X[,,1]),as.vector(X[,,2]))*100
		
		for(i in 1:d1) { Y[i,dim(Y)[2],1] <- mean(abs(Y[i,(d2+3):(dim(Y)[2]-1),1]))}
		for(j in (d2+3):(dim(Y)[2]-1)) { Y[dim(Y)[1],j,1] <- mean(abs(Y[1:d1,j,1]))}
		Y[d1+1,(d2*2)+3,1] <- mean(abs(Y[1:d1,(d2+3):((d2*2)+2),1]))
		}
	
	if (d3 >= 3) {
		
		Y <- array(NA, c(d1+1, (d2*2)+2, d3))
		Y[1:d1,1:d2,1:d3] <- X
		
		for (i in 1:d1){
			for (j in 1:d2){
				Y[i,j+d2+1,1] <- sd(X[i,j,])
				}
			}
		
		for (i in 1:d1) { Y[i,dim(Y)[2],1] <- mean(Y[i,(d2+2):(d2+1+d2),1]) }
		for (j in (d2+2):(dim(Y)[2]-1)) { Y[dim(Y)[1],j,1] <- mean(Y[1:d1,j,1])}
		Y[d1+1,(d2*2)+2,1] <- mean(abs(Y[1:d1,(d2+2):((d2*2)+1),1]))
		}
		
	round(Y)
	
	}
#' @importFrom tibble as_tibble
mat2d_f <- function(x) {
  
  if (is.null(x)) {
    return(NULL)
  }
  tibble::as_tibble(x)
}
printf <- function( ... ) print( sprintf( ... ) )

catf <- function( ... ) cat( sprintf( ... ) )
## ceeboo 2008

tokenize <-
function(x, lines = FALSE, eol = "\n")
{
    if (!is.character(x))
        stop("'x' not a character")
    if (lines)
        x <- gsub("$", eol, x, perl = TRUE)
    # protect infix punctuation
    x <- unlist(strsplit(x, "\\b(?<!^|\\w[[:punct:]])(?![[:punct:]]\\w)",
                perl = TRUE))
    # split non-words
    i <- grep("^\\W+$", x, perl = TRUE)
    if (length(i)) {
        x <- as.list(x)
        x[i] <- lapply(x[i], strsplit, "\\B", perl = TRUE)
        return (unlist(x))
    }
    x
}

remove_stopwords <-
function(x, words, lines = FALSE)
{
    if (!is.character(x))
        stop("'x' not a character")
    if (!is.character(words))
        stop("'words' not a character")
    if (lines) {
        ## FIXME perl prefers partial matches. For now
	##       we protect hyphenated words and infix
	##       apostrophes.
        words <- paste("\\b(?<!-)(", paste(words, collapse = "|"),
            ")(?!(-|'\\b))\\b", sep = "", collapse = "")
        x <- gsub(words, "", x, ignore.case = TRUE, perl = TRUE)
    } else {
        i <- match(tolower(x), tolower(words))
        x <- x[is.na(i)]
    }
    x
}
#' Pipe operator
#'
#' See \code{magrittr::\link[magrittr]{\%>\%}} for details.
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @export
#' @importFrom magrittr %>%
#' @usage lhs \%>\% rhs
NULL
self    <- 'For R CMD CHECK'
private <- 'For R CMD CHECK'

not_implemented <- function() stop('Currently not implemented')

check_stop <- function(error){
  return(attr(error, 'condition')$message == "Operation was aborted by an application callback")
}

check_file <- function(path, required = FALSE){
  if (file.exists(path))
    path
  else {
    if (required) stop(path, ' is not a valid path')
    else NULL
  }
}

method_summaries <- function(meth, indent = 0){
  wrap_at <- 72 - indent
  meth_string <- paste(meth, collapse = ", ")
  indent(strwrap(meth_string, width = wrap_at), indent)
}

indent <- function(str, indent = 0) {
  gsub("(^|\\n)(?!$)",
       paste0("\\1", paste(rep(" ", indent), collapse = "")),
       str,
       perl = TRUE
  )
}
"%||%" <- function(x, y) if (is.null(x)) y else x

is_windows <- function() {
  identical(.Platform$OS.type, "windows")
}

is_unix <- function() {
  identical(.Platform$OS.type, "unix")
}

is_osx <- function() {
  Sys.info()["sysname"] == "Darwin"
}

is_linux <- function() {
  identical(tolower(Sys.info()[["sysname"]]), "linux")
}

is_ubuntu <- function() {
  # check /etc/lsb-release
  if (is_unix() && file.exists("/etc/lsb-release")) {
    lsbRelease <- readLines("/etc/lsb-release")
    any(grepl("Ubuntu", lsbRelease))
  } else {
    FALSE
  }
}

ensure_loaded <- function() {
  invisible(tf$`__version__`)
}

aliased <- function(path) {
  sub(Sys.getenv("HOME"), "~", path)
}


call_hook <- function(name, ...) {
  hooks <- getHook(name)
  if (!is.list(hooks))
    hooks <- list(hooks)
  response <- FALSE
  lapply(hooks, function(hook) {
    if (isTRUE(hook(...)))
      response <<- TRUE
  })
  response
}
# find an available dir
available_dir = function(dirs) {
  for (i in dirs) {
    if (utils::file_test('-d', i)) return(i)
  }
  stop('none of the directories exists:\n', paste(utils::formatUL(dirs), collapse = '\n'))
}

# tailored for assert(): extract the expression that is likely to be useful for
# diagnostics if possible
deparse_key = function(expr) {
  x = deparse(expr, width.cutoff = 100L)
  if ((n <- length(x)) <= 1) return(x)
  # if expression is in {}, fetch the line n-1, otherwise use the first line
  paste(x[1], '....', if (x[n] == '}') sub('^\\s*', '', x[n - 1L]))
}

# whether every element of x is strictly TRUE
all_true = function(x) {
  is.logical(x) && length(x) && !any(is.na(x)) && all(x)
}

insert_identical = function() {
  if (!has_error(rstudioapi::verifyAvailable()))
    rstudioapi::insertText(text = ' %==% ')
}

# This function is a modification of base::sys.source.  It allows to specify
# the top-level environment, which is by default "envir" (the same as in
# base::sys.source), but for package testing it is desirable to use the
# package namespace to mimick the environment structure used when packages
# are running. This function assumes that chdir = FALSE and keep.source = TRUE.
sys.source2 = function(file, envir, top.env = as.environment(envir)) {
  oop = options(keep.source = TRUE, topLevelEnvironment = top.env)
  on.exit(options(oop))

  lines = readLines(file, warn = FALSE, encoding = 'UTF-8')
  srcfile = srcfilecopy(file, lines, file.mtime(file), isFile = TRUE)
  exprs = parse(text = lines, srcfile = srcfile, encoding = 'UTF-8')

  if (length(exprs) == 0L) return()
  owd = setwd(dirname(file)); on.exit(setwd(owd), add = TRUE)
  for (i in seq_along(exprs)) eval(exprs[i], envir)
}
readLines <- function(...) stop("Use read_lines!")
writeLines <- function(...) stop("Use write_lines!")

read_lines <- function(path, n = -1L, encoding = "UTF-8") {
  base::readLines(path, n = n, encoding = encoding, warn = FALSE)
}

write_lines <- function(text, path) {
  base::writeLines(enc2utf8(text), path, useBytes = TRUE)
}

all_utf8 <- function(x) {
  ! any(is.na(iconv(x, "UTF-8", "UTF-8")))
}
#' @importFrom magrittr %>%
#' @export
magrittr::`%>%`

`%||%` <- function(a, b) if (is.null(a)) b else a

starts_with <- function(string, prefix) {
  substr(string, 1, nchar(prefix)) == prefix
}

is_directory <- function(x) file.info(x)$isdir
is_readable <- function(x) file.access(x, 4) == 0

null <- function(...) invisible()

klass <- function(x) paste(class(x), collapse = "/")

first_last <- function(x, max = 10, filler = "...") {
  if (length(x) <= 2 * max + 1) {
    x
  } else {
    c(
      x[seq_len(max)],
      filler,
      x[seq.int(to = length(x), length.out = max)]
    )
  }
}

# Tools for finding srcrefs -----------------------------------------------

show_stack <- function(star = integer(), n = sys.nframe() - 1L) {
  pos <- seq_len(n)
  fun <- vapply(sys.calls()[pos], f_name, character(1))
  has_src <- vapply(sys.calls()[pos], function(x) !is.null(attr(x, "srcref")), logical(1))
  env <- vapply(lapply(sys.frames()[pos], parent.env), env_name, character(1))
  parent <- sys.parents()[pos]

  data.frame(
    `*` = ifelse(pos %in% star, "*", ""),
    fun = fun,
    src = ifelse(has_src, "x", ""),
    env = env,
    par = parent,
    stringsAsFactors = FALSE,
    check.names = FALSE
  )
}

env_name <- function(x) {
  str <- capture_output(x, print = TRUE)
  gsub("<environment: |>", "", str)
}

find_first_srcref <- function(calls) {
  for (call in calls) {
    srcref <- attr(call, "srcref")
    if (!is.null(srcref)) {
      return(srcref)
    }
  }
  NULL
}

f_name <- function(x) {
  if (is.call(x)) {
    f_name(x[[1]])
  } else if (is.name(x)) {
    as.character(x)
  } else {
    ""
  }
}

escape_regex <- function(x) {
  chars <- c("*", ".", "?", "^", "+", "$", "|", "(", ")", "[", "]", "{", "}", "\\")
  gsub(paste0("([\\", paste0(collapse = "\\", chars), "])"), "\\\\\\1", x, perl = TRUE)
}

# For R 3.1
dir.exists <- function(paths) {
  file.exists(paths) & file.info(paths)$isdir
}
is_testfile <- function(x){
  is.scalar(x) &&  is_testfiles(x)
}




is_testfiles <- function(x){
  grepl("^test[_\\-]", basename(x))
}




#' Check if a file is /R/
#'
#' @param x a file path
#'
#' @return logical
#' @noRd
#'
is_in_rdir <- function(x) {
  pat <- file.path('/R', basename(x))
  grepl(pat, x, fixed = TRUE)
}




get_current_file <- function(){
  require_rstudio()
  res <- rstudioapi::getActiveDocumentContext()$path

  if (identical(res, '')){
    res <-  rstudioapi::getSourceEditorContext()$path
  }

  res
}




get_pkg_testfile_names_from_tags <- function(){
  infiles <- list_rdir_files()

  res <- lapply(infiles, get_taglist) %>%
    lapply(get_tag, 'testfile') %>%
    stats::setNames(infiles) %>%
    unlist()

  data.frame(
    rfile = names(res),
    tfile = paste0(as.character(res), '.R'),
    stringsAsFactors = FALSE
  )
}




get_testfile_name_from_tag <- function(infile){
  assert_that(is.scalar(infile))

  res <- infile %>%
    get_taglist() %>%
    get_tag('testfile')

  if(is.null(res)) return(NULL)

  data.frame(
    rfile = infile,
    tfile = paste0(res, '.R'),
    stringsAsFactors = FALSE
  )
}
#' @importFrom magrittr %>%
#' @export
magrittr::`%>%`
vply_int <- function(.x, .f) {
  vapply(.x, rlang::as_closure(.f), FUN.VALUE = integer(1), USE.NAMES = FALSE)
}
vply_dbl <- function(.x, .f) {
  vapply(.x, rlang::as_closure(.f), FUN.VALUE = double(1), USE.NAMES = FALSE)
}
vply_lgl <- function(.x, .f) {
  vapply(.x, rlang::as_closure(.f), FUN.VALUE = logical(1), USE.NAMES = FALSE)
}
vply_chr <- function(.x, .f) {
  vapply(.x, rlang::as_closure(.f), FUN.VALUE = character(1), USE.NAMES = FALSE)
}
vply_fct <- function(.x, .f) {
  vapply(.x, rlang::as_closure(.f), FUN.VALUE = factor(1), USE.NAMES = FALSE)
}
vply_pos <- function(.x, .f) {
  x <- vapply(.x, rlang::as_closure(.f), FUN.VALUE = double(1), USE.NAMES = FALSE)
  as.POSIXct(x, origin = "1970-01-01")
}
na_omit <- function(x) x[!is.na(x)]

check_dictionary <- function(x){

    if(anyDuplicated(x[[1]]) > 0) stop("Duplicate tokens found in column one of the lemma dictionary.")

}


numreg <-  "(?<=^| )[-.]*\\d+(?:\\.\\d+)?(?= |\\.?$)|\\d+(?:,\\d{3})+(\\.\\d+)*"
as_integer_tensor <- function(x, dtype = tf$int64) {
  # recurse over lists
  if (is.list(x) || (is.numeric(x) && length(x) > 1))
    lapply(x, function(elem) as_integer_tensor(elem, dtype))
  else if (is.null(x))
    x
  else if (is_tensor(x))
    tf$cast(x, dtype = dtype)
  else
    tf$constant(as.integer(x), dtype = dtype)
}

as_tensor_shapes <- function(x) {
  if (is.list(x))
    tuple(lapply(x, as_tensor_shapes))
  else if (is_tensor(x))
    tf$cast(x, dtype = tf$int64)
  else if (inherits("x", "python.builtin.object"))
    x
  else if (is.null(x))
    tf$constant(-1L, dtype = tf$int64)
  else
    tf$constant(as.integer(x), dtype = tf$int64)
}


with_session <- function(f, session = NULL) {
  if (is.null(session))
    session <- tf$get_default_session()
  if (is.null(session)) {
    session <- tf$Session()
    on.exit(session$close(), add = TRUE)
  }
  f(session)
}


validate_tf_version <- function() {
  tf_ver <- tensorflow::tf_version()
  required_ver <- "1.4"
  if (tf_ver < required_ver) {
    stop(
      "tfdatasets requires version ", required_ver, " ",
      "of TensorFlow (you are currently running version ", tf_ver, ").",
      call. = FALSE
    )
  }
}

column_names <- function(dataset) {
  if (!is.list(dataset$output_shapes) || is.null(names(dataset$output_shapes)))
    stop("Unable to resolve features for dataset that does not have named outputs", call. = FALSE)
  names(dataset$output_shapes)
}

is_dataset <- function(x) {
  inherits(x, "tensorflow.python.data.ops.dataset_ops.Dataset")
}

is_tensor <- function(x) {
  inherits(x, "tensorflow.python.framework.ops.Tensor")
}
"%||%" <- function(x, y) if (is.null(x)) y else x

stopf <- function(fmt, ..., call. = TRUE, domain = NULL) {
  stop(simpleError(
    sprintf(fmt, ...),
    if (call.) sys.call(sys.parent())
  ))
}

warnf <- function(fmt, ..., call. = TRUE, immediate. = FALSE) {
  warning(sprintf(fmt, ...), call. = call., immediate. = immediate.)
}

enumerate <- function(object, f, ...) {
  nm <- names(object)
  result <- lapply(seq_along(object), function(i) {
    f(nm[[i]], object[[i]], ...)
  })
  names(result) <- names(object)
  result
}

# make sure an object is a function
resolve_fn <- function(object) {
  if (is.function(object))
    object()
  else
    object
}


# utility function for importing python modules defined in the
# inst/python directory of the package
import_package_module <- function(module, convert = TRUE) {
  python_path <- system.file("python", package = "tfestimators")
  import_from_path(module, python_path, convert = convert)
}

resolve_mode <- function() {
  calls <- sys.calls()
  
  mode <- list(
    infer = ~ identical(.x[[1]], quote(predict.tf_estimator)) ||
      identical(.x[[1]], quote(object$estimator$predict)),
    eval = ~ identical(.x[[1]], quote(evaluate.tf_estimator)) ||
      identical(.x[[1]], quote(object$estimator$evaluate))
  ) %>%
    purrr::map(~ purrr::detect(calls, .x)) %>%
    purrr::compact() %>%
    names()
  
  if (!length(mode))
    stop("no train() or evaluate() function detected in call stack")
  if (length(mode) > 1)
    stop("both train() and evaluate() detected in call stack")
  
  mode
}
is_windows <- function() {
  identical(.Platform$OS.type, "windows")
}
#' @importFrom magrittr %>%
#' @export
magrittr::`%>%`

#' @importFrom phyloseq tax_table<-
#' @export
phyloseq::`tax_table<-`

#' @importFrom phyloseq otu_table<-
#' @export
phyloseq::`otu_table<-`

#' @importFrom phyloseq sample_data<-
#' @export
phyloseq::`sample_data<-`

if(getRversion() >= "2.15.1")  utils::globalVariables(c("."))
#' Pipe operator
#'
#' See \code{magrittr::\link[magrittr]{\%>\%}} for details.
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @export
#' @importFrom magrittr %>%
#' @usage lhs \%>\% rhs
NULL
#'@importFrom httr GET stop_for_status content user_agent
threeword_query <- function(url, ...){
  result <- httr::GET(url, httr::user_agent("what3words R client - https://www.github.com/ironholds/threewords/"), ...)
  httr::stop_for_status(result)
  output <- httr::content(x = result, as = "parsed")
  if("error" %in% names(output)){
    stop(output$message)
  }
  return(output)
}

clean <- function(result){
  result$words <- unlist(result$words)
  result$position <- as.numeric(unlist(result$position))
  return(result)
}
has_dim <- function(x) {
  length(dim(x)) > 0L || has_nonnull_names(x)
}

needs_dim <- function(x) {
  length(dim(x)) > 1L
}

has_null_names <- function(x) {
  is.null(names(x))
}

has_nonnull_names <- function(x) {
  !has_null_names(x)
}

set_class <- `class<-`

is_1d <- function(x) {
  # dimension check is for matrices and data.frames
  is_vector(x) && !needs_dim(x)
}

strip_dim <- function(x) {
  # Careful update only if necessary, to avoid copying which is checked by
  # the "copying" test in dplyr
  if (is_atomic(x) && has_dim(x)) {
    dim(x) <- NULL
  }
  x
}

needs_list_col <- function(x) {
  is_list(x) || length(x) != 1L
}

# Work around bug in R 3.3.0
safe_match <- function(x, table) {
  # nocov start
  if (getRversion() == "3.3.0") {
    match(x, table, incomparables = character())
  } else {
    match(x, table)
  }
  # nocov end
}

stopc <- function(...) {
  abort(paste0(...))
}

warningc <- function(...) {
  warn(paste0(...))
}

nchar_width <- function(x) {
  nchar(x, type = "width")
}

cat_line <- function(...) {
  cat(paste0(..., "\n"), sep = "")
}

is_syntactic <- function(x) {
  ret <- make.names(x) == x
  ret[is.na(x)] <- FALSE
  ret
}

tick_non_syntactic <- function(x) {
  needs_ticks <- !is_syntactic(x)
  x[needs_ticks] <- tick(x[needs_ticks])
  x
}

tick <- function(x) {
  x[is.na(x)] <- "NA"
  encodeString(x, quote = "`")
}
# Reexports --------------------------------------------------------------------

#' @importFrom dplyr %>%
#' @export
#'
dplyr::`%>%`

#' @importFrom rlang :=
#'
NULL

#' @importFrom rlang .data
#'
NULL

#' @importFrom rlang %||%
#'
NULL

#' @useDynLib tibbletime, .registration = TRUE
#' @importFrom Rcpp sourceCpp
NULL

# Global util ------------------------------------------------------------------

# A glue version of stop()
glue_stop <- function(..., .sep = "") {
  stop(glue::glue(..., .sep, .envir = parent.frame()), call. = FALSE)
}

# Cheaply get the length of a string
string_length <- function(x) {
  split <- unlist(strsplit(x, ""))
  length(split)
}

index_attributes <- function() {
  c("index_quo", "index_time_zone")
}

make_dummy_dispatch_obj <- function(x) {
  structure(list(), class = x)
}

remove_time_group <- function(x) {
  if(".time_group" %in% colnames(x)) {
    x[[".time_group"]] <- NULL
  }
  x
}
#' @importFrom stats setNames runif
NULL
#' Confidence interval (lower 2.5\%)
#'
#' @param x A numeric vector
#' @param na.rm A logical value indicating whether NA values should be stripped
#'   before the computation proceeds.
#'
#' @return 2.5% quantile of x
#'
#' @examples
#' x <- rnorm(1000, mean = 0, sd = 1)
#' ci_lower(x)
#' @export
ci_lower <- function(x, na.rm = FALSE) {
  stats::quantile(x, 0.025, na.rm = na.rm)
}

#' Confidence interval (upper 97.5\%)
#'
#' @param x A numeric vector
#' @param na.rm A logical value indicating whether NA values should be stripped
#'   before the computation proceeds.
#'
#' @return 97.5% quantile of x
#'
#' @examples
#' x <- rnorm(1000, mean = 0, sd = 1)
#' ci_upper(x)
#' @export
ci_upper <- function(x, na.rm = FALSE) {
  stats::quantile(x, 0.975, na.rm = na.rm)
}
# GENERAL UTILITY FUNCTIONS FOR FORMATTING NUMBERS

convert_to_numeric <- function(x) {

    # Error handling
    if (is.na(x) || is.null(x)) {
        return(NA)
    }

    # x = character such as "23.4B"
    units <- stringr::str_sub(x, -1, -1)

    if (units %in% c("T", "B", "M")) {
        value <- stringr::str_sub(x, 1, -2) %>%
            as.numeric()

        if (units == "T") {
            value <- value * 1e12
        } else if (units == "B") {
            value <- value * 1e9
        } else if (units == "M") {
            value <- value * 1e6
        }
    } else (
        value <- as.numeric(value)
    )

    return(value)
}

convert_to_percent <- function(x) {

    # Error handling
    if (is.na(x) || is.null(x)) {
        return(NA)
    }

    # x = character such as "-0.6104%"
    units <- stringr::str_sub(x, -1, -1)

    if (units %in% c("%")) {
        value <- stringr::str_sub(x, 1, -2) %>%
            as.numeric()

        value <- value * 1 / 100
    }

    return(value)
}
# GENERAL UTILITY FUNCTIONS FOR DATES

# Checks a data frame and returns true / false if date or date-time column exists
check_date_or_date_time_exists <- function(data) {

    date_cols <- timetk::tk_get_timeseries_variables(data)
    return(length(date_cols) > 0)

}

# Takes a dateframe and returns name of date / date-time column
get_col_name_date_or_date_time <- function(data) {

    date_cols <- timetk::tk_get_timeseries_variables(data)
    if (length(date_cols) == 0) {
        stop("No date or POSIXct column found in `data`.")
    }
    return(date_cols[[1]])

}

get_time_zone <- function(data, date_col_name) {

    date_col_string <- paste0(deparse(substitute(data)), "$", date_col_name)
    eval(parse(text = date_col_string)) %>%
        lubridate::tz()
}
#' Pipe operator
#'
#' See \code{\link[magrittr]{\%>\%}} for more details.
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @export
#' @importFrom magrittr %>%
#' @usage lhs \%>\% rhs
NULL

regroup <- function(output, input, except = NULL) {
  groups <- dplyr::group_vars(input)
  if (!is.null(except)) {
    groups <- setdiff(groups, except)
  }

  dplyr::grouped_df(output, groups)
}
reconstruct_tibble <- function(input, output, ungrouped_vars = chr()) {
  if (inherits(input, "grouped_df")) {
    regroup(output, input, ungrouped_vars)
  } else if (inherits(input, "tbl_df")) {
    as_tibble(output)
  } else {
    output
  }
}


imap <- function(.x, .f, ...) {
  map2(.x, names(.x) %||% character(0), .f, ...)
}

seq_nrow <- function(x) seq_len(nrow(x))
seq_ncol <- function(x) seq_len(ncol(x))
is_negated <- function(x) {
  is_call(x, "-", n = 1)
}

sym_dollar <- quote(`$`)
sym_brackets2 <- quote(`[[`)
is_data_pronoun <- function(expr) {
  is_call(expr, list(sym_dollar, sym_brackets2)) &&
    identical(node_cadr(expr), quote(.data))
}

singular <- function(vars) {
  nm <- attr(vars, "type") %||% c("column", "columns")
  if (!is_character(nm, 2)) {
    abort("The `type` attribute must be a character vector of length 2")
  }
  nm[[1]]
}
plural <- function(vars) {
  nm <- attr(vars, "type") %||% c("column", "columns")
  if (!is_character(nm, 2)) {
    abort("The `type` attribute must be a character vector of length 2")
  }
  nm[[2]]
}
Singular <- function(vars) {
  capitalise_first(singular(vars))
}
Plural <- function(vars) {
  capitalise_first(plural(vars))
}

vars_pluralise <- function(vars) {
  pluralise(vars, singular(vars), plural(vars))
}
vars_pluralise_len <- function(vars, x) {
  pluralise_len(x, singular(vars), plural(vars))
}

capitalise_first <- function(chr) {
  gsub("(^[[:alpha:]])", "\\U\\1", chr, perl = TRUE)
}

paren_sym <- quote(`(`)
minus_sym <- quote(`-`)
colon_sym <- quote(`:`)
c_sym <- quote(`c`)

quo_is_character <- function(quo, n = NULL) {
  is_character(quo_get_expr(quo), n = n)
}
quo_as_list <- function(quo) {
  as.list(quo_get_expr(quo))
}

is_character <- function(x, n = NULL) {
  if (typeof(x) != "character") return(FALSE)

  if (!is_null(n)) {
    if (is_scalar_integerish(n) && length(x) != n) return(FALSE)
    else if (is_function(n) && !n(length(x))) return(FALSE)
  }

  TRUE
}

are_name <- function(nms) {
  if (!is_character(nms)) {
    abort("Expected a character vector")
  }

  nms == "" | is.na(nms)
}

# Compatibility with R < 3.2
isNamespaceLoaded <- function(name) {
  name %in% loadedNamespaces()
}
#' @importFrom stringdist stringdist
#' @importFrom rlang quo_name enquo
#' @importFrom dplyr tibble
#'
tibble_dist <- function(df, v1 = V1, v2 = V2, method){
  col_name <- enquo(method)
  str_dist <- stringdist(df[[quo_name(enquo(v1))]],
                         df[[quo_name(enquo(v2))]],
                         method)
  tibble(!! method := str_dist)
}
msg <- function(..., startup = FALSE) {
  if (startup) {
    if (!isTRUE(getOption("tidyverse.quiet"))) {
      packageStartupMessage(text_col(...))
    }
  } else {
    message(text_col(...))
  }
}

text_col <- function(x) {
  # If RStudio not available, messages already printed in black
  if (!rstudioapi::isAvailable()) {
    return(x)
  }

  if (!rstudioapi::hasFun("getThemeInfo")) {
    return(x)
  }

  theme <- rstudioapi::getThemeInfo()

  if (isTRUE(theme$dark)) crayon::white(x) else crayon::black(x)

}

#' List all packages in the tidyverse
#'
#' @param include_self Include tidyverse in the list?
#' @export
#' @examples
#' tidyverse_packages()
tidyverse_packages <- function(include_self = TRUE) {
  raw <- utils::packageDescription("tidyverse")$Imports
  imports <- strsplit(raw, ",")[[1]]
  parsed <- gsub("^\\s+|\\s+$", "", imports)
  names <- vapply(strsplit(parsed, " +"), "[[", 1, FUN.VALUE = character(1))

  if (include_self) {
    names <- c(names, "tidyverse")
  }

  names
}

invert <- function(x) {
  if (length(x) == 0) return()
  stacked <- utils::stack(x)
  tapply(as.character(stacked$ind), stacked$values, list)
}


style_grey <- function(level, ...) {
  crayon::style(
    paste0(...),
    crayon::make_style(grDevices::grey(level), grey = TRUE)
  )
}
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU Library General Public License for more details.
#
# You should have received A copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA  02111-1307  USA


################################################################################
# FUNCTION:                 DESCRIPTION:
#  description               Creates default description string
################################################################################


description <- 
function()
{   
    # A function implemented by Diethelm Wuertz

    # Description:
    #   Sets default description string:

    # FUNCTION:

    # Get Description String:
    ans <- paste(as.character(date()), "by user:", Sys.getenv("USERNAME"))

    # Return Value:
    ans
}


################################################################################
# recursive function to check depth of list. hat tip flodel 
# at stackoverflow: http://stackoverflow.com/questions/13432863/determine-level-of-nesting-in-r
#' Determine depth of a list
#' 
#' This function recursively checks the depth of a list and returns an integer value of depth
#' 
#' @param this an object of class list 
#' @details Hat tip to flodel at stackoverflow for suggesting this light weight way analyze depth of a nested list. Further complexity needs to be added to cover the fact that data.frame are lists, too. A more sophisticated recursive function can be found in the gatveys2 package.
#' @references http://stackoverflow.com/questions/13432863/determine-level-of-nesting-in-r
#' @export
getListDepth <- function(this) ifelse(is.list(this), 1L + max(sapply(this, getListDepth)), 0L)

#' Check Validity of a PostgreSQL connection
#' 
#' Is the PostgreSQL connection expired?
#' 
#' @param dbObj PostgreSQL connection object.
#' @importFrom DBI dbIsValid
#' @importFrom DBI dbGetInfo
#' @import RPostgreSQL
#' @import methods
#' @docType methods
#' @aliases dbIsValid
#' @rdname dbIsValid-methods
#' @export
setMethod("dbIsValid", "PostgreSQLConnection", function(dbObj) {
  isValid <- tryCatch({DBI::dbGetInfo(dbObj)},
                      error = function(e) NULL)
  !is.null(isValid)  
})
.onLoad <- function(libname, pkgname) {
  # register a handler to decode the timeline data passed from JS to R
  # because the default way of decoding it in shiny flattens a data.frame
  # to a vector
  shiny::registerInputHandler("timevisDF", function(data, ...) {
    jsonlite::fromJSON(jsonlite::toJSON(data, auto_unbox = TRUE))
  }, force = TRUE)
}

# Check if an argument is a single boolean value
is.bool <- function(x) {
  is.logical(x) && length(x) == 1
}

# Convert a data.frame to a list of lists (the data format that D3 uses)
dataframeToD3 <- function(df) {
  if (missing(df) || is.null(df)) {
    return(list())
  }
  if (!is.data.frame(df)) {
    stop("timevis: the input must be a dataframe", call. = FALSE)
  }
  row.names(df) <- NULL
  apply(df, 1, function(row) as.list(row[!is.na(row)]))
}

#' @importFrom magrittr %>%
#' @export
magrittr::`%>%`
char_at <- function(.string, i) {
  if (abs(i) > nchar(.string) || i == 0) stop('index out of bounds', call. = FALSE)
  j <- (i %% nchar(.string)) + (i < 0)
  substr(.string, j, j)
}

first_of <- function(.string, c) {
  if (!grepl(c, .string, fixed = TRUE)) return(-1)
  i <- 1
  while (i < nchar(.string) && char_at(.string, i) != c) i <- i + 1
  i
}

re_search <- function(.string, pattern) {
  bounds <- regexpr(pattern, .string)
  if (bounds[[1]] != -1) {
    substr(.string, bounds[[1]], bounds[[1]] + attr(bounds, 'match.length') - 1)
  } else {
    NULL
  }
}

set_names <- function(obj, nm) {
  names(obj) <- nm
  obj
}

cat0 <- function(...) cat(..., sep = '')

is.try_error <- function(x) inherits(x, 'try-error')
# excludes can be a vector of 'markdown', 'epub', etc
is_html_output <- function(fmt = pandoc_to(), excludes = NULL) {
    if (length(fmt) == 0) return(FALSE)
    if (grepl('^markdown', fmt)) fmt = 'markdown'
    if (fmt == 'epub3') fmt = 'epub'
    fmts = c('markdown', 'epub', 'html', 'html5', 'revealjs', 's5', 'slideous', 'slidy')
    fmt %in% setdiff(fmts, excludes)
}

is_latex_output <- function() {
    out_format('latex') || pandoc_to(c('latex', 'beamer'))
}

out_format <- function (x) {
    fmt <- knitr::opts_knit$get("out.format")
    if (missing(x))
        fmt
    else !is.null(fmt) && (fmt %in% x)
}

# rmarkdown sets an option for the Pandoc output format from markdown
pandoc_to <- function(x) {
    fmt <- knitr::opts_knit$get('rmarkdown.pandoc.to')
    if (missing(x)) fmt else !is.null(fmt) && (fmt %in% x)
}
spf <- function(...) stop(sprintf(...), call. = FALSE)
#' Pipe operator
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @export
#' @importFrom purrr %>%
#' @usage lhs \%>\% rhs
NULL
## Helper functions

.print_via_format <-
function(x, ...)
{
    writeLines(format(x, ...))
    invisible(x)
}

## Efficient alternative to table() proposed by Kurt Hornik
.table <- function(x) {
    u <- sort(unique(x))
    if(!length(u)) return(integer())
    v <- tabulate(match(x, u))
    names(v) <- u
    v
}

.xml_content <- function(doc, spec) {
    switch(spec[[1]],
           node = xml_text(xml_find_all(doc, spec[[2]])),
           "function" = spec[[2]](doc),
           unevaluated = spec[[2]])
}

IETF_Snowball_map <-
list("danish" = c("da", "dan"),
     "dutch" = c("nl", "nld", "dut"),
     "english" = c("en", "eng"),
     "finnish" = c("fi", "fin"),
     "french" = c("fr", "fra", "fre"),
     "german" = c("de", "deu", "ger"),
     "hungarian" = c("hu", "hun"),
     "italian" = c("it", "ita"),
     "norwegian" = c("no", "nor"),
     "portuguese" = c("pt", "por"),
     "romanian" = c("ro", "ron", "rum"),
     "russian" = c("ru", "rus"),
     "spanish" = c("es", "esl", "spa"),
     "swedish" = c("sv", "swe"),
     ## Have stopwords but no SnowballC stemmer ...
     "catalan" = c("ca", "cat"),
     ## Have SnowballC stemmer but no stopwords ...
     "turkish" = c("tr", "tur")
     )

# Map IETF language tags to languages used by the Snowball stemmer project
# http://en.wikipedia.org/wiki/IETF_language_tag
map_IETF_Snowball <-
local({
    codes <- unlist(IETF_Snowball_map, use.names = FALSE)
    names <- rep.int(names(IETF_Snowball_map), lengths(IETF_Snowball_map))

    function(code) {
        code <- as.character(code)

        if (identical(code, "") || identical(code, character(0)) || is.na(code))
            return("porter")

        names[charmatch(gsub("-.*", "", code), codes)]
    }
})
.verifyChar <- function(vec) {
	if (!is.atomic(vec)) stop("Must be an atomic vector!", call. = FALSE)
	OUT <- as.character(vec)
	return(OUT)
}

.verifyNum <- function(vec) {
	if (!is.atomic(vec)) stop("Must be an atomic vector!")
	OUT <- suppressWarnings(as.numeric(vec))
	if (length(OUT[!is.na(OUT)]) == 0) stop("Does not contain any numeric elements!", call. = FALSE)
	return(OUT)
}

.verifyEnv <- function() {
	if (!exists(".tmcnEnv", envir = .GlobalEnv)) {
		envir0 = as.environment(1)
		assign(".tmcnEnv", new.env(), envir = envir0)
	} 
	OUT <- get(".tmcnEnv", envir = .GlobalEnv)
	return(OUT)
}

.getStopWords <- function() {
	.tmcnEnv <- .verifyEnv()
	utils::data(STOPWORDS, envir = .tmcnEnv)
	STOPWORDS <- get("STOPWORDS", envir = .tmcnEnv)
	return(STOPWORDS)
}

.strsplit_space_tokenizer <- function(x) {
	unlist(strsplit(as.character(x), "[[:space:]]+"))
}

.createHashmapEnv <- function(key, value)
{
	key <- .verifyChar(key)
	value <- .verifyChar(value)
	if (length(key) != length(value)) stop("Length of 'key' and 'value' are not same!")
	e <- new.env(hash = TRUE, size = length(key))
	for (ikey in 1:length(key)) {
		assign(x = key[ikey], value = value[ikey], envir = e)
	}
	return(e)
}
simplify_list <- function(x, simplify) {
  stopifnot(is.logical(simplify))
  if (simplify && length(x) == 1) x[[1]] else x
}

check_input <- function(x) {
  check_character <- is.character(x) |
  if (is.list(x)) {
       check_list <- all(vapply(x, is.character, logical(1))) &
         all(vapply(x, length, integer(1)) == 1L)
  } else {
    check_list <- FALSE
  }
  if (!(check_character | check_list))
    stop("Input must be a character vector of any length or a list of character\n",
         "  vectors, each of which has a length of 1.")
}

remove_stopwords <- function(x, stopwords) {
  out <- x[!x %in% stopwords]
  if(!length(out)){
    return(NA_character_)
  }
  return(out)
}
#' Replace NULL values with NA.
#'
#' \code{nullToNA} is used to convert any NULL values to NA in a list.
#'
#' This function is used when reading vectors from mongoDB. If the original
#' vector had a value of NA, rmongodb converts to NULL before writing to the
#' database. When rmongodb performs a find, these NULL values are left as NULL,
#' and when unlisted will shorten the vector. Before unlisting the vector, this
#' function is run to convert the NULL values to NA so that the vector remains
#' the correct length and that NAs are in the correct positions.
#'
#' @param x A list.
#' @return x with all NULL at the top level of the list replaced by NA.
#' @examples
#' \dontrun{nullToNA(list(1,5,'a', NULL, NA, 4))}
nullToNA <- function(x){
  x[sapply(x, is.null)] <- NA
  return(x)
}

#' Convert x to numeric if x is a list.
#'
#' \code{listTonumeric} is used to convert x to a numeric type if x is a list.
#'
#' This function is used as part of reading data from mongoDB using rmongodb.
#' Typically values will be stored as numeric vectors. However, if an NA is in
#' the original vector, rmongodb will convert to NULL prior to writing to the
#' database. This gets read from the database as a list of length Y rather than
#' a numeric of length Y with positions that were NA now with value NULL. The
#' function \code{nullToNA} converts the NULL values to NA, and this function
#' converts the list back to a numeric type.
#'
#' @param x A list of length Y without NULL values.
#' @return x a numeric vector of length Y.
#' @examples
#' \dontrun{class(listTonumeric(list(1,2,3,4,NA,6,7)))}
listTonumeric <- function(x){
  if(is.list(x)){
    x <- as.numeric(x)
  }
  return(x)
}

anynulls <- function(x){
  numnull <- sum(sapply(x, is.null))
  return(numnull)
}
tpr.control <- function(conlist) {
  control <- list(maxit = 25, tol = 0.0001, smooth = 0, intsmooth = 0)
  control[names(conlist)] <- conlist
  control <- list(maxit=as.integer(control$maxit),
                  tol=as.double(control$tol),
                  smooth=as.integer(control$smooth),
                  intsmooth=as.integer(control$smooth))
}

kern.str <- function(kernlist) {
  kernstr <- list(kern = 1, poly = 1, band = 1)
  kernstr[names(kernlist)] <- kernlist
  kernstr <- list(kern=as.integer(kernstr$kern),
                  poly=as.integer(kernstr$poly),
                  band=as.double(kernstr$band))
}
trim_ws <- function(x) {
  sub("\\s+$", "", sub("^\\s+", "", x))
}

## We need this, because head(x, -n) behaves badly if n = 0

#' @importFrom utils head

drop_last <- function(x, n) {
  head(x, n = length(x) - n)
}

make_spaces <- function(n) {
  paste(rep(" ", n), collapse = "")
}

nullna <- function(x, unlist = TRUE) {
  x <- lapply(x, function(xx) if (is.null(xx) || ! length(xx)) NA else xx)
  if (unlist) unlist(x) else x
}

## The special case is to avoid converting to logical():
## ifelse(numeric(), 0, 1) is logical()
## Also, we want to avoid ifelse() simplifying to integer,
## so if the input is not integer we put in a real 0 (instead of 0L).

na0 <- function(x) {
  if (!length(x)) {
    x

  } else if (is.integer(x)) {
    ifelse(is.na(x), 0L, x)

  } else {
    ifelse(is.na(x), 0, x)
  }
}

is_count <- function(x) {
  is.numeric(x) && length(x) == 1 && !is.na(x) && as.integer(x) == x &&
    x >= 0L
}

is_string <- function(x) {
  is.character(x) && length(x) == 1 && !is.na(x)
}

## a file we can read from

is_readable_file <- function(x) {
  is_string(x) && file.exists(x) &&
    tryCatch(
      length(readLines(x, n = 1)) == 1,
      error = function(e) FALSE
    )
}
## from lme4
namedList <- function(...) {
  result <- list(...)
  substituteNames <- sapply(substitute(list(...)), deparse)[-1]
  if (is.null(resultNames <- names(result))) resultNames <- substituteNames
  if (any(noNames <- resultNames == "")) resultNames[noNames] <- substituteNames[noNames]
  setNames(result, resultNames)
}

## use this to produce calls of the form
##  treatSens:::functionName
## so that we can evaluate non-exported functions in
## the user's environment
quoteInNamespace <- function(name, character.only = FALSE) {
  result <- quote(a + b)
  result[[1]] <- as.symbol(":::")
  result[[2]] <- as.symbol("treatSens")
  
  result[[3]] <- if (character.only) name else match.call()[[2]]
  result
}

"%not_in%" <- function(x, table) match(x, table, nomatch = 0) == 0
"%w/o%" <- function(x, y) x[!x %in% y]

## changes a named value in a list and returns that list
setInList <- function(x, ...) {
  mc <- match.call()
  if (length(mc) == 2L) return(x)
  for (i in seq.int(2L, length(mc))) {
    if (names(mc)[i] == "x") next
    mc.i <- mc[[i]]
    if (is.null(mc.i)) {
      x[[names(mc)[i]]] <- NULL
    } else if (is.language(mc.i) && mc.i[[1L]] == "<-" || mc.i[[1L]] == "=") {
      temp <- quote(x$a)
      temp[[3L]] <- mc.i[[2L]]
      mc.i[[2L]] <- temp
    } else {
      temp <- quote(x$a <- b)
      temp[[2L]][[3L]] <- names(mc)[i]
      temp[[3L]] <- mc.i
      mc.i <- temp
    }
    eval(mc.i)
  }
  x
}
.onAttach <- function(libname, pkgname) {
    packageStartupMessage(
        "R API for Trello\n",
        "Disclaimer: trelloR is not affiliated, associated, authorized, endorsed by or in any way officially connected to Trello, Inc. (www.trello.com).\n")
}

as_POSIXct_hex = function(x) {

    # Check input
    if (!is.character(x)) stop("Input must be of class 'character'")
    if (!all(nchar(x) == 8)) stop("Input must be a string of 8 characters")

    # Convert into POSIXct
    timestamp = strtoi(x, 16L)
    posix_ct  = as.POSIXct(timestamp, origin = "1970-01-01")
    return(posix_ct)
}
#############################################################################
#   Copyright (c) 2015 Christophe Dutang
#
#   This program is free software; you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation; either version 2 of the License, or
#   (at your option) any later version.
#
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with this program; if not, write to the
#   Free Software Foundation, Inc.,
#   59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
#
#############################################################################



plus <- function(x)
    pmax(x, 0)
## helpers
# ref: tibble:::big_mark
big_mark <- function(x, ...) {
  mark <- if (identical(getOption("OutDec"), ",")) "." else ","
  formatC(x, big.mark = mark, ...)
}

# ref: tibble:::cat_line
cat_line <- function(...) {
  cat(paste0(..., "\n"), sep = "")
}

dim_tbl_ts <- function(x) {
  dim_x <- dim(x)
  format_dim <- purrr::map_chr(dim_x, big_mark)
  paste(format_dim, collapse = " x ")
}

split_period <- function(x) {
  output <- lubridate::seconds_to_period(x)
  list(
    year = output$year, month = output$month, day = output$day,
    hour = output$hour, minute = output$minute, second = output$second
  )
}

paste_comma <- function(...) {
  paste(..., collapse = ", ")
}

first_arg <- function(x) {
  purrr::compact(purrr::map(x, ~ dplyr::first(call_args(.))))
}

# regular time interval is obtained from the minimal time distance.
# duplicated time entries result in 0L.
# if validate = FALSE in as_tsibble, skip to check duplicated entries
min_interval <- function(x, duplicated = TRUE) {
  if (has_length(x, 1)) { # only one time index
    return(NA_integer_)
  }
  abs_diff <- abs(diff(as.numeric(x), na.rm = TRUE))
  if (duplicated) {
    return(minp(abs_diff)) # faster than min(abs_diff[abs_diff > 0])
  } else {
    min(abs_diff)
  }
}

validate_vars <- function(j, x) { # j = quos/chr/dbl
  tidyselect::vars_select(.vars = x, !!! j)
}

surround <- function(x, bracket = "(") {
  if (bracket == "(") {
    return(paste0("(", x, ")"))
  } else if (bracket == "[") {
    return(paste0("[", x, "]"))
  } else if (bracket == "<") {
    return(paste0("<", x, ">"))
  } else {
    paste0("`", x, "`")
  }
}

quo_text2 <- function(x) {
  quo_text(x, width = 500L)
}

min0 <- function(x) {
  min(x, na.rm = TRUE)
}

max0 <- function(x) {
  max(x, na.rm = TRUE)
}

is_named <- function(quos) {
  named_quos <- names(quos)
  is_false(all(named_quos == ""))
}
isInteger <- function(n, tol=.Machine$double.eps) {
  isI <- function(n, tol) {
    isNumber <- is.numeric(n)
    if (isNumber) {
      return(abs(n - round(n)) < tol)
    } else {
      return(FALSE)
    }
  }
  sapply(n, isI, tol=tol)
}

merge.list <- function(x, y=NULL, mergeUnnamed=TRUE, ...) {
  if (is.null(y)) {
    return(as.list(x))
  } else {
    y <- as.list(y)
    
    # replace NA in names with ""
    if (!is.null(names(x))) {
      names(x)[is.na(names(x))] <- ""
    }
    if (!is.null(names(y))) {
      names(y)[is.na(names(y))] <- ""
    }
    
    names1 <- names(x)
    names2 <- names(y)
  
    # select an element if it has:
    # a.) an empty name in y _and_
    #     mergeUnnamed is true _or_
    # b.) a name _not_ contained in x
    isUnique <- if (mergeUnnamed) {
      if (is.null(names2) | is.null(names1)) {
        rep(TRUE, length(y))
      } else {
        (nchar(names2) == 0) | !(names2 %in% names1)
      }
    } else {
      !(names2 %in% names1) & (nchar(names2) != 0)
    }
    mergedList <- c(x, y[isUnique])
    return(mergedList)
  }
}
allowed_elements <- c("language", "pre-exercise-code", "sample-code", "solution", "sct", "hint")
required_elements <- c("sample-code")
project_alias <- "DataCamp Light"
cdn_path <- "datacamp-light-latest.min.js"

cpaste <- function(x) {
  paste(x, collapse = "\n")
}

spaste <- function(...) {
  paste(..., sep = "\n")
}

collapse <- function(x, conn = " and ") {
  if (length(x) > 1) {
    n <- length(x)
    last <- c(n - 1, n)
    collapsed <- paste(x[last], collapse = conn)
    collapsed <- paste(c(x[-last], collapsed), collapse = ", ")
  } else collapsed <- x
  collapsed
}

#' @importFrom markdown markdownToHTML
to_html <- function(x) {
  html <- markdownToHTML(text = x, fragment.only = TRUE)
  #remove surrounding <p> tags
  html <- gsub("^\\s*<p>(.*?)</p>\\s*$", "\\1", html)
  # remove trailing newlines
  html <- gsub("^(.*?)\\s*$", "\\1", html)
  html
}
#' Create List of Control Parameters for tvSURE
#'
#' Create a list of control pararameters for function \code{\link{tvSURE}}.
#' All control parameters that are not passed to this function are set to
#' default values.
#'
#' If the estimation is iterative FGLS with \code{maxiter}>1, the convergence criterion is
#' \deqn{\sqrt{ \frac{ \sum_{i, j}
#' (B_{i,j,g} - B{i, j, g-1})^2 }{ \sum_{i, j} B_{i, j, g-1}^2 }} < \code{tol}}
#' (\eqn{B_{i, j,g}} is the ith, jth coefficient of the gth iteration step).
#' @rdname tvReg-internals
#' @param maxiter maximum number of iterations for the iterative FGLS
#' estimations.
#' @param tol tolerance level indicating when to stop the iteration for the iterative FGLS estimations
#' @return A list of the above components.
#'
#' @export
tvsure.control <- function(maxiter = 1, tol = 1e-05)
{
  result <- list()
  if (maxiter <= 0 || round(maxiter) != maxiter) {
    stop("control parameter 'maxiter' must be a positive integer\n")
  }
  result$maxiter <- maxiter
  if (tol <= 0 || !is.numeric(tol) || length(tol) != 1) {
    stop("control parameter 'tol' must be a positive scalar\n")
  }
  result$tol <- tol
  return(result)
}
check.latitude <- function(latitude) {
  if (is.null(latitude) || is.na(latitude)) return(latitude)
  latitude = as.numeric(latitude)
  if ((latitude > 90 || latitude < -90)) {
    stop('Latitude must be in range [90.0,-90.0].')
  } else return(latitude)
}

check.longitude <- function(longitude) {
  if (is.null(longitude) || is.na(longitude)) return(longitude)
  longitude = as.numeric(longitude)
  if (!is.na(longitude) && (longitude > 180 || longitude < -180)) {
    stop('Longitude must be in range [180,-180].')
  } else return(longitude)
}

getEndpoint <- function(cmd, version = 1) {
  # paste("https://api.uber.com/v", version, '/', cmd, sep='')
  #
  # Use the API sandbox (https://developer.uber.com/docs/rides/sandbox)
  #
  paste("https://sandbox-api.uber.com/v", version, '/', cmd, sep='')
}

#' @import ggmap
#' @importFrom stats na.omit
geocode <- function(location) {
  position <- na.omit(suppressWarnings(suppressMessages(ggmap::geocode(location))))
  if (nrow(position) == 0) {
    stop(sprintf("Unable to find location '%s'.", location), call. = FALSE)
  }
  position
}

nullToNA <- function(x) {
  x[sapply(x, is.null)] <- NA
  return(x)
}
#'@importFrom httr user_agent stop_for_status GET content
ud_query <- function(params, term = TRUE, ...){
  url <- paste0("http://api.urbandictionary.com/v0/", params)

  result <- httr::GET(url, httr::user_agent("udapi - https://github.com/Ironholds/udapi"))
  httr::stop_for_status(result)
  output <- httr::content(result)
  if("result_type" %in% names(output) && output$result_type == "no_results"){
    stop("No results found")
  }
  if(term){
    return(output$list)
  }
  return(output)
}

clean_results <- function(results){
  output_names <- names(results[[1]])
  output <-  data.frame(matrix(unlist(results), nrow = length(results), byrow = TRUE),
                        stringsAsFactors = FALSE)
  names(output) <- output_names
  output$thumbs_up <- as.numeric(output$thumbs_up)
  output$defid <- as.numeric(output$defid)
  output$thumbs_down <- as.numeric(output$thumbs_down)
  return(output)
}
# Borrowed from rticles to avoid having to deal w/ name space issues
# Not exported

find_file <- function(template, file) {
  template <- system.file("rmarkdown", "templates", template, file,
                          package = "uiucthemes")
  if (template == "") {
    stop("Couldn't find template file ", template, "/", file, call. = FALSE)
  }

  template
}

find_resource <- function(template, file) {
  find_file(template, file.path("resources", file))
}

inherit_pdf_document <- function(...) {
  fmt <- rmarkdown::pdf_document(...)
  fmt$inherits <- "pdf_document"
  fmt
}

load_resources_if_missing <- function(template_name, resources) {
  for (template_file in resources)
    if (!file.exists(template_file))
      file.copy(system.file("rmarkdown", "templates", template_name, "skeleton",
                            template_file, package="uiucthemes"),
                ".")
}
#' @importFrom magrittr %>%
#' @export
magrittr::`%>%`

#' @import data.table
#' @import tidyr

#' @importFrom methods is

# Spurious imports to satisfy R CMD check
#' @importFrom dtplyr tbl_dt
#' @importFrom purrr map

NULL

globalVariables(c(".",
                  "inner_join",
                  "mutate",
                  "select",
                  "rename",
                  "quo",
                  "UQ",
                  "quo_name",
                  "from_row",
                  "from_col",
                  "to_row",
                  "to_col",
                  "type",
                  "value",
                  "everything",
                  ".boundary"))
#  Copyright 2017 Patrick O. Perry.
#
#  Licensed under the Apache License, Version 2.0 (the "License");
#  you may not use this file except in compliance with the License.
#  You may obtain a copy of the License at
#
#      http://www.apache.org/licenses/LICENSE-2.0
#
#  Unless required by applicable law or agreed to in writing, software
#  distributed under the License is distributed on an "AS IS" BASIS,
#  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
#  See the License for the specific language governing permissions and
#  limitations under the License.


with_rethrow <- function(expr)
{
    parentcall <- sys.call(-1)
    eval(envir = parent.frame(),
        withCallingHandlers(expr,
            error = function(e, call = parentcall) {
                e$call <- call
                stop(e)
            },
            warning = function(w, call = parentcall) {
                w$call <- call
                warning(w)
                invokeRestart("muffleWarning")
            },
            message = function(m, call = parentcall) {
                m$call <- call
            }
        )
    )
}
# Empty-default operator
`%||%` <- function(x, y) {
  if (is.null(x) || length(x) == 0L) y else x
}

# Pipe operator
`%>%` <- purrr::`%>%`

# Hush `R CMD check` note (confused by `.` in pipes)
. <- NULL

is_true <- isTRUE
is_false <- function(x) identical(FALSE, x)

stop_wo_call <- function(...) stop(..., call. = FALSE)
warning_wo_call <- function(...) warning(..., call. = FALSE)

# Deparse a language object as a single string
deparse_collapse <- function(x) {
  d <- deparse(x)
  if (length(d) > 1L) {
    paste(trimws(gsub("\\s+", " ", d), which = "left"), collapse = "")
  } else {
    d
  }
}

# Typically used to list symbols, such as function argument names
quote_collapse <- function(xs) {
  paste(encodeString(xs, quote = "`"), collapse = ", ")
}

# Collapse a character vector into an enumerated string
enumerate_many <- function(x, many = 2L) {
  if (length(x) >= many) {
    paste(
      vapply(seq_along(x), function(i) sprintf("%d) %s\n", i, x[[i]]),
             character(1)),
      collapse = ""
    )
  } else {
    paste0(x, "\n")
  }
}
setNames <- function(x,nm){
  names(x) <- nm
  x
}

# a reasonable warning
warnf <- function(fmt,...){
  warning(sprintf(fmt,...),call.=FALSE)
}
# makes a copy of the validation object
check_validator <- function(x, copy = TRUE, check_infeasible = TRUE){
  if (!inherits(x, "validator")){
    stop("This method needs a 'validator' object, but was given a '", class(x), "'.",call. = FALSE)
  }
  if (isTRUE(check_infeasible) && is_infeasible(x)){
    stop("This rule set is infeasible. Please fix and repair the rule set with `make_feasible` before continuing.", call. = FALSE)
  }
  invisible(x)
}

to_exprs <- function(x, ...){
  x$exprs( lin_eq_eps   = 0
         , lin_ineq_eps = 0
         , replace_in   = FALSE
         , vectorize    = FALSE
         )
}


get_variables_num <- function(x){
  var_num <- sapply(to_miprules(x), function(mr){
    names(mr$type)[mr$type == "double"]
  })
  unique(unlist(var_num))
}

get_variables_cat <- function(x){
  var_cat <- sapply(to_miprules(x), function(mr){
    nms <- names(mr$type)
    nms[mr$type == "binary" & grepl(":", nms)]
  })
  var_cat <- unique(unlist(var_cat))
  if (length(var_cat) == 0){
    return(
      data.frame( bin_variable = character(0)
                , variable     = character(0)
                , value        = character(0)
                , stringsAsFactors = FALSE
      )
    )
  }

  data.frame( bin_variable = var_cat
            , variable     = sub(":.*$", "", var_cat)
            , value        = sub("^.*:", "", var_cat)
            , stringsAsFactors = FALSE
            )
}
remove_trailing_comma <- function(x) sub(",$", "", x)
which_or_NA <- function(v) {
  ind <- which(v)
  if (length(ind) == 0) {ind <- NA_integer_}
  return(ind)
}

convert_unicode_to_ascii <- function(string) {
  old <- paste0("\u00C0\u00C1\u00C2\u00C3\u00C8\u00C9\u00CA\u00CC\u00CD\u00D2",
                "\u00D3\u00D4\u00D5\u00D9\u00DA\u00DD\u00E0\u00E1\u00E2\u00E3",
                "\u00E8\u00E9\u00EA\u00EC\u00ED\u00F2\u00F3\u00F4\u00F5\u00F9",
                "\u00FA\u00FD\u0102\u0103\u0110\u0111\u0128\u0129\u0168\u0169",
                "\u01A0\u01A1\u01AF\u01B0\u1EA0\u1EA1\u1EA2\u1EA3\u1EA4\u1EA5",
                "\u1EA6\u1EA7\u1EA8\u1EA9\u1EAA\u1EAB\u1EAC\u1EAD\u1EAE\u1EAF",
                "\u1EB0\u1EB1\u1EB2\u1EB3\u1EB4\u1EB5\u1EB6\u1EB7\u1EB8\u1EB9",
                "\u1EBA\u1EBB\u1EBC\u1EBD\u1EBE\u1EBF\u1EC0\u1EC1\u1EC2\u1EC3",
                "\u1EC4\u1EC5\u1EC6\u1EC7\u1EC8\u1EC9\u1ECA\u1ECB\u1ECC\u1ECD",
                "\u1ECE\u1ECF\u1ED0\u1ED1\u1ED2\u1ED3\u1ED4\u1ED5\u1ED6\u1ED7",
                "\u1ED8\u1ED9\u1EDA\u1EDB\u1EDC\u1EDD\u1EDE\u1EDF\u1EE0\u1EE1",
                "\u1EE2\u1EE3\u1EE4\u1EE5\u1EE6\u1EE7\u1EE8\u1EE9\u1EEA\u1EEB",
                "\u1EEC\u1EED\u1EEE\u1EEF\u1EF0\u1EF1\u1EF2\u1EF3\u1EF4\u1EF5",
                "\u1EF6\u1EF7\u1EF8\u1EF9\u00d0")
  new <- paste0("AAAAEEEIIO",
                "OOOUUYaaaa",
                "eeeiioooou",
                "uyAaDdIIUu",
                "OoUuAaAaAa",
                "AaAaAaAaAa",
                "AaAaAaAaEe",
                "EeEeEeEeEe",
                "EeEeIiIiOo",
                "OoOoOoOoOo",
                "OoOoOoOoOo",
                "OoUuUuUuUu",
                "UuUuUuYyYy",
                "YyYyD")
  return(chartr(old, new, string))
}
mergeLists <- function (base_list, overlay_list, recursive = TRUE) {
  if (length(base_list) == 0)
    overlay_list
  else if (length(overlay_list) == 0)
    base_list
  else {
    merged_list <- base_list
    for (name in names(overlay_list)) {
      base <- base_list[[name]]
      overlay <- overlay_list[[name]]
      if (is.list(base) && is.list(overlay) && recursive)
        merged_list[[name]] <- mergeLists(base, overlay)
      else {
        merged_list[[name]] <- NULL
        merged_list <- append(merged_list,
                              overlay_list[which(names(overlay_list) %in% name)])
      }
    }
    merged_list
  }
}

toArrayList <- function(obj, names = TRUE){
  value = lapply(1:nrow(obj), function(i) {
    res <- as.list(obj[i, , drop = FALSE])
    if (!names) names(res) <- NULL
    res
  })
  names(value) <- NULL;
  value
}

#' Export magrittr function
#' 
#' Export magrittr function
#' 
#' @importFrom magrittr %>%
#' @name %>%
#' @export
#' @rdname visNetwork-exports
NULL
permute.mean.QTL.terms_ <- function(df, the.perm = sample(x = nrow(df))) {

  mean.qtl.col.names <- grep(pattern = 'mean.QTL', x = names(df), value = TRUE)
  for (mean.qtl.col.name in mean.qtl.col.names) {
    df[[mean.qtl.col.name]] <- df[[mean.qtl.col.name]][the.perm]
  }
  return(df)
}


permute.var.QTL.terms_ <- function(df, the.perm = sample(x = nrow(df))) {

  var.qtl.col.names <- grep(pattern = 'var.QTL', x = names(df), value = TRUE)
  for (var.qtl.col.name in var.qtl.col.names) {
    df[[var.qtl.col.name]] <- df[[var.qtl.col.name]][the.perm]
  }
  return(df)
}

permute.QTL.terms_ <- function(df, the.perm = sample(x = nrow(df))) {

  df2 <- permute.var.QTL.terms_(df = df, the.perm = the.perm)
  df3 <- permute.mean.QTL.terms_(df = df2, the.perm = the.perm)
  return(df3)
}
# VIA: http://stackoverflow.com/q/13294952/1457051

rbind_gtable_max <- function(...) {

  gtl <- list(...)

  stopifnot(all(sapply(gtl, is.gtable)))

  bind2 <- function (x, y) {

    stopifnot(ncol(x) == ncol(y))

    if (nrow(x) == 0) return(y)
    if (nrow(y) == 0) return(x)

    y$layout$t <- y$layout$t + nrow(x)
    y$layout$b <- y$layout$b + nrow(x)
    x$layout <- rbind(x$layout, y$layout)

    x$heights <- insert_unit(x$heights, y$heights)
    x$rownames <- c(x$rownames, y$rownames)
    x$widths <- unit.pmax(x$widths, y$widths)
    x$grobs <- append(x$grobs, y$grobs)

    x

  }
  Reduce(bind2, gtl)

}

cbind_gtable_max <- function(...) {

  gtl <- list(...)

  stopifnot(all(sapply(gtl, is.gtable)))

  bind2 <- function (x, y) {

    stopifnot(nrow(x) == nrow(y))

    if (ncol(x) == 0) return(y)
    if (ncol(y) == 0) return(x)

    y$layout$l <- y$layout$l + ncol(x)
    y$layout$r <- y$layout$r + ncol(x)
    x$layout <- rbind(x$layout, y$layout)

    x$widths <- insert_unit(x$widths, y$widths)
    x$colnames <- c(x$colnames, y$colnames)
    x$heights <- unit.pmax(x$heights, y$heights)
    x$grobs <- append(x$grobs, y$grobs)

    x

  }

  Reduce(bind2, gtl)

}

insert_unit <- function (x, values, after = length(x)) {

  lengx <- length(x)

  if (lengx == 0) return(values)
  if (length(values) == 0) return(x)

  if (after <= 0) {
    unit.c(values, x)
  } else if (after >= lengx) {
    unit.c(x, values)
  } else {
    unit.c(x[1L:after], values, x[(after + 1L):lengx])
  }

}
## seconds to H:M:S format
sec2hms <- function (...) {
    x <- c(...)
    if (any(x > 3600)) stop("`...` must be <= 3600")
    hs <- x%%3600
    h <- floor(hs)
    ms <- (hs - h) * 60
    m <- floor(ms)
    s <- floor((ms - m) * 60)

    hms <- lapply(list(h, m, s), function(x) sprintf("%02d", x))
    chron::times(paste(hms[[1]], hms[[2]], hms[[3]], sep=":"))
}


## Hijack a function
## see: http://stackoverflow.com/a/25366322/1000343
hijack <- function(FUN, ...){

    .FUN <- FUN

    args <- list(...)
    invisible(lapply(seq_along(args), function(i) {
        formals(.FUN)[[names(args)[i]]] <<- args[[i]]
    }))

    .FUN
}

## taked from the qdapTools package
mtabulate <- function (vects) {
    lev <- sort(unique(unlist(vects)))
    dat <- do.call(rbind, lapply(vects, function(x, lev) {
        tabulate(factor(x, levels = lev, ordered = TRUE), nbins = length(lev))
    }, lev = lev))
    colnames(dat) <- sort(lev)
    data.frame(dat, check.names = FALSE)
}

validate_relate <- function(x){
    grepl("[\\+\\-\\*\\/]([^_]+)_(.+)", x, perl=TRUE)
}
#' Pipe operator
#'
#' See \code{magrittr::\link[magrittr]{\%>\%}} for details.
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @export
#' @importFrom magrittr %>%
#' @usage lhs \%>\% rhs
NULL
`%||%` <- function(l, r) if (is.null(l)) r else l

update <- function(original, new) {

  if (length(new)) {
    assert_named(original)
    assert_named(new)
    original[names(new)] <- new
  }

  original
}

read_file <- function(x) {
  readChar(x, file.info(x)$size)
}

`%+%` <- function(l, r) {
  assert_string(l)
  assert_string(r)
  paste0(l, r)
}

str <- function(x) {
  as.character(x)
}

is_windows <- function() .Platform$OS.type == "windows"

is_osx     <- function() Sys.info()[['sysname']] == 'Darwin'

is_linux   <- function() Sys.info()[['sysname']] == 'Linux'

dir_exists <- function(path) utils::file_test('-d', path)
#Organically grows or reduces collectors and column names for Amazon CloudFront files to compensate for changes
#in the number of fields. Kind of icky but it works and looks great from the user end, so..
aws_header_select <- function(header_fields){
  field_names <- c("date", "time", "x-edge-location", "sc-bytes", "c-ip", "cs-method",
                   "cs(Host)", "cs-uri-stem", "sc-status", "cs(Referer)", "cs(User-Agent)", "cs-uri-query",
                   "cs(Cookie)", "x-edge-result-type", "x-edge-request-id", "x-host-header", "cs-protocol", "cs-bytes",
                   "time-taken")
  
  new_names <- c("date", "time", "edge_location", "bytes_sent", "ip_address", "http_method", "host", "path",
                 "status_code", "referer", "user_agent", "query", "cookie", "result_type", "request_id",
                 "host_header", "protocol", "bytes_received", "time_elapsed")
  
  collectors <- list(col_character(), col_character(), col_character(), col_integer(), col_character(),
                     col_character(), col_character(), col_character(), col_integer(), col_character(),
                     col_character(), col_character(), col_character(), col_character(), col_character(),
                     col_character(), col_character(), col_character(), col_number())
  if(length(header_fields) == length(field_names) && all(header_fields == field_names)){
    return(list(new_names, collectors))
  }
  
  out_names <- character()
  out_collectors <- list()
  for(field in header_fields){
    location <- which(field_names == field)[1]
    out_names <- append(out_names, new_names[location])
    out_collectors <- c(out_collectors, collectors[location])
  }
  if(anyNA(out_names)){
    stop("Your file contains unrecognised fields")
  }
  return(list(out_names, out_collectors))
}

unix_to_posix <- function(ts){
  return(as.POSIXct(ts, origin = '1970-01-01', tz = "UTC"))
}
# Override default for call. argument
stop <- function(..., call. = FALSE){
  base::stop(..., call. = FALSE)
}

# Strip trailing whitespace
trail <- function(str){
  str <- sub("\\s+$", "", str, perl = TRUE);
  sub("^\\s+", "", str, perl = TRUE);
}

rawToChar <- function(x){
  out <- base::rawToChar(x)
  Encoding(out) <- 'UTF-8'
  out
}
#'@title Create a token for WhoAPI
#'@description This function allows the creation of connectors to whoapi, which can be passed
#'between function calls, providing consistent API keys and options for different calls.
#'
#'@param key the API key to use.
#'
#'@param user_agent the user agent to use. NULL by default, which will use the \code{whoapi} package user agent.
#'
#'@export
whoapi_token <- function(key, user_agent = NULL){

  if(is.null(user_agent)){
    user_agent <- "whoapi R client: https://github.com/ironholds/whoapi"
  }

  output_object <- list(key = key, user_agent = user_agent)

  return(output_object)
}


#Convert character-stored numeric values to logical
char_convert <- function(x){
  return(as.logical(as.numeric(x)))
}

#Query function
whoapi_query <- function(token, url, ...){
  url <- paste0("http://api.whoapi.com/?apikey=", token$key, url)
  result <- httr::GET(url, user_agent(token$user_agent), ...)
  httr::stop_for_status(result)
  result <- httr::content(result)
  if(char_convert(result$status)){
    stop(result$status_desc)
  }
  return(result)
}
#' Comes from tidyr
#' @noRd
col_name <- function(x, default = stop("Please supply column name", call. = FALSE))
{
  if (is.character(x))
    return(x)
  if (identical(x, quote(expr = )))
    return(default)
  if (is.name(x))
    return(as.character(x))
  if (is.null(x))
    return(x)
  stop("Invalid column specification", call. = FALSE)
}
make_call <- function(...) {
  as.call(list(...))
}

vlapply <- function(X, FUN, ..., FUN.VALUE = logical(1)) {
  vapply(X, FUN, ..., FUN.VALUE = FUN.VALUE)
}

names2 <- function(x) {
  nms <- names(x)
  if (is.null(nms)) {
    rep("", length(x))
  } else {
    nms[is.na(nms)] <- ""
    nms
  }
}
check_resp <- function(response, message) {
  if (httr::http_error(response)) {
    doc <- get_xml(response)
    stop(message, parse_el_txt(doc, xpath = "//faultstring"), call. = FALSE)
  }
}

lapply2 <- function(...) sapply(..., simplify = FALSE, USE.NAMES = TRUE)

replace_if_0_rows <- function(x, replace = NULL) {
  if (is.data.frame(x)) {
    if (nrow(x) == 0) return(replace)
  }
  x
}

ua <- function() httr::user_agent("https://github.com/vt-arc/wosr")

format_num <- function(x) format(
  x, big.mark = ",", scientific = FALSE, trim = TRUE
)

append_class <- function(x, class) structure(x, class = c(class(x), class))
# returns string w/o leading or trailing whitespace
trim <- function (x) gsub("^\\s+|\\s+$", "", x)
stop_eventlog <- function(eventlog)
	if(!("eventlog" %in% class(eventlog)))
		stop("Function only applicable for class eventlog")
#' Obtain an attribute of an object without partial matching
#'
#' An abbreviation of \code{base::\link[base]{attr}(exact = TRUE)}.
#' @param ... Passed to \code{base::\link[base]{attr}()} (without the
#'   \code{exact} argument).
#' @export
#' @examples
#' z = structure(list(a = 1), foo = 2)
#' base::attr(z, 'f')  # 2
#' xfun::attr(z, 'f')  # NULL
#' xfun::attr(z, 'foo')  # 2
attr = function(...) base::attr(..., exact = TRUE)

#' Evaluate an expression under a specified working directory
#'
#' Change the working directory, evaluate the expression, and restore the
#' working directory.
#' @param dir Path to a directory.
#' @param expr An R expression.
#' @export
#' @examples
#' library(xfun)
#' in_dir(tempdir(), {print(getwd()); list.files()})
in_dir = function(dir, expr) {
  owd = setwd(dir); on.exit(setwd(owd))
  expr
}

#' Test if an object is identical to \code{FALSE}
#'
#' A simple abbreviation of \code{identical(x, FALSE)}.
#' @param x An R object.
#' @export
#' @examples
#' library(xfun)
#' isFALSE(TRUE)  # false
#' isFALSE(FALSE)  # true
#' isFALSE(c(FALSE, FALSE))  # false
isFALSE = function(x) identical(x, FALSE)

#' Parse R code and do not keep the source
#'
#' An abbreviation of \code{parse(keep.source = FALSE)}.
#' @param code A character vector of the R source code.
#' @export
#' @return R \code{\link{expression}}s.
#' @examples library(xfun)
#' parse_only('1+1'); parse_only(c('y~x', '1:5 # a comment'))
#' parse_only(character(0))
parse_only = function(code) {
  if (length(code) == 0) return(expression())
  parse(text = code, keep.source = FALSE)
}

#' Try to evaluate an expression silently
#'
#' An abbreviation of \code{try(silent = TRUE)}.
#' @param expr An R expression.
#' @export
#' @examples library(xfun)
#' z = try_silent(stop('Wrong!'))
#' inherits(z, 'try-error')
try_silent = function(expr) try(expr, silent = TRUE)
## .onLoad <- function(libname, pkgname)
## {
##   .jpackage(pkgname)
  
##   # what's your java  version?  Need >= 1.5.0.
##   jversion <- .jcall('java.lang.System','S','getProperty','java.version')
##   if (jversion < "1.5.0")
##     stop(paste("Your java version is ", jversion,
##                  ".  Need 1.5.0 or higher.", sep=""))

## }
sheetExists <- function(wb, ws_name) {
  sheets <- names(wb)
  return(ws_name %in% sheets)
}

not_null <- function(x) {
  !(is.null(x))
}

not_na <- function(x) {
  !(is.na(x))
}


remove_leading_trailing_pipe <- function(x) {
  x <-  gsub("\\|+$", "", x, perl=TRUE)
  x <-  gsub("^\\|+", "", x, perl=TRUE)
  x
}

is_null_or_blank <- function(x) {
  if (length(x) > 1) {
    stop("You passed something of length > 1 to is_null_or_blank")
  }

  if (is.null(x)) {
    return(TRUE)
  }

  if (x == "") {
    return(TRUE)
  }

  return(FALSE)
}

get_prop_or_return_null <- function(mylist, key) {
  if (key %in% names(mylist) ) {
    return(mylist[[key]])
  } else {
    return(NULL)
  }
}

is_truely_na <- function(x){
  return(is.na(x) & !is.nan(x))
}
spaces_const <- sapply(1:41-1, function(x) paste(rep(" ", x), collapse = ""))

spaces <- function(x) spaces_const[ pmin(x, 40) + 1 ]
#' @source tidyverse
#' @keywords internal

startup_message <- function(...) {
    if (isTRUE(getOption("tidyverse.quiet")))
        return()

    packageStartupMessage(...)
}

#' @source tidyverse
#' @keywords internal

bullets <- function(...) {
    message(paste0(" * ", ..., collapse = "\n"))
}
dir_all <- function(files) {
  if (! length(files)) return(files)

  info <- file.info(files)

  unlist(lapply(
    seq_along(files),
    function(i) {
      if (info$isdir[i]) {
        dir(files[i], recursive = TRUE, full.names = TRUE)
      } else {
        files[i]
      }
    }
  ))
}

ignore_dirs_with_warning <- function(files) {
  info <- file.info(files)
  if (any(info$isdir)) {
    warning("directories ignored in zip file, specify recurse = TRUE")
    files <- files[!info$isdir]
  }
  files
}
## test return value of "try"
isError <- function(x) {
  return(class(x) == "try-error")
}

## fetch current limits
.lim <- function(usr) {
  d <- diff(usr)/1.08
  return(usr[1:2]+d*c(0.04, -0.04))
}

## fetch current xlim
.xlim <- function() {
  return(.lim(par("usr")[1:2]))
}

## fetch current ylim
.ylim <- function() {
  return(.lim(par("usr")[3:4]))
}

## move xlim limits:
.movelim <- function(lim, width) {
  step <- diff(lim)*width
  return(lim+step)
}

## move xlim limits
##  width > 0 => to the right
##  width < 0 => to the left
.moveXlim <- function(width) {
  return(.movelim(.xlim(), width=width))
}

## move ylim limits
##  width > 0 => up
##  width < 0 => down
.moveYlim <- function(width) {
  return(.movelim(.ylim(), width=width))
}

## zoom limits
.zoomLim <- function(lim, width) {
  d <- diff(lim)/2/width
  m <- sum(lim)/2
  return(m+d*c(-1, 1))
}

## zoom only x axis
##  width < 1 => zoom out
##  width > 1 => zoom in
.zoomXlim <- function(width) {
  return(.zoomLim(.xlim(), width))
}

## zoom only y axis
##  width < 1 => zoom out
##  width > 1 => zoom in
.zoomYlim <- function(width) {
  return(.zoomLim(.ylim(), width))
}