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

### function to set default 'btt' value(s) or check specified 'btt' values

.set.btt <- function(btt, p, int.incl, Xnames, fixed=FALSE) {

   mstyle <- .get.mstyle()

   if (missing(btt) || is.null(btt)) {

      if (p > 1L) {                       # if the model matrix has more than one column
         if (int.incl) {
            btt <- seq.int(from=2, to=p)     # and the model has an intercept term, test all coefficients except the intercept
         } else {
            btt <- seq_len(p)                # and the model does not have an intercept term, test all coefficients
         }
      } else {
         btt <- 1L                        # if the model matrix has a single column, test that single coefficient
      }

   } else {

      if (is.character(btt)) {

         btt <- grep(btt, Xnames, fixed=fixed)

         if (length(btt) == 0L)
            stop(mstyle$stop("Cannot identify coefficient(s) corresponding to the specified 'btt' string."), call.=FALSE)

      } else {

         ### round, take unique values, sort, and turn into integer(s)
         btt <- as.integer(sort(unique(round(btt))))

         ### check for mix of positive and negative values
         if (any(btt < 0) && any(btt > 0))
            stop(mstyle$stop("Cannot mix positive and negative 'btt' values."), call.=FALSE)

         ### keep/remove from 1:p vector as specified
         btt <- seq_len(p)[btt]

         ### (1:5)[5:6] yields c(5, NA) so remove NAs if this happens
         btt <- btt[!is.na(btt)]

         ### make sure that at least one valid value is left
         if (length(btt) == 0L)
            stop(mstyle$stop("Non-existent coefficient(s) specified via 'btt'."), call.=FALSE)

      }

   }

   return(btt)

}

### function to format 'btt' value(s) for printing

.format.btt <- function(btt) {

   sav <- c()

   if (length(btt) > 1L) {

      btt <- sort(btt)

      while (length(btt) > 0L) {

         x <- rle(diff(btt))

         if (x$values[1] == 1 && length(x$values) != 0L) {
            sav <- c(sav, c(btt[1], ":", btt[x$lengths[1] + 1]))
            btt <- btt[-c(1:(x$lengths[1] + 1))]
            #sav <- c(sav, ", ") # this adds a space between multiple a:b sets
            sav <- c(sav, ",")
         } else {
            sav <- c(sav, btt[1], ",")
            btt <- btt[-1]
         }

      }

      sav <- paste0(sav[-length(sav)], collapse="")

   } else {

      sav <- paste0(btt)

   }

   return(sav)

}

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

### pairwise sorting of the elements of two vectors

#.psort.old <- function(x, y) {
#
#   if (is.null(x) || length(x) == 0L) # need to catch this
#      return(NULL)
#
#   if (missing(y)) {
#      if (is.matrix(x)) {
#         xy <- x
#      } else {
#         xy <- rbind(x) # in case x is just a vector
#      }
#   } else {
#      xy <- cbind(x,y)
#   }
#
#   n <- nrow(xy)
#
#   for (i in seq_len(n)) {
#      if (anyNA(xy[i,]))
#         next
#      xy[i,] <- sort(xy[i,])
#   }
#
#   colnames(xy) <- NULL
#
#   return(xy)
#
#}

.psort <- function(x, y, as.list=FALSE) {

   # simpler / vectorized version that also deals with x and y being matrices
   # (of the same dimensions) for elementwise swapping of pairs as needed

   # t(apply(xy, 1, sort)) would be okay, but problematic if there are NAs;
   # either they are removed completely (na.last=NA) or they are always put
   # first/last (na.last=FALSE/TRUE); but we just want to leave the NAs in
   # their position!

   if (is.null(x) || length(x) == 0L) # need to catch this
      return(NULL)

   if (missing(y)) {
      if (is.matrix(x)) {
         y <- x[,2]
         x <- x[,1]
      } else {
         y <- x[2]
         x <- x[1]
      }
   }

   flip <- x > y
   flip[is.na(flip)] <- FALSE

   x.flip <- x
   y.flip <- y

   x.flip[flip] <- y[flip]
   y.flip[flip] <- x[flip]

   if (as.list) {
      return(list(x=x.flip, y=y.flip))
   } else {
      return(unname(cbind(x.flip, y.flip)))
   }

}

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

### function for applying observation limits

.applyolim <- function(x, olim) {
   x[x < olim[1]] <- olim[1]
   x[x > olim[2]] <- olim[2]
   return(x)
}

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

### function to take the square root of a vector of numbers, giving NA for negative numbers (without a warning)

.sqrt <- function(x)
   sapply(x, function(x) if (is.na(x) || x < 0) NA_real_ else sqrt(x))

### function to construct a diagonal matrix that also works if x is a scalar

.diag <- function(x, names=TRUE, dim) {
   if (missing(dim)) {
      k <- NROW(x)
   } else {
      k <- dim
   }
   diag(x, nrow=k, ncol=k, names=names)
}

### function to obtain the trace of a matrix

.tr <- function(X)
   return(sum(diag(X)))

### function to check if a matrix is square

.is.square <- function(X)
   NROW(X) == NCOL(X)

### use NROW/NCOL to better deal with scalars; compare:
### (V <- list(matrix(1, nrow=2, ncol=2), 3, c(1,4), cbind(c(2,1)))); sapply(V, function(x) nrow(x) == ncol(x)); sapply(V, function(x) NROW(x) == NCOL(x))

### function to test whether a vector is all equal to 1s (e.g., to find intercept(s) in a model matrix)

.is.intercept <- function(x, eps=1e-08)
   return(all(abs(x - 1) < eps))

### function to check if a formula is simply '~ 1'

.is.tilde1 <- function(f) {
   # isTRUE(all.equal(f, ~ 1))
   tt <- terms(f)
   length(attr(tt, "term.labels")) == 0L && attr(tt, "intercept") == 1L
}

### function to test whether a vector is a dummy variable (i.e., consists of only 0s and 1s)

.is.dummy <- function(x, eps=1e-08)
   return(all(abs(x) < eps | abs(x - 1) < eps))
   #return(all(sapply(x, identical, 0) | sapply(x, identical, 1)))

### function to test whether something is a vector (in the sense of being atomic, not a matrix, and not NULL)

.is.vector <- function(x)
   is.atomic(x) && !is.matrix(x) && !is.null(x)

### function to test if a string is an integer and to return the integer if so (otherwise return NA)

.is.stringint <- function(x) {
   is.int <- grepl("^[0-9]+L?$", x)
   if (is.int) {
      x <- sub("L", "", x, fixed=TRUE)
      x <- as.integer(x)
   } else {
      x <- NA
   }
   return(x)
}

### function to test if x is a matrix and that also covers Matrix objects

.is.matrix <- function(x)
   is.matrix(x) || inherits(x, "Matrix")

### function to test if x is numeric but also allow a (vector of) NA

.is.numeric <- function(x) {
   if (all(is.na(x)))
      return(TRUE)
   is.numeric(x)
}

### function to test if two model matrices are nested

.is.nested <- function(x1, x2) {

   if (nrow(x1) != nrow(x2))
      return(FALSE)

   # compute ranks manually using qr()

   #qrx1 <- try(qr(x1), silent=TRUE)
   #qrx2 <- try(qr(x2), silent=TRUE)
   #qrx1x2 <- try(qr(cbind(x1, x2)), silent=TRUE)

   #if (inherits(qrx1, "try-error") || inherits(qrx2, "try-error") || inherits(qrx1x2, "try-error"))
   #   return(FALSE)

   #rank.f <- max(qrx1$rank, qrx2$rank)
   #rank.c <- qrx1x2$rank

   # use Matrix::rankMatrix()

   rank.f <- c(max(rankMatrix(x1), rankMatrix(x2)))
   rank.c <- c(rankMatrix(cbind(x1,x2)))

   return(identical(rank.f, rank.c))

}

### sapply()-like function but for matrices that always preserves the matrix dimensions (used in traceplot.rma.uni())

.matapply <- function(x, FUN, targs=NULL) {
   if (is.null(x))
      return(NULL)
   if (is.null(targs)) {
      x[] <- sapply(x, FUN)
   } else {
      x[] <- sapply(x, FUN, targs)
   }
   return(x)
}

### check if ddd element is NULL; if so, return ifnull, otherwise return the ddd element or ifnot (if the latter is not NULL)

.chkddd <- function(x, ifnull=NULL, ifnot=NULL) {

   if (is.null(x)) {
      return(ifnull)
   } else {
      if (is.null(ifnot)) {
         return(x)
      } else {
         return(ifnot)
      }
   }

}

### function that expands a scalar to length k; can also expand a scalar to
### the maximum length of the list elements given to k

.expand1 <- function(x, k) {

   if (is.list(k))
      k <- max(lengths(k, use.names=FALSE))

   if (length(x) == 1L)
      x <- rep(x, k)

   return(x)

}

### function that takes a vector as input and creates an expanded vector of
### the length of 'fill' of all NAs but where the fill values are given by x
### (can also take an entire list as input)

.expandna <- function(x, fill) {
   if (is.list(x)) {
      return(lapply(x, function(xi) .expandna(xi, fill)))
   } else {
      if (!is.logical(fill))
         stop("Argument 'fill' is not a logical vector.")
      k <- length(fill)
      out <- rep(NA_real_, k)
      out[fill] <- x
      return(out)
   }
}

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

### function to format p-values (no longer used; use fmtp() instead)
### if showeq=FALSE, c(0.001, 0.00001) becomes c("0.0010", "<.0001")
### if showeq=TRUE,  c(0.001, 0.00001) becomes c("=0.0010", "<.0001")
### if add0=FALSE, "<.0001"; if add0=TRUE, "<0.0001"

.pval <- function(p, digits=4, showeq=FALSE, sep="", add0=FALSE) {

   digits  <- max(digits, 1)
   cutoff  <- paste(c(".", rep(0,digits-1),1), collapse="")
   ncutoff <- as.numeric(cutoff)

   ifelse(is.na(p), paste0(ifelse(showeq, "=", ""), sep, "NA"),
                    ifelse(p >= ncutoff, paste0(ifelse(showeq, "=", ""), sep, formatC(p, digits=digits, format="f")),
                                         paste0("<", sep, ifelse(add0, "0", ""), cutoff)))

}

### function to format/round values in general (no longer used; use fmtx() instead)

.fcf <- function(x, digits) {

   if (all(is.na(x))) { # since formatC(NA, format="f", digits=2) fails
      rep("NA", length(x))
   } else {
      trimws(formatC(x, format="f", digits=digits))
   }

}

### function to handle 'level' argument

.level <- function(level, allow.vector=FALSE, argname="level", stopon100=FALSE) {

   if (is.null(level))
      return(NULL)

   mstyle <- .get.mstyle()

   if (any(level > 100) || any(level < 0))
      stop(mstyle$stop(paste0("Argument '", argname, "' must be between 0 and 100.")), call.=FALSE)

   if (isTRUE(stopon100) && any(level==100))
      stop(mstyle$stop(paste0("Argument '", argname, "' cannot be equal to 100.")), call.=FALSE)

   if (!allow.vector && length(level) != 1L)
      stop(mstyle$stop(paste0("Argument '", argname, "' must specify a single value.")), call.=FALSE)

   if (!is.numeric(level))
      stop(mstyle$stop(paste0("The '", argname, "' argument must be numeric.")), call.=FALSE)

   ifelse(level == 0, 1, ifelse(level >= 1, (100-level)/100, ifelse(level > 0.5, 1-level, level)))

}

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

### function to print a named (character) vector right aligned with
### a gap of two spaces between adjacent values and no padding

.print.vector <- function(x, minfoot=NA, print.gap=2) {

   empty.last.colname <- colnames(x)[length(colnames(x))] == ""

   if (is.null(names(x)))
      names(x) <- seq_along(x)

   gap <- paste0(rep(" ", print.gap), collapse="")

   len.n   <- nchar(names(x))
   len.x   <- nchar(x, keepNA=FALSE)
   len.max <- pmax(len.n, len.x)
   #format  <- sapply(len.max, function(x) paste("%", x, "s", sep=""))

   #row.n <- paste(sprintf(format, names(x)), collapse=gap) # sprintf("%3s", "\u00b9") isn't right
   #row.x <- paste(sprintf(format, x), collapse=gap)

   #f <- function(x, n)
   #   paste0(paste0(rep(" ", n-nchar(x)), collapse=""), x, collapse="")
   #row.n <- paste(mapply(f, names(x), len.max), collapse=gap)
   #row.x <- paste(mapply(f, unname(x), len.max), collapse=gap)

   if (is.na(minfoot)) {
      row.n <- paste(mapply(formatC, names(x), width=len.max), collapse=gap) # formatC("\u00b9", width=3) works
      row.x <- paste(mapply(formatC, x, width=len.max), collapse=gap)
   } else {
      row.n <- mapply(formatC, names(x), width=len.max)
      row.n[minfoot] <- paste0(" ", row.n[minfoot])
      row.n <- paste(row.n, collapse=gap)
      row.x <- mapply(formatC, x, width=len.max)
      if (empty.last.colname) {
         row.x[length(row.x)] <- paste0(" ", row.x[length(row.x)])
      } else {
         row.x[length(row.x)] <- paste0(row.x[length(row.x)], " ")
      }
      row.x <- paste(row.x, collapse=gap)
   }

   cat(row.n, "\n", row.x, "\n", sep="")

}

.addfootsym <- function(x, cols, footsym) {
   nc <- length(cols)
   if (length(footsym) == 1L)
      footsym <- rep(footsym, nc)
   if (length(footsym) != nc)
      stop(paste0("Length of 'cols' not the same as length of 'footsym' in .addfootsym()."), call.=FALSE)
   for (i in seq_along(cols)) {
      colnames(x)[cols[i]] <- paste0(colnames(x)[cols[i]], footsym[i])
      x[[cols[i]]] <- paste0(x[[cols[i]]], " ")
   }
   return(x)
}

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

.space <- function(x=TRUE) {
   if (exists(".rmspace")) {
      addspace <- FALSE
   } else {
      addspace <- isTRUE(getmfopt("space", default=TRUE))
   }
   if (addspace && x)
      cat("\n")
   if (!addspace && !x)
      cat("\n")
}

.get.footsym <- function() {

   fs <- getmfopt("footsym")

   if (is.null(fs) || length(fs) != 6L)
      fs <- c("\u00b9", "1)", "\u00b2", "2)", "\u00b3", "3)")

   return(fs)

}

# setmfopt(footsym = c("\u00b9", "\u00b9\u207e", "\u00b2", "\u00b2\u207e", "\u00b3", "\u00b3\u207e"))

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

### function that prints the model fitting time

.print.time <- function(x) {

   mstyle <- .get.mstyle()

   hours   <- floor(x/60/60)
   minutes <- floor(x/60) - hours*60
   seconds <- round(x - minutes*60 - hours*60*60, ifelse(x > 60, 0, 2))

   cat("\n")
   cat(mstyle$message(paste("Processing time:", hours, ifelse(hours == 0 || hours > 1, "hours,", "hour,"), minutes, ifelse(minutes == 0 || minutes > 1, "minutes,", "minute,"), seconds, ifelse(x < 60 || seconds == 0 || seconds > 1, "seconds", "second"))))
   cat("\n")

}

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

### function like make.unique(), but starts at .1 for the first instance
### of a repeated element

.make.unique <- function(x) {

   if (is.null(x))
      return(NULL)

   x <- as.character(x)
   ux <- unique(x)

   for (i in seq_along(ux)) {
      #xiTF <- x == ux[i]
      xiTF <- x %in% ux[i] # works also with NAs in vector (multiple NAs are then NA.1, NA.2, ...)
      xi <- x[xiTF]
      if (length(xi) == 1L)
         next
      x[xiTF] <- paste(xi, seq_along(xi), sep=".")
   }

   return(x)

}

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

### function to check if extra/superfluous arguments are specified via ...

.chkdots <- function(ddd, okargs) {

   for (i in seq_along(okargs))
      ddd[okargs[i]] <- NULL

   if (length(ddd) > 0L) {
      mstyle <- .get.mstyle()
      warning(mstyle$warning(paste0("Extra argument", ifelse(length(ddd) > 1L, "s ", " "), "(", paste0("'", names(ddd), "'", collapse=", "), ") disregarded.")), call.=FALSE)
   }

}

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

.getx <- function(x, mf, data, enclos=sys.frame(sys.parent(n=2)), checknull=TRUE, checknumeric=FALSE, default) {

   mstyle <- .get.mstyle()

   mf.getx <- match.call()
   dname <- deparse1(mf.getx[[match("data", names(mf.getx))]])
   dname <- deparse1(mf[[match(dname, names(mf))]])

   mf.x <- mf[[match(x, names(mf))]]

   if (!is.null(dname) && dname %in% names(data) && grepl("$", deparse1(mf.x), fixed=TRUE) || grepl("[[", deparse1(mf.x), fixed=TRUE))
      data <- NULL

   out <- try(eval(mf.x, data, enclos), silent=TRUE) # NULL if x was not specified

   if (inherits(out, "try-error") || is.function(out))
      stop(mstyle$stop(paste0("Cannot find the object/variable ('", deparse(mf.x), "') specified for the '", x, "' argument.")), call.=FALSE)

   # note: is.function() check catches case where 'vi' is the utils::vi() function and other shenanigans

   # check if x is actually one of the elements in the call

   spec <- x %in% names(mf)

   # out could be NULL if it is not a specified argument; if so, apply default if there is one

   if (is.null(out) && !spec && !missing(default))
      out <- default

   if (checknull) {

      # when using something like fun(dat$blah) and blah doesn't exist in dat, then get NULL

      if (spec && is.null(out)) {
         mf.txt <- deparse(mf.x)
         if (mf.txt == "NULL") {
            mf.txt <- " "
         } else {
            mf.txt <- paste0(" ('", mf.txt, "') ")
         }
         stop(mstyle$stop(paste0(deparse(mf)[1], ":\nThe object/variable", mf.txt, "specified for the '", x, "' argument is NULL.")), call.=FALSE)
      }

   }

   if (checknumeric && !is.null(out) && !is.list(out) && !.is.numeric(out[1])) # using [1] so is.numeric(Matrix(1:3)[1]) works
      stop(mstyle$stop(paste0("The object/variable specified for the '", x, "' argument is not numeric.")), call.=FALSE)

   return(out)

}

.getfromenv <- function(what, element, envir=.metafor, default=NULL) {

   x <- try(get(what, envir=envir, inherits=FALSE), silent=TRUE)
   if (inherits(x, "try-error")) {
      return(default)
   } else {
      if (missing(element)) {
         return(x)
      } else {
         x <- x[[element]]
         if (is.null(x)) {
            return(default)
         } else {
            return(x)
         }
      }
   }

}

### a version of do.call() that allows for the arguments to be passed via ... (i.e., can either be a list or not) and removes NULL arguments

.do.call <- function(fun, ...) {
   if (is.list(..1) && ...length() == 1L) {
      args <- c(...)
   } else {
      args <- list(...)
   }
   args <- args[!sapply(args, is.null)]
   do.call(fun, args)
}

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

.chkclass <- function(class, must, notap, notav, type="Method") {

   mstyle <- .get.mstyle()

   obj <- as.character(match.call()[2])
   obj <- substr(obj, 7, nchar(obj)-1)

   if (!missing(must) && !is.element(must, class))
      stop(mstyle$stop(paste0("Argument '", obj, "' must be an object of class \"", must, "\".")), call.=FALSE)

   if (!missing(notap) && any(is.element(notap, class)))
      stop(mstyle$stop(paste0(type, " not applicable to objects of class \"", class[1], "\".")), call.=FALSE)
      #stop(mstyle$stop(paste0("Method not applicable to objects of class \"", paste0(class, collapse=", "), "\".")), call.=FALSE)

   if (!missing(notav) && any(is.element(notav, class)))
      stop(mstyle$stop(paste0(type, " not available for objects of class \"", class[1], "\".")), call.=FALSE)
      #stop(mstyle$stop(paste0("Method not available for objects of class \"", paste0(class, collapse=", "), "\".")), call.=FALSE)

}

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

.chkviarg <- function(x) {

   runvicheck <- .getfromenv("runvicheck", default=TRUE)

   if (runvicheck) {

      x <- deparse(x)
      xl <- tolower(x)

      ok <- TRUE

      # starts with 'se' or 'std'
      if (any(grepl("^se", xl)))
         ok <- FALSE
      if (any(grepl("^std", xl)))
         ok <- FALSE
      # ends with 'se' or 'std'
      if (any(grepl("se$", xl)))
         ok <- FALSE
      if (any(grepl("std$", xl)))
         ok <- FALSE
      # catch cases where vi=<data frame>$se and vi=<data frame>$std
      if (any(grepl("^[[:alpha:]][[:alnum:]_.]*\\$se", xl)))
         ok <- FALSE
      if (any(grepl("^[[:alpha:]][[:alnum:]_.]*\\$std", xl)))
         ok <- FALSE

      # but if ^, *, or ( appears, don't issue a warning
      if (any(grepl("^", xl, fixed=TRUE)))
         ok <- TRUE
      if (any(grepl("*", xl, fixed=TRUE)))
         ok <- TRUE
      if (any(grepl("(", xl, fixed=TRUE)))
         ok <- TRUE

      if (!ok) {
         mstyle <- .get.mstyle()
         warning(mstyle$warning(paste0("The 'vi' argument should be used to specify sampling variances,\nbut '", x, "' sounds like this variable may contain standard\nerrors (maybe use 'sei=", x, "' instead?).")), call.=FALSE)
         try(assign("runvicheck", FALSE, envir=.metafor), silent=TRUE)
      }

   }

}

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

### check that the lengths of all non-zero length elements given via ... are equal to each other

.equal.length <- function(...) {

   ddd <- list(...)
   ks <- lengths(ddd)   # get the length of each element in ddd
   if (all(ks == 0L)) { # if all elements have length 0 (are NULL), return TRUE
      return(TRUE)
   } else {
      ks <- ks[ks > 0L] # keep the non-zero lengths
      return(length(unique(ks)) == 1L) # check that they are all identical
   }

}

### check that all elements given via ... are not of length 0 (are not NULL)

.all.specified <- function(...) {

   ddd <- list(...)
   #all(!sapply(ddd, is.null))
   not0 <- lengths(ddd) != 0L
   all(not0)

}

### get the maximum length of a bunch of vectors

.maxlength <- function(...)
   max(lengths(list(...), use.names=FALSE))

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

### set axis label (for forest, funnel, and labbe functions)

.setlab <- function(measure, transf.char, atransf.char, gentype, short=FALSE) {

   if (gentype == 1)
      lab <- "Observed Outcome"
   if (gentype == 2)
      lab <- "Overall Estimate" # for forest.cumul.rma() function
   if (gentype == 3)
      lab <- "Estimate"         # for header

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

   if (!is.null(measure)) {

      ######################################################################
      if (is.element(measure, c("RR","MPRR"))) {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Log[RR]", "Log Risk Ratio")
         } else {
            lab <- ifelse(short, lab, "Transformed Log Risk Ratio")
            funlist <- lapply(list(exp, transf.exp.int), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "Risk Ratio", "Risk Ratio (log scale)")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "Risk Ratio", "Risk Ratio")
         }
      }
      if (is.element(measure, c("OR","PETO","D2OR","D2ORN","D2ORL","MPOR","MPORC","MPPETO","MPORM"))) {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Log[OR]", "Log Odds Ratio")
         } else {
            lab <- ifelse(short, lab, "Transformed Log Odds Ratio")
            funlist <- lapply(list(exp, transf.exp.int), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "Odds Ratio", "Odds Ratio (log scale)")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "Odds Ratio", "Odds Ratio")
         }
      }
      if (is.element(measure, c("RD","MPRD"))) {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Risk Difference", "Risk Difference")
         } else {
            lab <- ifelse(short, lab, "Transformed Risk Difference")
         }
      }
      if (measure == "AS") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Arcsine RD", "Arcsine Transformed Risk Difference")
         } else {
            lab <- ifelse(short, lab, "Transformed Arcsine Transformed Risk Difference")
         }
      }
      if (measure == "PHI") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Phi", "Phi Coefficient")
         } else {
            lab <- ifelse(short, lab, "Transformed Phi Coefficient")
         }
      }
      if (measure == "ZPHI") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, expression('Fisher\'s ' * z[phi]), "Fisher's z Transformed Phi Coefficient")
         } else {
            lab <- ifelse(short, lab, "Transformed Fisher's z Transformed Phi Coefficient")
            funlist <- lapply(list(transf.ztor, transf.ztor.int, tanh), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "Phi", "Phi Coefficient")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "Phi", "Phi Coefficient")
         }
      }
      if (measure == "YUQ") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Yule's Q", "Yule's Q")
         } else {
            lab <- ifelse(short, lab, "Transformed Yule's Q")
         }
      }
      if (measure == "YUY") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Yule's Y", "Yule's Y")
         } else {
            lab <- ifelse(short, lab, "Transformed Yule's Y")
         }
      }
      ######################################################################
      if (measure == "IRR") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Log[IRR]", "Log Incidence Rate Ratio")
         } else {
            lab <- ifelse(short, lab, "Transformed Log Incidence Rate Ratio")
            funlist <- lapply(list(exp, transf.exp.int), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "Rate Ratio", "Incidence Rate Ratio (log scale)")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "Rate Ratio", "Incidence Rate Ratio")
         }
      }
      if (measure == "IRD") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "IRD", "Incidence Rate Difference")
         } else {
            lab <- ifelse(short, lab, "Transformed Incidence Rate Difference")
         }
      }
      if (measure == "IRSD") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "IRSD", "Square Root Transformed Incidence Rate Difference")
         } else {
            lab <- ifelse(short, lab, "Transformed Square Root Transformed Incidence Rate Difference")
         }
      }
      ######################################################################
      if (measure == "MD") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "MD", "Mean Difference")
         } else {
            lab <- ifelse(short, lab, "Transformed Mean Difference")
         }
      }
      if (is.element(measure, c("SMD","SMDH","SMD1","SMD1H","PBIT","OR2D","OR2DN","OR2DL"))) {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "SMD", "Standardized Mean Difference")
         } else {
            lab <- ifelse(short, lab, "Transformed Standardized Mean Difference")
         }
      }
      if (measure == "ROM") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Log[RoM]", "Log Ratio of Means")
         } else {
            lab <- ifelse(short, lab, "Transformed Log Ratio of Means")
            funlist <- lapply(list(exp, transf.exp.int), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "Ratio of Means", "Ratio of Means (log scale)")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "Ratio of Means", "Ratio of Means")
         }
      }
      if (measure == "RPB") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Correlation", "Point-Biserial Correlation Coefficient")
         } else {
            lab <- ifelse(short, lab, "Transformed Point-Biserial Correlation Coefficient")
         }
      }
      if (measure == "ZPB") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, expression('Fisher\'s ' * z[phi]), "Fisher's z Transformed Point-Biserial Correlation Coefficient")
         } else {
            lab <- ifelse(short, lab, "Transformed Fisher's z Transformed Point-Biserial Correlation Coefficient")
            funlist <- lapply(list(transf.ztor, transf.ztor.int, tanh), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "Correlation", "Point-Biserial Correlation Coefficient")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "Correlation", "Point-Biserial Correlation Coefficient")
         }
      }
      if (measure == "VR") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Log[VR]", "Log Variability Ratio")
         } else {
            lab <- ifelse(short, lab, "Transformed Log Variability Ratio")
            funlist <- lapply(list(exp, transf.exp.int), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "VR", "Variability Ratio (log scale)")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "VR", "Variability Ratio")
         }
      }
      if (measure == "CVR") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Log[CVR]", "Log Coefficient of Variation Ratio")
         } else {
            lab <- ifelse(short, lab, "Transformed Log Coefficient of Variation Ratio")
            funlist <- lapply(list(exp, transf.exp.int), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "CVR", "Coefficient of Variation Ratio (log scale)")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "CVR", "Coefficient of Variation Ratio")
         }
      }
      ######################################################################
      if (is.element(measure, c("COR","UCOR","RTET","RBIS"))) {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Correlation", "Correlation Coefficient")
         } else {
            lab <- ifelse(short, lab, "Transformed Correlation Coefficient")
         }
      }
      if (is.element(measure, c("ZCOR","ZTET","ZBIS"))) {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, expression('Fisher\'s ' * z[r]), "Fisher's z Transformed Correlation Coefficient")
         } else {
            lab <- ifelse(short, lab, "Transformed Fisher's z Transformed Correlation Coefficient")
            funlist <- lapply(list(transf.ztor, transf.ztor.int, tanh), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "Correlation", "Correlation Coefficient")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "Correlation", "Correlation Coefficient")
         }
      }
      ######################################################################
      if (measure == "PCOR") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Correlation", "Partial Correlation Coefficient")
         } else {
            lab <- ifelse(short, lab, "Transformed Partial Correlation Coefficient")
         }
      }
      if (measure == "ZPCOR") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, expression('Fisher\'s ' * z[r]), "Fisher's z Transformed Partial Correlation Coefficient")
         } else {
            lab <- ifelse(short, lab, "Transformed Fisher's z Transformed Partial Correlation Coefficient")
            funlist <- lapply(list(transf.ztor, transf.ztor.int, tanh), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "Correlation", "Partial Correlation Coefficient")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "Correlation", "Partial Correlation Coefficient")
         }
      }
      if (measure == "SPCOR") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Correlation", "Semi-Partial Correlation Coefficient")
         } else {
            lab <- ifelse(short, lab, "Transformed Semi-Partial Correlation Coefficient")
         }
      }
      if (measure == "ZSPCOR") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, expression('Fisher\'s ' * z[r]), "Fisher's z Transformed Semi-Partial Correlation Coefficient")
         } else {
            lab <- ifelse(short, lab, "Transformed Fisher's z Transformed Semi-Partial Correlation Coefficient")
            funlist <- lapply(list(transf.ztor, transf.ztor.int, tanh), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "Correlation", "Semi-Partial Correlation Coefficient")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "Correlation", "Semi-Partial Correlation Coefficient")
         }
      }
      ######################################################################
      if (is.element(measure, c("R2","R2F"))) {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, expression(R^2), "Coefficient of Determination")
         } else {
            lab <- ifelse(short, lab, "Transformed Coefficient of Determination")
         }
      }
      if (is.element(measure, c("ZR2","ZR2F"))) {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, expression(z[R^2]), "z Transformed Coefficient of Determination")
         } else {
            lab <- ifelse(short, lab, "Transformed z Transformed Coefficient of Determination")
            funlist <- lapply(list(transf.ztor2), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, expression(R^2), "Coefficient of Determination")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, expression(R^2), "Coefficient of Determination")
         }
      }
      ######################################################################
      if (measure == "PR") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Proportion", "Proportion")
         } else {
            lab <- ifelse(short, lab, "Transformed Proportion")
         }
      }
      if (measure == "PLN") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Log[Pr]", "Log Proportion")
         } else {
            lab <- ifelse(short, lab, "Transformed Log Proportion")
            funlist <- lapply(list(exp, transf.exp.int), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "Proportion", "Proportion (log scale)")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "Proportion", "Proportion")
         }
      }
      if (measure == "PLO") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Log[Odds]", "Log Odds")
         } else {
            lab <- ifelse(short, lab, "Transformed Log Odds")
            funlist <- lapply(list(transf.ilogit, transf.ilogit.int, plogis), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "Proportion", "Proportion (logit scale)")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "Proportion", "Proportion")
            funlist <- lapply(list(exp, transf.exp.int), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "Odds", "Odds (log scale)")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "Odds", "Odds")
         }
      }
      if (measure == "PRZ") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, expression(Phi^{-1}*(p)), "Probit Transformed Proportion") # expression(z[p])
         } else {
            lab <- ifelse(short, lab, "Transformed Probit Transformed Proportion")
            funlist <- lapply(list(transf.iprobit, transf.iprobit.int, pnorm), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "Proportion", "Proportion (probit scale)")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "Proportion", "Proportion")
         }
      }
      if (measure == "PAS") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, expression(arcsin(sqrt(p))), "Arcsine Transformed Proportion")
         } else {
            lab <- ifelse(short, lab, "Transformed Arcsine Transformed Proportion")
            funlist <- lapply(list(transf.iarcsin, transf.iarcsin.int), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "Proportion", "Proportion (arcsine scale)")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "Proportion", "Proportion")
         }
      }
      if (measure == "PFT") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "PFT", "Double Arcsine Transformed Proportion")
         } else {
            lab <- ifelse(short, lab, "Transformed Double Arcsine Transformed Proportion")
            funlist <- lapply(list(transf.ipft.hm), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "Proportion", "Proportion")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "Proportion", "Proportion")
         }
      }
      ######################################################################
      if (measure == "IR") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Rate", "Incidence Rate")
         } else {
            lab <- ifelse(short, lab, "Transformed Incidence Rate")
         }
      }
      if (measure == "IRLN") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Log[IR]", "Log Incidence Rate")
         } else {
            lab <- ifelse(short, lab, "Transformed Log Incidence Rate")
            funlist <- lapply(list(exp, transf.exp.int), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "Rate", "Incidence Rate (log scale)")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "Rate", "Incidence Rate")
         }
      }
      if (measure == "IRS") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Sqrt[IR]", "Square Root Transformed Incidence Rate")
         } else {
            lab <- ifelse(short, lab, "Transformed Square Root Transformed Incidence Rate")
            funlist <- lapply(list(transf.isqrt, atransf.char), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "Rate", "Incidence Rate (square root scale)")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "Rate", "Incidence Rate")
         }
      }
      if (measure == "IRFT") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "IRFT", "Freeman-Tukey Transformed Incidence Rate")
         } else {
            lab <- ifelse(short, lab, "Transformed Freeman-Tukey Transformed Incidence Rate")
         }
      }
      ######################################################################
      if (measure == "MN") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Mean", "Mean")
         } else {
            lab <- ifelse(short, lab, "Transformed Mean")
         }
      }
      if (measure == "SMN") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Std. Mean", "Standardized Mean")
         } else {
            lab <- ifelse(short, lab, "Transformed Standardized Mean")
         }
      }
      if (measure == "MNLN") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Log[Mean]", "Log Mean")
         } else {
            lab <- ifelse(short, lab, "Transformed Log Mean")
            funlist <- lapply(list(exp, transf.exp.int), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "Mean", "Mean (log scale)")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "Mean", "Mean")
         }
      }
      if (measure == "SDLN") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Log[SD]", "Log Standard Deviation")
         } else {
            lab <- ifelse(short, lab, "Transformed Log Standard Deviation")
            funlist <- lapply(list(exp, transf.exp.int), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "SD", "Standard Deviation (log scale)")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "SD", "Standard Deviation")
         }
      }
      if (measure == "CVLN") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Log[CV]", "Log Coefficient of Variation")
         } else {
            lab <- ifelse(short, lab, "Transformed Log Coefficient of Variation")
            funlist <- lapply(list(exp, transf.exp.int), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "CV", "Coefficient of Variation (log scale)")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "CV", "Coefficient of Variation")
         }
      }
      ######################################################################
      if (measure == "MC") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Mean Change", "Mean Change")
         } else {
            lab <- ifelse(short, lab, "Transformed Mean Change")
         }
      }
      if (is.element(measure, c("SMCC","SMCR","SMCRH","SMCRP","SMCRPH"))) {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "SMC", "Standardized Mean Change")
         } else {
            lab <- ifelse(short, lab, "Transformed Standardized Mean Change")
         }
      }
      if (measure == "ROMC") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Log[RoM]", "Log Ratio of Means")
         } else {
            lab <- ifelse(short, lab, "Transformed Log Ratio of Means")
            funlist <- lapply(list(exp, transf.exp.int), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "Ratio of Means", "Ratio of Means (log scale)")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "Ratio of Means", "Ratio of Means")
         }
      }
      if (measure == "VRC") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Log[VR]", "Log Variability Ratio")
         } else {
            lab <- ifelse(short, lab, "Transformed Log Variability Ratio")
            funlist <- lapply(list(exp, transf.exp.int), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "VR", "Variability Ratio (log scale)")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "VR", "Variability Ratio")
         }
      }
      if (measure == "CVRC") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Log[CVR]", "Log Coefficient of Variation Ratio")
         } else {
            lab <- ifelse(short, lab, "Transformed Log Coefficient of Variation Ratio")
            funlist <- lapply(list(exp, transf.exp.int), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "CVR", "Coefficient of Variation Ratio (log scale)")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "CVR", "Coefficient of Variation Ratio")
         }
      }
      ######################################################################
      if (measure == "ARAW") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Alpha", "Cronbach's alpha")
         } else {
            lab <- ifelse(short, lab, "Transformed Cronbach's alpha")
         }
      }
      if (measure == "AHW") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, expression('Alpha'[HW]), "Transformed Cronbach's alpha")
         } else {
            lab <- ifelse(short, lab, "Transformed Cronbach's alpha")
            funlist <- lapply(list(transf.iahw, transf.iahw.int), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "Alpha", "Cronbach's alpha")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "Alpha", "Cronbach's alpha")
         }
      }
      if (measure == "ABT") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, expression('Alpha'[B]), "Transformed Cronbach's alpha")
         } else {
            lab <- ifelse(short, lab, "Transformed Cronbach's alpha")
            funlist <- lapply(list(transf.iabt, transf.iabt.int), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "Alpha", "Cronbach's alpha")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "Alpha", "Cronbach's alpha")
         }
      }
      ######################################################################
      if (measure == "REH") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Log[REH]", "Log Relative Excess Heterozygosity")
         } else {
            lab <- ifelse(short, lab, "Transformed Log Relative Excess Heterozygosity")
            funlist <- lapply(list(exp, transf.exp.int), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "REH", "Relative Excess Heterozygosity (log scale)")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "REH", "Relative Excess Heterozygosity")
         }
      }
      ######################################################################
      if (is.element(measure, c("CLES","CLESN","CLESCN"))) {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "CLES", "Common Language Effect Size")
         } else {
            lab <- ifelse(short, lab, "Transformed Common Language Effect Size")
         }
      }
      ######################################################################
      if (is.element(measure, c("AUC","AUCN","AUCCN"))) {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "AUC", "Area under the Curve")
         } else {
            lab <- ifelse(short, lab, "Transformed Area under the Curve")
         }
      }
      ######################################################################
      if (measure == "HR") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "Log[HR]", "Log Hazard Ratio")
         } else {
            lab <- ifelse(short, lab, "Transformed Log Hazard Ratio")
            funlist <- lapply(list(exp, transf.exp.int), deparse)
            if (any(sapply(funlist, identical, atransf.char)))
               lab <- ifelse(short, "HR", "Hazard Ratio (log scale)")
            if (any(sapply(funlist, identical, transf.char)))
               lab <- ifelse(short, "HR", "Hazard Ratio")
         }
      }
      if (measure == "HD") {
         if (identical(transf.char, "FALSE") && identical(atransf.char, "FALSE")) {
            lab <- ifelse(short, "HD", "Hazard Difference")
         } else {
            lab <- ifelse(short, lab, "Transformed Hazard Difference")
         }
      }
      ######################################################################

   }

   return(lab)

}

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

### stuff related to colored/styled output

.get.mstyle <- function() {

   crayonloaded <- "crayon" %in% .packages()

   styleopt <- getmfopt("style")

   if (is.logical(styleopt)) {

      if (isTRUE(styleopt)) {
         styleopt <- NULL
      } else {
         crayonloaded <- FALSE
      }
   }

   if (crayonloaded) {

      if (exists(".mstyle")) {
         .mstyle <- get(".mstyle")
      } else {
         .mstyle <- list()
      }

      if (!is.null(styleopt))
         .mstyle <- styleopt

      if (!is.list(.mstyle))
         .mstyle <- list(.mstyle)

      if (is.null(.mstyle$section)) {
         section <- crayon::bold
      } else {
         section <- .mstyle$section
      }
      if (is.null(.mstyle$header)) {
         header <- crayon::underline
      } else {
         header <- .mstyle$header
      }
      if (is.null(.mstyle$body1)) {
         body1 <- crayon::reset
      } else {
         body1 <- .mstyle$body1
      }
      if (is.null(.mstyle$body2)) {
         body2 <- crayon::reset
      } else {
         body2 <- .mstyle$body2
      }
      if (is.null(.mstyle$na)) {
         na <- crayon::reset
      } else {
         na <- .mstyle$na
      }
      if (is.null(.mstyle$text)) {
         text <- crayon::reset
      } else {
         text <- .mstyle$text
      }
      if (is.null(.mstyle$result)) {
         result <- crayon::reset
      } else {
         result <- .mstyle$result
      }
      if (is.null(.mstyle$stop)) {
         stop <- crayon::combine_styles(crayon::red, crayon::bold)
      } else {
         stop <- .mstyle$stop
      }
      if (is.null(.mstyle$warning)) {
         warning <- crayon::yellow
      } else {
         warning <- .mstyle$warning
      }
      if (is.null(.mstyle$message)) {
         message <- crayon::green
      } else {
         message <- .mstyle$message
      }
      if (is.null(.mstyle$verbose)) {
         verbose <- crayon::cyan
      } else {
         verbose <- .mstyle$verbose
      }
      if (is.null(.mstyle$legend)) {
         legend <- crayon::silver
         #legend <- crayon::make_style("gray90")
      } else {
         legend <- .mstyle$legend
      }

   } else {

      tmp <- function(...) paste0(...)

      section <- tmp
      header  <- tmp
      body1   <- tmp
      body2   <- tmp
      na      <- tmp
      text    <- tmp
      result  <- tmp
      stop    <- tmp
      warning <- tmp
      message <- tmp
      verbose <- tmp
      legend  <- tmp

   }

   return(list(section=section, header=header, body1=body1, body2=body2, na=na, text=text, result=result, stop=stop, warning=warning, message=message, verbose=verbose, legend=legend))

}

.print.output <- function(x, mstyle) {

   if (missing(mstyle)) {
      for (i in seq_along(x)) {
         cat(x[i], "\n")
      }
   } else {
      for (i in seq_along(x)) {
         cat(mstyle(x[i]), "\n")
      }
   }

}

.is.even <- function(x) x %% 2 == 0

.print.table <- function(x, mstyle) {

   is.header <- !grepl(" [-0-9]", x) & !grepl(" NA ", x, fixed=TRUE)
   #is.header <- !grepl("^\\s*[0-9]", x)
   has.header <- any(is.header)

   for (i in seq_along(x)) {
      if (is.header[i]) {
         #x[i] <- trimws(x[i], which="right")
         x[i] <- mstyle$header(x[i])
      } else {
         x[i] <- gsub("NA", mstyle$na("NA"), x[i], fixed=TRUE)
         if (.is.even(i-has.header)) {
            x[i] <- mstyle$body2(x[i])
         } else {
            x[i] <- mstyle$body1(x[i])
         }
      }
      cat(x[i], "\n")
   }

}

.print.vcovmat <- function(x, mstyle) {

   for (i in seq_along(x)) {
      x[i] <- gsub("NA", mstyle$na("NA"), x[i], fixed=TRUE)
      x[i] <- gsub(" .", mstyle$legend(" ."), x[i], fixed=TRUE)
      #if (i == 1) {
      #   x[i] <- mstyle$section(x[i])
      #} else {
      #   x[i] <- gsub("^( ?\\S+)", mstyle$section("\\1"), x[i])
      #}
      cat(x[i], "\n")
   }

}

#.set.mstyle.1 <- str2lang(".mstyle <- list(section=make_style(\"gray90\")$bold, header=make_style(\"skyblue1\")$bold$underline, body=make_style(\"skyblue2\"), text=make_style(\"slateblue3\"), result=make_style(\"slateblue1\"))")
#eval(metafor:::.set.mstyle.1)

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

.set.digits <- function(digits, dmiss) {

   res <- c(est=4, se=4, test=4, pval=4, ci=4, var=4, sevar=4, fit=4, het=4)

   if (exists(".digits")) {
      .digits <- get(".digits")
      if (is.null(names(.digits)) && length(.digits) == 1L) {
         # if .digits is a single unnamed scalar, set all digit values to that value
         res <- c(est=.digits, se=.digits, test=.digits, pval=.digits, ci=.digits, var=.digits, sevar=.digits, fit=.digits, het=.digits)
      } else if (any(names(.digits) != "") && any(names(.digits) == "")) {
         # if .digits has (at least) one unnamed element, use it to set all unnamed elements to that digits value
         pos <- pmatch(names(.digits), names(res))
         res[c(na.omit(pos))] <- .digits[!is.na(pos)]
         otherval <- .digits[names(.digits) == ""][1]
         res[(1:9)[-c(na.omit(pos))]] <- otherval
      } else {
         pos <- pmatch(names(.digits), names(res))
         res[c(na.omit(pos))] <- .digits[!is.na(pos)]
      }
   }

   if (!dmiss) {
      if (is.null(names(digits))) {
         res <- c(est=digits[[1]], se=digits[[1]], test=digits[[1]], pval=digits[[1]], ci=digits[[1]], var=digits[[1]], sevar=digits[[1]], fit=digits[[1]], het=digits[[1]])
      } else {
         pos <- pmatch(names(digits), names(res))
         res[c(na.omit(pos))] <- digits[!is.na(pos)]
      }
   }

   ### p-values are always given to at least 2 digits
   if (res["pval"] <= 1)
      res["pval"] <- 2

   res

}

.get.digits <- function(digits, xdigits, dmiss) {

   res <- xdigits

   if (exists(".digits")) {
      .digits <- get(".digits")
      pos <- pmatch(names(.digits), names(res))
      res[c(na.omit(pos))] <- .digits[!is.na(pos)]
   }

   if (!is.null(getmfopt("digits"))) {
      .digits <- getmfopt("digits")
      if (length(.digits) == 1L)
         .digits <- c(est=.digits[[1]], se=.digits[[1]], test=.digits[[1]], pval=.digits[[1]], ci=.digits[[1]], var=.digits[[1]], sevar=.digits[[1]], fit=.digits[[1]], het=.digits[[1]])
      pos <- pmatch(names(.digits), names(res))
      res[c(na.omit(pos))] <- .digits[!is.na(pos)]
   }

   if (!dmiss) {
      if (is.null(names(digits))) {
         res <- c(est=digits[[1]], se=digits[[1]], test=digits[[1]], pval=digits[[1]], ci=digits[[1]], var=digits[[1]], sevar=digits[[1]], fit=digits[[1]], het=digits[[1]])
      } else {
         pos <- pmatch(names(digits), names(res))
         res[c(na.omit(pos))] <- digits[!is.na(pos)]
      }
   }

   ### so we can still print objects created with older metafor versions (where xdigit is just an unnamed scalar)
   if (length(res) == 1L && is.null(names(res)))
      res <- c(est=res[[1]], se=res[[1]], test=res[[1]], pval=res[[1]], ci=res[[1]], var=res[[1]], sevar=res[[1]], fit=res[[1]], het=res[[1]])

   ### p-values are always given to at least 2 digits
   if (!is.null(res["pval"]) && res["pval"] <= 1)
      res["pval"] <- 2

   res

}

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

### check if x is logical and TRUE/FALSE (NAs and NULL always evaluate as FALSE)

#isTRUE <- function(x)
#   !is.null(x) && is.logical(x) && !is.na(x) && x
#
#isFALSE <- function(x)
#   !is.null(x) && is.logical(x) && !is.na(x) && !x

# not sure anymore why I implemented these; c(isTRUE(NULL), isTRUE(NA), isFALSE(NULL), isFALSE(NA)) are all FALSE

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

### shorten a character vector so that elements remain distinguishable

.shorten <- function(x, minlen) {

   y <- x

   x <- c(na.omit(x))

   n <- length(unique(x))

   maxlen <- max(nchar(unique(x)))

   for (l in seq_len(maxlen)) {
      tab <- table(x, substr(x, 1, l))
      if (nrow(tab) == n && ncol(tab) == n && sum(tab[upper.tri(tab)]) == 0 && sum(tab[lower.tri(tab)]) == 0)
         break
   }

   if (!missing(minlen) && l < minlen) {
      if (minlen > maxlen)
         minlen <- maxlen
      l <- minlen
   }

   return(substr(y, 1, l))

}

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

### simplified version of what mvtnorm::rmvnorm() does

.mvrnorm <- function(n, mu, Sigma) {

   p <- nrow(Sigma)
   eS <- eigen(Sigma, symmetric = TRUE)
   eval <- eS$values
   evec <- eS$vectors

   Y <- matrix(rnorm(p * n), nrow = n, byrow = TRUE) %*% t(evec %*% (t(evec) * sqrt(pmax(eval, 0))))
   Y <- sweep(Y, 2, mu, "+")

   return(Y)

}

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

### check subset argument (if logical, make sure it's of the right length and set NAs to FALSE; if
### numeric, remove NAs and 0's and check that values are not beyond k)

.chksubset <- function(x, k, stoponk0=TRUE) {

   if (is.null(x)) # if x is NULL, return x (i.e., NULL)
      return(x)

   mstyle <- .get.mstyle()

   argname <- deparse(substitute(x))

   if (length(x) == 0L)
      stop(mstyle$stop(paste0("Argument '", argname, "' is of length 0.")), call.=FALSE)

   if (is.character(x))
      stop(mstyle$stop(paste0("Argument '", argname, "' is not a logical or numeric vector.")), call.=FALSE)

   if (is.logical(x)) {
      if (length(x) != k)
         stop(mstyle$stop(paste0("Length of the '", argname, "' argument (", length(x), ") is not of length k = ", k, ".")), call.=FALSE)
      #x <- x[seq_len(k)]     # keep only elements 1:k from x
      if (anyNA(x))           # if x includes any NA elements
         x[is.na(x)] <- FALSE # set NA elements to FALSE
   }

   if (is.numeric(x)) {
      if (anyNA(x))             # if x includes any NA elements
         x <- x[!is.na(x)]      # remove them
      x <- as.integer(round(x))
      x <- x[x != 0L]           # also remove any 0's
      if (any(x > 0L) && any(x < 0L))
         stop(mstyle$stop(paste0("Cannot mix positive and negative values in '", argname, "' argument.")), call.=FALSE)
      if (all(x > 0L)) {
         if (any(x > k))
            stop(mstyle$stop(paste0("Argument '", argname, "' includes values larger than k = ", k, ".")), call.=FALSE)
         x <- is.element(seq_len(k), x)
      } else {
         if (any(x < -k))
            stop(mstyle$stop(paste0("Argument '", argname, "' includes values larger than k = ", k, ".")), call.=FALSE)
         x <- !is.element(seq_len(k), abs(x))
      }
   }

   if (stoponk0 && !any(x))
      stop(mstyle$stop(paste0("Stopped because k = 0 after subsetting.")), call.=FALSE)

   return(x)

}

### get subset function that works for matrices and data frames (selecting rows by default but rows
### and columns when col=TRUE) and vectors and also checks that x is of the same length as subset

.getsubset <- function(x, subset, col=FALSE, drop=FALSE) {

   if (is.null(x) || is.null(subset)) # if x or subset is NULL, return x
      return(x)

   mstyle <- .get.mstyle()

   xname <- deparse(substitute(x))

   k <- length(subset)

   if (.is.matrix(x) || is.data.frame(x)) {
      if (nrow(x) != k)
         stop(mstyle$stop(paste0("Element '", xname, "' is not of length ", k, ".")), call.=FALSE)
      if (col) {
         x <- x[subset,subset,drop=drop]
      } else {
         x <- x[subset,,drop=drop]
      }
   } else {
      if (length(x) != k)
         stop(mstyle$stop(paste0("Element '", xname, "' is not of length ", k, ".")), call.=FALSE)
      x <- x[subset]
   }

   return(x)

}

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

# function to compute a weighted mean (this one works a bit different than
# stats:::weighted.mean.default)

.wmean <- function (x, w, na.rm=FALSE) {
   if (na.rm) {
      i <- !(is.na(x) | is.na(w)) # only include x if x and w are not missing
      x <- x[i]
      w <- w[i]
   }
   sum(x*w) / sum(w)
}

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

.chkopt <- function(optimizer, optcontrol, ineq=FALSE) {

   mstyle <- .get.mstyle()

   ### set NLOPT_LN_BOBYQA as the default algorithm for the nloptr optimizer when ineq=FALSE
   ### and otherwise use NLOPT_LN_COBYLA to allow for nonlinear inequality constraints
   ### and by default use a relative convergence criterion of 1e-8 on the function value

   if (optimizer == "nloptr" && !is.element("algorithm", names(optcontrol))) {
      if (ineq) {
         optcontrol$algorithm <- "NLOPT_LN_COBYLA"
      } else {
         optcontrol$algorithm <- "NLOPT_LN_BOBYQA"
      }
   }

   if (optimizer == "nloptr" && !is.element("ftol_rel", names(optcontrol)))
      optcontrol$ftol_rel <- 1e-8

   ### for mads, set trace=FALSE and tol=1e-6 by default

   if (optimizer == "mads" && !is.element("trace", names(optcontrol)))
      optcontrol$trace <- FALSE

   if (optimizer == "mads" && !is.element("tol", names(optcontrol)))
      optcontrol$tol <- 1e-6

   ### for subplex, set reltol=1e-8 by default (the default in subplex() is .Machine$double.eps)

   if (optimizer == "subplex" && !is.element("reltol", names(optcontrol)))
      optcontrol$reltol <- 1e-8

   ### for BBoptim, set trace=FALSE by default

   if (optimizer == "BBoptim" && !is.element("trace", names(optcontrol)))
      optcontrol$trace <- FALSE

   ### for solnp, set trace=FALSE by default

   if (optimizer == "solnp" && !is.element("trace", names(optcontrol)))
      optcontrol$trace <- FALSE

   ### check that the required packages are installed

   if (is.element(optimizer, c("uobyqa","newuoa","bobyqa"))) {
      if (!requireNamespace("minqa", quietly=TRUE))
         stop(mstyle$stop("Please install the 'minqa' package to use this optimizer."), call.=FALSE)
   }

   if (is.element(optimizer, c("nloptr","ucminf","lbfgsb3c","subplex","optimParallel"))) {
      if (!requireNamespace(optimizer, quietly=TRUE))
         stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer.")), call.=FALSE)
   }

   if (is.element(optimizer, c("hjk","nmk","mads"))) {
      if (!requireNamespace("dfoptim", quietly=TRUE))
         stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer."), call.=FALSE)
   }

   if (optimizer == "BBoptim") {
      if (!requireNamespace("BB", quietly=TRUE))
         stop(mstyle$stop("Please install the 'BB' package to use this optimizer."), call.=FALSE)
   }

   if (optimizer == "solnp") {
      if (!requireNamespace("Rsolnp", quietly=TRUE))
         stop(mstyle$stop("Please install the 'Rsolnp' package to use this optimizer."), call.=FALSE)
   }

   if (is.element(optimizer, c("constrOptim.nl","auglag"))) {
      if (!requireNamespace("alabama", quietly=TRUE))
         stop(mstyle$stop("Please install the 'alabama' package to use this optimizer."), call.=FALSE)
   }

   if (is.element(optimizer, c("Rcgmin","Rvmmin"))) {
      if (!requireNamespace("optimx", quietly=TRUE))
         stop(mstyle$stop(paste0("Please install the 'optimx' package to use this optimizer.")), call.=FALSE)
   }

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

   if (is.element(optimizer, c("optim","constrOptim"))) {
      par.arg <- "par"
      ctrl.arg <- ", control=optcontrol"
   }

   if (optimizer == "nlminb") {
      par.arg <- "start"
      ctrl.arg <- ", control=optcontrol"
   }

   if (is.element(optimizer, c("uobyqa","newuoa","bobyqa"))) {
      par.arg <- "par"
      optimizer <- paste0("minqa::", optimizer) # need to use this since loading nloptr masks bobyqa() and newuoa() functions
      ctrl.arg <- ", control=optcontrol"
   }

   if (optimizer == "nloptr") {
      par.arg <- "x0"
      optimizer <- paste0("nloptr::nloptr") # need to use this due to requireNamespace()
      ctrl.arg <- ", opts=optcontrol"
   }

   if (optimizer == "nlm") {
      par.arg <- "p" # because of this, must use argument name pX for p (number of columns in X matrix)
      ctrl.arg <- paste(names(optcontrol), unlist(optcontrol), sep="=", collapse=", ")
      if (nchar(ctrl.arg) != 0L)
         ctrl.arg <- paste0(", ", ctrl.arg)
   }

   if (is.element(optimizer, c("hjk","nmk","mads"))) {
      par.arg <- "par"
      optimizer <- paste0("dfoptim::", optimizer) # need to use this so that the optimizers can be found
      ctrl.arg <- ", control=optcontrol"
   }

   if (is.element(optimizer, c("ucminf","lbfgsb3c","subplex"))) {
      par.arg <- "par"
      optimizer <- paste0(optimizer, "::", optimizer) # need to use this due to requireNamespace()
      ctrl.arg <- ", control=optcontrol"
   }

   if (optimizer == "BBoptim") {
      par.arg <- "par"
      optimizer <- "BB::BBoptim"
      ctrl.arg <- ", quiet=TRUE, control=optcontrol"
   }

   if (optimizer == "solnp") {
      par.arg <- "pars"
      optimizer <- "Rsolnp::solnp"
      ctrl.arg <- ", control=optcontrol"
   }

   if (is.element(optimizer, c("constrOptim.nl","auglag"))) {
      par.arg <- "par"
      optimizer <- paste0("alabama::", optimizer)
      if ("control.outer" %in% names(optcontrol)) {
         # can specify 'control.outer' to be passed to constrOptim.nl(), but when using
         # the 'method' argument, must escape " or use ' for this to work; for example:
         # control=list(optimizer="constrOptim.nl", control.outer=list(method="'Nelder-Mead'"))
         control.outer <- paste0("control.outer=list(", paste(names(optcontrol$control.outer), unlist(optcontrol$control.outer), sep="=", collapse=", "), ")")
         ctrl.arg <- paste0(", control.optim=optcontrol, ", control.outer)
         optcontrol$control.outer <- NULL
      } else {
         ctrl.arg <- ", control.optim=optcontrol, control.outer=list(trace=FALSE)"
      }
   }

   if (optimizer == "Rcgmin") {
      par.arg <- "par"
      optimizer <- "optimx::Rcgmin"
      ctrl.arg <- ", gr='grnd', control=optcontrol"
      #ctrl.arg <- ", control=optcontrol"
   }

   if (optimizer == "Rvmmin") {
      par.arg <- "par"
      optimizer <- "optimx::Rvmmin"
      ctrl.arg <- ", gr='grnd', control=optcontrol"
      #ctrl.arg <- ", control=optcontrol"
   }

   if (optimizer == "optimParallel") {
      par.arg <- "par"
      optimizer <- "optimParallel::optimParallel"
      ctrl.arg <- ", control=optcontrol, parallel=parallel"
   }

   return(list(optimizer=optimizer, optcontrol=optcontrol, par.arg=par.arg, ctrl.arg=ctrl.arg))

}

.chkconv <- function(optimizer, opt.res, optcontrol, fun, verbose, paronly=TRUE) {

   mstyle <- .get.mstyle()

   if (optimizer == "optimParallel::optimParallel" && verbose) {
      tmp <- capture.output(print(opt.res$loginfo))
      .print.output(tmp, mstyle$verbose)
   }

   ### convergence checks

   if (inherits(opt.res, "try-error"))
      stop(mstyle$stop(paste0("Error during the optimization. Use verbose=TRUE and see\n       help(", fun, ") for more details on the optimization routines.")), call.=FALSE)

   if (optimizer == "lbfgsb3c::lbfgsb3c" && is.null(opt.res$convergence)) # special provision for lbfgsb3c in case 'convergence' is missing
      opt.res$convergence <- -99

   if (is.element(optimizer, c("optim","constrOptim","nlminb","dfoptim::hjk","dfoptim::nmk","lbfgsb3c::lbfgsb3c","subplex::subplex","BB::BBoptim","Rsolnp::solnp","alabama::constrOptim.nl","alabama::auglag","optimx::Rcgmin","optimx:Rvmmin","optimParallel::optimParallel")) && opt.res$convergence != 0)
      stop(mstyle$stop(paste0("Optimizer (", optimizer, ") did not achieve convergence (convergence = ", opt.res$convergence, ").")), call.=FALSE)

   if (is.element(optimizer, c("dfoptim::mads")) && opt.res$convergence > optcontrol$tol)
      stop(mstyle$stop(paste0("Optimizer (", optimizer, ") did not achieve convergence (convergence = ", opt.res$convergence, ").")), call.=FALSE)

   if (is.element(optimizer, c("minqa::uobyqa","minqa::newuoa","minqa::bobyqa")) && opt.res$ierr != 0)
      stop(mstyle$stop(paste0("Optimizer (", optimizer, ") did not achieve convergence (ierr = ", opt.res$ierr, ").")), call.=FALSE)

   if (optimizer=="nloptr::nloptr" && !(opt.res$status >= 1 && opt.res$status <= 4))
      stop(mstyle$stop(paste0("Optimizer (", optimizer, ") did not achieve convergence (status = ", opt.res$status, ").")), call.=FALSE)

   if (optimizer=="ucminf::ucminf" && !(opt.res$convergence == 1 || opt.res$convergence == 2))
      stop(mstyle$stop(paste0("Optimizer (", optimizer, ") did not achieve convergence (convergence = ", opt.res$convergence, ").")), call.=FALSE)

   if (verbose > 2) {
      cat("\n")
      tmp <- capture.output(print(opt.res))
      .print.output(tmp, mstyle$verbose)
   }

   ### copy estimated values to 'par'

   if (optimizer=="nloptr::nloptr")
      opt.res$par <- opt.res$solution
   if (optimizer=="nlm")
      opt.res$par <- opt.res$estimate
   if (optimizer=="Rsolnp::solnp")
      opt.res$par <- opt.res$pars

   ### copy function value to 'value'

   if (is.element(optimizer, c("nlminb", "nloptr::nloptr")))
      opt.res$value <- opt.res$objective
   if (is.element(optimizer, c("minqa::uobyqa","minqa::newuoa","minqa::bobyqa")))
      opt.res$value <- opt.res$fval
   if (optimizer=="nlm")
      opt.res$value <- opt.res$minimum
   if (optimizer=="Rsolnp::solnp")
      opt.res$value <- tail(opt.res$values, 1)

   if (paronly) {
      return(opt.res$par)
   } else {
      return(opt.res)
   }

}

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

.coltail <- function(h, val, tail="upper", mult=1, col, border, freq, ...) {

   h$counts  <- h$counts  * mult
   h$density <- h$density * mult

   if (tail == "lower") {

      above <- which(h$breaks > val)
      if (length(above) > 0L) {
         pos <- above[1]
         h$breaks[pos] <- val
      }
      sel <- h$breaks <= val
      if (sum(sel) >= 2L) {
         h$breaks  <- h$breaks[sel]
         h$counts  <- h$counts[sel[-1]]
         h$density <- h$density[sel[-1]]
         h$mids    <- h$mids[sel[-1]]
         lines(h, col=col, border=border, freq=freq, ...)
      }

   } else {

      below <- which(h$breaks < val)
      if (length(below) > 0L) {
         pos <- below[length(below)]
         h$breaks[pos] <- val
      }
      sel <- h$breaks >= val
      if (sum(sel) >= 2L) {
         len <- length(below)
         h$breaks  <- h$breaks[sel]
         h$counts  <- h$counts[sel[-len]]
         h$density <- h$density[sel[-len]]
         h$mids    <- h$mids[sel[-len]]
         lines(h, col=col, border=border, freq=freq, ...)
      }

   }

}

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

# theme="default" - uses the default par() of the plotting device
# theme="light"   - forces par(fg="black",  bg="white", ...)
# theme="dark"    - forces par(fg="gray95", bg="gray10", ...)
# theme="auto"    - in RStudio, picks fg/bg based on theme that is set (outside RStudio, same as "default")
# theme="custom"  - uses getmfopt("fg") and getmfopt("bg")

.start.plot <- function(x=TRUE) {

   if (!x)
      return()

   themeopt <- getmfopt("theme", default="default")[[1]]
   themeopt <- sub("2", "", themeopt, fixed=TRUE)

   if (!is.element(themeopt, c("default", "light", "dark", "auto", "custom")))
      themeopt <- "default"

   if (exists(".darkplots"))
      themeopt <- "dark"

   if (isTRUE(themeopt == "light")) {
      fg <- "black"
      bg <- "white"
      #fg <- "gray5"
      #bg <- "gray95"
   }

   if (isTRUE(themeopt == "dark")) {
      fg <- "gray95"
      bg <- "gray10"
   }

   if (isTRUE(themeopt == "auto")) {

      rsapi <- try(rstudioapi::isAvailable(), silent=TRUE)

      if (inherits(rsapi, "try-error") || isFALSE(rsapi)) {
         themeopt <- "default"
      } else {
         fg <- .rsapicol2rgb(rstudioapi::getThemeInfo()$foreground)
         bg <- .rsapicol2rgb(rstudioapi::getThemeInfo()$background)
      }

   }

   if (isTRUE(themeopt == "custom")) {

      fgopt <- getmfopt("fg")
      bgopt <- getmfopt("bg")

      if (is.null(fgopt) || is.null(bgopt)) {
         themeopt <- "default"
      } else {
         fg <- fgopt
         bg <- bgopt
      }

   }

   if (themeopt != "default" && isFALSE(par("new")))
      par(fg=fg, bg=bg, col=fg, col.axis=fg, col.lab=fg, col.main=fg, col.sub=fg)

   invisible()

}

# convert the string "rgb(val1, val2, val3)" into rgb(val1, val2, val3, maxColorValue=255)

.rsapicol2rgb <- function(col) {

   col  <- strsplit(col, ",")[[1]]
   col  <- trimws(col)
   col1 <- as.numeric(sub("rgb(", "", col[1], fixed=TRUE))
   col2 <- as.numeric(col[2])
   col3 <- as.numeric(trimws(sub(")", "", col[3], fixed=TRUE)))
   col  <- rgb(col1, col2, col3, maxColorValue=255)
   return(col)

}

.is.dark <- function() {

   rgb <- col2rgb(par("bg"))
   res <- sum(rgb) <= 384 # note: sum(col2rgb(rgb(0.5,0.5,0.5))) == 384
   return(res)

}

.coladj <- function(col, dark, light) {

   themeopt <- getmfopt("theme", default="default")

   if (length(col) == 2L && substr(themeopt, nchar(themeopt), nchar(themeopt)) == "2") {
      pos <- 2
      if (length(dark) == 1L)
         dark <- c(dark, ifelse(dark > 0, dark-1, dark+1))
      if (length(light) == 1L)
         light <- c(light, ifelse(light > 0, light-1, light+1))
   } else {
      pos <- 1
   }

   col <- c(col2rgb(col[[pos]]))

   if (.is.dark()) {
      col <- col + round(dark*255)[[pos]]
   } else {
      col <- col + round(light*255)[[pos]]
   }

   col[col < 0] <- 0
   col[col > 255] <- 255

   col <- rgb(col[1], col[2], col[3], maxColorValue=255)
   return(col)

}

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

.chkpd <- function(x, tol=.Machine$double.eps, corr=FALSE, nearpd=FALSE) {

   if (any(eigen(x, symmetric=TRUE, only.values=TRUE)$values <= tol)) {
      ispd <- FALSE
      if (nearpd) {
         tmp <- nearPD(x, corr=corr)
         x <- as.matrix(tmp$mat)
         if (tmp$converged)
            ispd <- TRUE
      }
   } else {
      ispd <- TRUE
   }

   if (nearpd) {
      return(list(ispd=ispd, x=x))
   } else {
      return(ispd)
   }

}

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

.trapezoid <- function(x,y) sum(diff(x)*(y[-1]+y[-length(y)]))/2

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