#' @title Check input
#'
#' @description A set of convenience functions for checking
#' objects/arguments to a function passed by a user.
#'
#' @param x object to be checked
#' @param name name of the object that will be print in the error
#' message.
#' @param check_length length of the object to be checked. Defaults to
#' \code{1}. Set to \code{0} in order to not check object length.
#' @param allow_NULL whether the object can be \code{NULL}.
#' If so, no checks are executed.
#' @param allow_NA whether the object can contain \code{NA} or \code{NaN}
#' values.
#' @param allow_values names of values allowed in a character vector.
#' Defaults to \code{NULL} (do not check).
#' @param check_names names of entries allowed in a list. Defaults to
#' \code{NULL} (do not check).
#' @param all_objects whether all entries in \code{check_names} must be
#' present. Defaults to \code{FALSE}.
#' @param allow_other whether additional entries then the specified in
#' \code{check_names} might be present
#' @param lower lower bound of allowed values.
#' Defaults to \code{-Inf} (do not check).
#' @param upper upper bound of allowed values.
#' Defaults to \code{Inf} (do not check).
#' @param allow_bound whether the values at the boundary are allowed.
#' Defaults to \code{TRUE}.
#' @param call string to be placed as a prefix to the error call.
#'
#' @examples
#' # check whether the object is logical
#' check_bool(TRUE, name = "input")
#'
#' # will throw an error on any other type
#' \dontrun{
#'   check_bool("TRUE", name = "input")
#' }
#'
#' @return returns \code{NULL}, called for the input check.
#'
#' @name check_input
#' @export check_bool
#' @export check_char
#' @export check_int
#' @export check_real
#' @export check_list

#' @rdname check_input
check_bool   <- function(x, name = deparse(substitute(x)), check_length = 1, allow_NULL = FALSE, allow_NA = TRUE, call = ""){

  if(is.null(x) || length(x) == 0){
    if(allow_NULL){
      return()
    }else{
      stop(paste0(call, "The '", name, "' argument cannot be NULL."), call. = FALSE)
    }
  }

  if(!is.logical(x) | !is.vector(x))
    stop(paste0(call, "The '", name, "' argument must be a logical vector."), call. = FALSE)

  if(check_length != 0  && length(x) != check_length)
    stop(paste0(call, "The '", name, "' argument must have length '", check_length, "'."), call. = FALSE)

  if(!allow_NA && anyNA(x))
    stop(paste0(call, "The '", name, "' argument cannot contain NA/NaN values."), call. = FALSE)

  return()
}

#' @rdname check_input
check_char   <- function(x, name = deparse(substitute(x)), check_length = 1, allow_values = NULL, allow_NULL = FALSE, allow_NA = TRUE, call = ""){

  if(is.null(x) || length(x) == 0){
    if(allow_NULL){
      return()
    }else{
      stop(paste0(call, "The '", name, "' argument cannot be NULL."), call. = FALSE)
    }
  }

  if(!is.character(x) | !is.vector(x))
    stop(paste0(call, "The '", name, "' argument must be a character vector."), call. = FALSE)

  if(check_length != 0 && length(x) != check_length)
    stop(paste0(call, "The '", name, "' argument must have length '", check_length, "'."), call. = FALSE)

  if(!allow_NA && anyNA(x))
    stop(paste0(call, "The '", name, "' argument cannot contain NA/NaN values."), call. = FALSE)

  if(!is.null(allow_values)){
    unrecognized <- !is.na(x) & !x %in% allow_values
    if(any(unrecognized))
      stop(paste0(call, "The '", paste0(x[unrecognized], collapse = "', '") ,"' values are not recognized by the '", name, "' argument."), call. = FALSE)
  }

  return()
}

#' @rdname check_input
check_real   <- function(x, name = deparse(substitute(x)), lower = -Inf, upper = Inf, allow_bound = TRUE, check_length = 1, allow_NULL = FALSE, allow_NA = TRUE, call = ""){

  if(is.null(x) || length(x) == 0){
    if(allow_NULL){
      return()
    }else{
      stop(paste0(call, "The '", name, "' argument cannot be NULL."), call. = FALSE)
    }
  }

  if(!allow_NA && anyNA(x))
    stop(paste0(call, "The '", name, "' argument cannot contain NA/NaN values."), call. = FALSE)

  if(check_length != 0 && length(x) != check_length)
    stop(paste0(call, "The '", name, "' argument must have length '", check_length, "'."), call. = FALSE)

  if(!is.numeric(x) | !is.vector(x))
    stop(paste0(call, "The '", name, "' argument must be a numeric vector."), call. = FALSE)

  x_no_na <- x[!is.na(x)]

  if(!is.infinite(lower)){
    if(!allow_bound){
      if(any(x_no_na <= lower))
        stop(paste0(call, "The '", name ,"' must be higher than ", lower,"."), call. = FALSE)
    }else{
      if(any(x_no_na < lower))
        stop(paste0(call, "The '", name ,"' must be equal or higher than ", lower,"."), call. = FALSE)
    }
  }

  if(!is.infinite(upper)){
    if(!allow_bound){
      if(any(x_no_na >= upper))
        stop(paste0(call, "The '", name ,"' must be lower than ", upper,"."), call. = FALSE)
    }else{
      if(any(x_no_na > upper))
        stop(paste0(call, "The '", name ,"' must be equal or lower than ", upper,"."), call. = FALSE)
    }
  }

  return()
}

#' @rdname check_input
check_int    <- function(x, name = deparse(substitute(x)), lower = -Inf, upper = Inf, allow_bound = TRUE, check_length = 1, allow_NULL = FALSE, allow_NA = TRUE, call = ""){

  if(is.null(x) || length(x) == 0){
    if(allow_NULL){
      return()
    }else{
      stop(paste0(call, "The '", name, "' argument cannot be NULL."), call. = FALSE)
    }
  }

  check_real(x, name = name, lower = lower, upper = upper, allow_bound = allow_bound, check_length = check_length, allow_NULL = allow_NULL, allow_NA = allow_NA, call = call)

  if(!all(.is.wholenumber(x, na.rm = TRUE)))
    stop(paste0(call, "The '", name ,"' argument must be an integer vector."), call. = FALSE)

  return()
}

#' @rdname check_input
check_list   <- function(x, name = deparse(substitute(x)), check_length = 0, check_names = NULL, all_objects = FALSE, allow_other = FALSE, allow_NULL = FALSE, call = ""){

  if(is.null(x) || length(x) == 0){
    if(allow_NULL){
      return()
    }else{
      stop(paste0(call, "The '", name, "' argument cannot be NULL."), call. = FALSE)
    }
  }

  if(!is.list(x))
    stop(paste0(call, "The '", name, "' argument must be a list."), call. = FALSE)

  if(check_length != 0 && length(x) != check_length)
    stop(paste0(call, "The '", name, "' argument must have length '", check_length, "'."), call. = FALSE)

  if(!is.null(check_names)){

    if(all_objects && any(!check_names %in% names(x)))
      stop(paste0(call, "The '", paste0(check_names[!check_names %in% names(x)], collapse = "', '") ,"' objects are missing in the '", name, "' argument."), call. = FALSE)

    if(!allow_other && any(!names(x) %in% check_names))
      stop(paste0(call, "The '", paste0(names(x)[!names(x) %in% check_names], collapse = "', '") ,"' objects are not recognized by the '", name, "' argument."), call. = FALSE)
  }

  return()
}

# helper functions
.is.wholenumber  <- function(x, na.rm = FALSE, tol = .Machine$double.eps^0.5){
  if(na.rm){
    return(stats::na.omit(abs(x - round(x))) < tol)
  }else{
    return(abs(x - round(x)) < tol)
  }
}

# check transformation argument
.check_transformation_input <- function(transformation, transformation_arguments, transformation_settings){

  if(!is.null(transformation)){
    if(is.character(transformation)){
      check_char(transformation, "transformation")
    }else if(is.list(transformation)){
      check_list(transformation, "transformation", check_length = 3, check_names = c("fun", "inv", "jac"), all_objects = TRUE)
    }else{
      stop("Uknown format of the 'transformation' argument.")
    }
  }
  check_list(transformation_arguments, "transformation_arguments", allow_NULL = TRUE)
  check_bool(transformation_settings, "transformation_settings")

  return()
}

# check whether package is installed
.check_rstan   <- function(){
  if(!requireNamespace("rstan", quietly = TRUE))
    stop("rstan package needs to be installed. Run 'install.packages('rstan')'")
  else
    return(invisible(TRUE))
}
.check_runjags <- function(){
  if(!requireNamespace("runjags", quietly = TRUE))
    stop("runjags package needs to be installed. Run 'install.packages('runjags')'")
  else
    return(invisible(TRUE))
}

# extract stan samples into a named matrix
.extract_stan <- function(fit, drop = TRUE){

  .check_rstan()
  if(!inherits(fit, what = "stanfit"))
    stop("'fit' must be an rstan fit")

  # order permutations to correspond to the other
  # (otherwise, models with same seed produce different posterior draws, like wtf stan???)
  for(i in seq_along(fit@sim$permutation)){
    fit@sim$permutation[[i]] <- seq_along(fit@sim$permutation[[i]])
  }

  model_samples <- rstan::extract(fit)
  par_names     <- names(model_samples)
  par_dims      <- sapply(model_samples, function(s)if(is.matrix(s)) ncol(s) else if(drop) 1 else 0)
  par_names     <- unlist(sapply(seq_along(par_names), function(p){
    if(par_dims[p] == {if(drop) 1 else 0}){
      return(par_names[p])
    }else{
      return(paste0(par_names[p], "[", 1:par_dims[p],"]"))
    }
  }))
  model_samples <- do.call(cbind, model_samples)
  colnames(model_samples) <- par_names

  return(model_samples)
}

# JASP progress bar functions
.JASP_progress_bar_active <- function(package_source = "jaspBase"){
  if(!requireNamespace(package_source, quietly = TRUE)){
    return(FALSE)
  }

  namespace <- asNamespace(package_source)
  if(!exists("jaspResultsCalledFromJasp", envir = namespace, inherits = FALSE)){
    return(FALSE)
  }

  isTRUE(get("jaspResultsCalledFromJasp", envir = namespace, inherits = FALSE)())
}
.JASP_progress_bar_call <- function(function_name, package_source = "jaspBase", ...){
  if(!.JASP_progress_bar_active(package_source)){
    return(invisible(FALSE))
  }

  namespace <- asNamespace(package_source)
  if(!exists(function_name, envir = namespace, inherits = FALSE)){
    return(invisible(FALSE))
  }

  do.call(get(function_name, envir = namespace, inherits = FALSE), list(...))
  return(invisible(TRUE))
}
.JASP_progress_bar_start <- function(n, label = "", package_source = "jaspBase"){
  .JASP_progress_bar_call("startProgressbar", package_source, expectedTicks = n, label = label)
  return(invisible())
}
.JASP_progress_bar_tick  <- function(package_source = "jaspBase"){
  .JASP_progress_bar_call("progressbarTick", package_source)
  return(invisible())
}

# depreciate orthonormal
.depreciate.transform_orthonormal <- function(transform_orthonormal, transform_factors){

  if(isTRUE(transform_orthonormal)){
    warning("'transform_orthonormal' argument will be depreciated in favor of 'transform_factors' argument.", immediate. = TRUE)

    if(isFALSE(transform_factors)){
      transform_factors <- transform_orthonormal
    }
  }

  return(transform_factors)
}
