#' @name logicals
#' @rdname logicals
#'
#' @title Several logical range comparison helpers
#'
#' @param e1 A vector to be evaluated.
#' @param e2 The right hand side value for the operator. For range operators,
#'   use a length-two vector without missing values. For \code{\%!in\%}, use a
#'   non-empty lookup vector. For \code{\%c\%}, use one non-empty character
#'   string containing chained comparisons joined by \code{&} or \code{|}. For
#'   \code{\%e\%}, use one non-empty character string containing interval
#'   notation joined by \code{&} or \code{|}. For \code{\%grepl\%}, use one
#'   non-empty regular expression.
#'
#' @return A logical vector of the same length as \code{e1}.
NULL

.check_range_e2 <- function(e2, operator) {
  if (!identical(length(e2), 2L)) {
    stop(sprintf("%s requires e2 to have length 2.", operator), call. = FALSE)
  }
  if (anyNA(e2)) {
    stop(sprintf("%s requires e2 to have no missing values.", operator), call. = FALSE)
  }
}

.check_non_empty_e2 <- function(e2, operator) {
  if (!length(e2)) {
    stop(sprintf("%s requires e2 to contain at least one value.", operator), call. = FALSE)
  }
}

.check_scalar_character_e2 <- function(e2, operator, description) {
  if (!is.character(e2)) {
    stop(sprintf("%s requires e2 to be a character string.", operator), call. = FALSE)
  }
  if (!identical(length(e2), 1L)) {
    stop(sprintf("%s requires e2 to be exactly one character string.", operator), call. = FALSE)
  }
  if (is.na(e2) || !nzchar(trimws(e2))) {
    stop(sprintf("%s requires e2 to be a non-empty %s.", operator, description), call. = FALSE)
  }
}

.check_connectors <- function(e2, operator) {
  compact <- gsub("\\s", "", e2)
  if (grepl("^[|&]|[|&]$", compact)) {
    stop(sprintf("%s requires e2 not to start or end with '&' or '|'.", operator), call. = FALSE)
  }
  if (grepl("[|&]{2,}", compact)) {
    stop(sprintf("%s requires e2 not to contain adjacent '&' or '|' operators.", operator), call. = FALSE)
  }
}

.check_chain_e2 <- function(e2, operator) {
  .check_scalar_character_e2(e2, operator, "chain expression")
  .check_connectors(e2, operator)
}

.check_set_e2 <- function(e2, operator) {
  .check_scalar_character_e2(e2, operator, "set notation expression")
  .check_connectors(e2, operator)
}

.check_pattern_e2 <- function(e2, operator) {
  .check_scalar_character_e2(e2, operator, "regular expression")
}

#' @rdname logicals
#' @export
#' @examples
#'
#' 1:5 %gele% c(2, 4)
#' 1:5 %gele% c(4, 2) # order does not matter uses min / max
`%gele%` <- function(e1, e2) {
  .check_range_e2(e2, "%gele%")

  e1 >= min(e2) & e1 <= max(e2)
}

#' @rdname logicals
#' @export
#' @examples
#'
#' 1:5 %gel% c(2, 4)
#' 1:5 %gel% c(4, 2) # order does not matter uses min / max
`%gel%` <- function(e1, e2) {
  .check_range_e2(e2, "%gel%")

  e1 >= min(e2) & e1 < max(e2)
}

#' @rdname logicals
#' @export
#' @examples
#'
#' 1:5 %gle% c(2, 4)
#' 1:5 %gle% c(4, 2) # order does not matter uses min / max
`%gle%` <- function(e1, e2) {
  .check_range_e2(e2, "%gle%")

  e1 > min(e2) & e1 <= max(e2)
}

#' @rdname logicals
#' @export
#' @examples
#'
#' 1:5 %gl% c(2, 4)
#' 1:5 %gl% c(4, 2) # order does not matter uses min / max
`%gl%` <- function(e1, e2) {
  .check_range_e2(e2, "%gl%")

  e1 > min(e2) & e1 < max(e2)
}

#' @rdname logicals
#' @export
#' @examples
#'
#' 1:5 %g% c(2)
`%g%` <- function(e1, e2) {e1 > e2}

#' @rdname logicals
#' @export
#' @examples
#'
#' 1:5 %ge% c(2)
`%ge%` <- function(e1, e2) {e1 >= e2}

#' @rdname logicals
#' @export
#' @examples
#'
#' 1:5 %l% c(2)
`%l%` <- function(e1, e2) {e1 < e2}

#' @rdname logicals
#' @export
#' @examples
#'
#' 1:5 %le% c(2)
`%le%` <- function(e1, e2) {e1 <= e2}

#' @rdname logicals
#' @export
#' @examples
#'
#' 1:5 %!in% c(2, 99)
#' c("jack", "jill", "john", "jane") %!in% c("jill", "jane", "bill")
`%!in%` <- function(e1, e2) {
  .check_non_empty_e2(e2, "%!in%")
  !(e1 %in% e2)
}

#' @rdname logicals
#' @export
`%nin%` <- `%!in%`

#' @rdname logicals
#' @export
## compare two strings where flips around
## a colon do not matter, used for interactions
`%flipIn%` <- function(e1, e2) {
  .flipMatch <- function(e1, e2) {
    e1 <- unlist(strsplit(e1, ":"))
    e2 <- unlist(strsplit(e2, ":"))
    all(e1 %in% e2) && all(e2 %in% e1)
  }
  sapply(e1, function(v) {
    .flipMatch(v, e2)
  })
}

#' Chain Operator
#'
#' This operator allows operators on the right hand side to be
#' chained together. The intended use case is when you have a
#' single object on which you want to perform several operations.
#' For example, testing whether a variable is between 1 and 5 or
#' equals special number 9, which might be used to indicate that
#' someone responded to a question (i.e., its not missing per se)
#' but that they preferred not to answer or did not know the answer.
#'
#' `%c%` has special facilities to handle the following:
#' `is.na`, `!is.na`, `is.nan`, and `!is.nan`. These do not need
#' any values supplied but they work as expected to add those logical
#' assessments into the chain of operators.
#'
#' @param e1 The values to be operated on, on the left hand side
#' @param e2 One non-empty character string (it MUST be quoted) containing
#' the operators and values to apply to `e1`. Operators can be chained together
#' using either `|` or `&`; these connectors must appear between complete
#' conditions, not at the start or end of the string, and cannot be doubled.
#' Parentheses are also supported and work as expected. See examples for more
#' information on how this function is used.
#' @keywords operators logical
#' @return a logical vector
#' @export
#' @examples
#'
#' ## define a variable
#' sample_data <- c(1, 3, 9, 5, NA, -9)
#'
#' ## suppose that we expect that values should fall in [1, 10]
#' ## unless they are special character, -9 used for unknown / refused
#' sample_data %c% "( >= 1 & <= 10 ) | == -9"
#'
#' ## we might expect some missing values and be OK as long as
#' ## above conditions are met or values are missing
#' sample_data %c% "( >= 1 & <= 10 ) | == -9 | is.na"
#'
#' ## equally we might be expecting NO missing values
#' ## and want missing values to come up as FALSE
#' sample_data %c% "(( >= 1 & <= 10 ) | == -9) & !is.na"
#'
#' c(1, 3, 9, 5, NA, -9) %c% "is.na & (( >= 1 & <= 10 ) | == -9)"
#'
#' ## clean up
#' rm(sample_data)
`%c%`  <- function(e1, e2) {
  .check_chain_e2(e2, "%c%")

  ## copy the call, used to find the
  ## symbol for e1
  call <- match.call()
  x <- as.character(call[2])

  ## replace | and & symbols temporarily
  e2 <- gsub(
    "\\|\\s*(\\(*\\s*is.na|\\(*\\s*!is.na|\\(*\\s*is.nan|\\(*\\s*!is.nan)",
    sprintf("__TEMP__OR__1 \\1(%s)", x),
    e2)

  e2 <- gsub(
    "&\\s*(\\(*\\s*is.na|\\(*\\s*!is.na|\\(*\\s*is.nan|\\(*\\s*!is.nan)",
    sprintf("__TEMP__AND__1 \\1(%s)", x),
    e2)

  e2 <- gsub("(\\||\\|\\s*\\(+|&|&\\s*\\(+)", sprintf("\\1 %s", x), e2)

  ## replace temp symbols back to R operators
  e2 <- gsub("__TEMP__OR__1",  "|", e2)
  e2 <- gsub("__TEMP__AND__1", "&", e2)

  ## deal with is.na or is.nan if it STARTS the operators
  if (grepl("^\\s*(\\(*\\s*is.na|\\(*\\s*!is.na|\\(*\\s*is.nan|\\(*\\s*!is.nan)", e2)) {
    e2 <- gsub(
      "^\\s*(\\(*\\s*is.na|\\(*\\s*!is.na|\\(*\\s*is.nan|\\(*\\s*!is.nan)",
      sprintf("\\1(%s)", x),
      e2)
  } else {
    e2 <- gsub("^(\\s*\\(*)", sprintf("\\1 %s", x), e2)
  }

  ## find the parent frame and evalaute there
  e <- parent.frame()
  eval(parse(text = e2), envir = e)
}

#' Process Sets
#'
#' This is an internal function and not intended to be used directly.
#' It processes small sets.
#'
#' @param x A character string
#' @param envir An environment in which to evaluate values
#' @return A data frame with the processed set
#' @keywords internal
#' @examples
#'
#' ## ## below is an example that should generate an (informative) error
#' ## extraoperators:::.set1("(-Inf,x)", envir = environment())
#'
#' z <- max(mtcars$mpg)
#' extraoperators:::.set1("(-Inf,z)", envir = environment())
#'
#' extraoperators:::.set1("(-Inf,30)", envir = environment())
#'
#' ## clean up
#' rm(z)
.set1 <- function(x, envir) {
  ## for connecting operators
  if (identical(length(x), 1L) && identical(nchar(x), 1L)) { 
    data.frame(Op1 = "",Val1 = "",
               Con1 = x,
               Op2 = "", Val2 = "",
               stringsAsFactors = FALSE)
  } else { ## for a set
    x <- unlist(strsplit(x, ","))
    if (isFALSE(grepl("\\(|\\[", x[1]) & grepl("\\)|\\]", x[2]))) {
      stop(paste(
        "Malformed inner set, requires both an open",
        "(i.e., '(' or '[') and a close (i.e., ')' or ']')",
        "brackets."))
    }
    if (missing(envir)) {
      envir <- parent.frame()
    }
    op1 <- ifelse(grepl("\\(", x[1]), ">", ">=")
    x[1] <- gsub("\\(|\\[", "", x[1])
    op2 <- ifelse(grepl("\\)", x[2]), "<", "<=")
    x[2] <- gsub("\\)|\\]", "", x[2])
    val1 <- tryCatch(
      as.character(eval(parse(text = x[1]), envir = envir)),
      error = function(e) "__AN-ERROR__")
    if (identical(val1, "__AN-ERROR__")) {
      stop(sprintf("Error, object '%s' not found", x[1]))
    }
    val2 <- tryCatch(
      as.character(eval(parse(text = x[2]), envir = envir)),
      error = function(e) "__AN-ERROR__")
    if (identical(val2, "__AN-ERROR__")) {
      stop(sprintf("Error, object '%s' not found", x[2]))
    }
    if (!identical(length(val1), 1L)) {
      stop(sprintf("evaluated text must be length 1, '%s' evaluates to length %d",
                   x[1], length(val1)))
    }
    if (!identical(length(val2), 1L)) {
      stop(sprintf("evaluated text must be length 1, '%s' evaluates to length %d",
                   x[2], length(val2)))
    }
    data.frame(Op1 = op1, Val1 = val1,
               Con1 = "&",
               Op2 = op2, Val2 = val2,
               stringsAsFactors = FALSE)
  }
}


#' Element In Set Operator
#'
#' This operator allows use of set notation style definitions
#'
#' @param e1 The values to be operated on, on the left hand side
#' @param e2 One non-empty character string containing set notation style
#' ranges on the real number line. Separate sets with the \dQuote{&} or
#' \dQuote{|} operator for AND or OR. Connectors must appear between complete
#' sets, not at the start or end of the string, and cannot be doubled.
#' @keywords operators logical
#' @return a logical vector
#' @export
#' @examples
#'
#' c(-1, 0, 1, 9, 10, 16, 17, 20) %e% "(-Inf, 0) | [1, 9) | [10, 16] | (17, Inf]"
#' table(mtcars$mpg %e% "(0, 15.5) | [22.8, 40)")
#' table(mtcars$mpg %e% "(0, 15) | [16, 18] | [30, 50)")
#' c(-1, 0, 1) %e% "(-Inf, Inf) & [0, 0] | [1, 1]"
#'
#' z <- max(mtcars$mpg)
#' table(mtcars$mpg %e% "(-Inf, z)")
#'
#' ## clean up
#' rm(z)
`%e%` <- function(e1, e2) {
  .check_set_e2(e2, "%e%")

  call <- match.call()
  x <- as.character(call[2])

  envir <- parent.frame()

  e2 <- gsub("\\s", "", e2)
  e2 <- unlist(strsplit(e2, split = "&"))
  if (length(e2) > 1) {
    e2 <- c(unlist(lapply(e2[-length(e2)], c, "&")), e2[length(e2)])
  }
  e2 <- unlist(lapply(e2, function(x) {
    if (grepl("\\|", x)) {
      x <- unlist(strsplit(x, split = "\\|"))
      if (length(x) > 1) {
        x <- c(unlist(lapply(x[-length(x)], c, "|")), x[length(x)])
      }
    }
    return(x)
  }))

  e2 <- do.call(rbind, lapply(e2, .set1, envir = envir))
  e2$ConOnly <- nzchar(e2$Op1)

  test <- e2[e2$ConOnly == TRUE, , drop = FALSE]
  if (any(is.na(test$Val1) | is.nan(test$Val1) | is.na(test$Val2) | is.nan(test$Val2))) {
    stop("Values in sets cannot be missing")
  }
  if (!isTRUE(all(as.numeric(test$Val1) <= as.numeric(test$Val2)))) {
    stop("Values in sets must be ordered from least to greatest")
  }

  text <- paste(ifelse(nzchar(e2$Op1),
                       paste("(", x, e2$Op1, e2$Val1, e2$Con1, x, e2$Op2, e2$Val2, ")"),
                       e2$Con1), collapse = " ")

  eval(parse(text = text), envir = envir)
}

#' @rdname logicals
#' @export
#' @examples
#'
#' c("jack", "jill", "john", "jane", "sill", "ajay") %grepl% "ja"
#' c("jack", "jill", "john", "jane", "sill", "ajay") %grepl% "^ja"
`%grepl%` <- function(e1, e2) {
  .check_pattern_e2(e2, "%grepl%")
  grepl(pattern = e2, x = e1)
}

#' @rdname logicals
#' @export
#' @examples
#'
#' c("jack", "jill", "john", "jane", "sill", "ajay") %!grepl% "ja"
#' c("jack", "jill", "john", "jane", "sill", "ajay") %!grepl% "^ja"
`%!grepl%` <- function(e1, e2) {
  .check_pattern_e2(e2, "%!grepl%")
  !grepl(pattern = e2, x = e1)
}
