#' @title Vérifie le format de date
#'
#' @description La fonction `assert_date_ts` vérifie qu'un objet est de type
#' `AAAA`, `c(AAAA, MM)` ou `c(AAAA, TT)`
#'
#' @param x un vecteur numérique, de préférence `integer` au format `AAAA`,
#' `c(AAAA, MM)` ou `c(AAAA, TT)`
#' @param frequency_ts un entier qui vaut `4L` (ou `4.0`) pour les séries
#' trimestrielles et `12L` (ou `12.0`) pour les séries mensuelles.
#' @param add Collection pour stocker les messages d'erreurs (Default is NULL)
#' @param .var.name Nom de l'objet à vérifier pour afficher dans les messages
#' @param warn un booleen
#'
#' @returns En sortie la fonction retourne l'objet `x` de manière invisible ou
#' une erreur.
#' @details Les fonctions du package date4ts sont faites pour fonctionner
#' avec des times-series de fréquence mensuelle ou trimestrielle et basés sur le
#' système des mois, trimestres et années classiques.
#' On cherche donc à favoriser l'utilisation de vecteur `c(AAAA, MM)` pour
#' désigner la date choisie.
#' Lorsque l'objet `x` en entrée est au mauvais format, il est corrigé pendant
#' la checks et l'objet en sortie est au bon format.
#' Si l'argument `warn` est `FALSE`, alors la fonction ne retournera pas de
#' warning lors de l'évaluation.
#'
#' Ici, l'argument `frequency_ts` est nécessaire car une date sous la forme
#' c(AAAA, PP), avec PP le nombre de période, ne désigne pas une date absolue.
#' Par exemple, c(2020L 5L) désigne mai 2020 pour une fréquence mensuelle et le
#' 1er trimestre 2021 pour une fréquence trimestrielle.
#'
#' Selon le préfixe de la fonction :
#'
#' \itemize{
#' \item si le check réussi : \itemize{
#'     \item la fonction `assert_date_ts` retourne l'objet `x` de manière
#'          invisible;
#'     \item la fonction `check_date_ts` retourne le booléen `TRUE`.
#' }
#' \item si le check échoue : \itemize{
#'     \item la fonction `assert_date_ts` retourne un message d'erreur;
#'     \item la fonction `check_date_ts` retourne une chaîne de caractère
#'          signalant le problème.
#' }
#' }
#'
#' @export
#'
#' @examples
#' # De bons formats de date
#' assert_date_ts(c(2020L, 8L), frequency_ts = 12L)
#' assert_date_ts(c(2020L, 2L), frequency_ts = 4L)
#' check_date_ts(2022L, frequency_ts = 12L)
#'
#' # Format double --> génération d'un warning
#' assert_date_ts(c(2020., 4.0), frequency_ts = 4L)
#' assert_date_ts(2022., frequency_ts = 12L)
#' check_date_ts(2022., frequency_ts = 12L)
#'
#' # Fréquence au format double --> génération d'un warning
#' assert_date_ts(c(2020L, 6L), frequency_ts = 4.0)
#' assert_date_ts(c(2020L, 42L), frequency_ts = 12.0)
#'
#' # Dépassement la fréquence --> génération d'un warning
#' assert_date_ts(c(2020L, 6L), frequency_ts = 4L)
#' assert_date_ts(c(2020L, 42L), frequency_ts = 12L)
#' assert_date_ts(c(2020L, -4L), frequency_ts = 12L)
#'
#' # Avec des erreurs
#' check_date_ts(1:10, frequency_ts = 12L)
#'
check_date_ts <- function(
    x,
    frequency_ts,
    .var.name = checkmate::vname(x),
    warn = TRUE
) {
    output <- make_check_collection()

    check_1 <- checkmate::check_flag(warn, na.ok = FALSE, null.ok = FALSE)
    check_2 <- check_frequency(
        frequency_ts,
        warn = warn,
        .var.name = "frequency_ts"
    )
    check_3 <- checkmate::check_integerish(
        x,
        any.missing = FALSE,
        min.len = 1L,
        max.len = 2L,
        null.ok = FALSE
    )
    check_4 <- checkmate::check_integer(x)

    output <- add_check_collection(
        coll = output,
        check_output = check_1,
        .var.name = "warn"
    )
    output <- add_check_collection(
        coll = output,
        check_output = check_3,
        .var.name = .var.name
    )

    if (isTRUE(output) && warn && !isTRUE(check_4)) {
        err <- try(
            expr = checkmate::assert_integer(x, .var.name = .var.name),
            silent = TRUE
        )
        warning(attr(err, "condition")$message, call. = FALSE)
    }

    output <- add_check_collection(
        coll = output,
        check_output = check_2,
        .var.name = "frequency_ts"
    )

    if (
        isTRUE(output) &&
            warn &&
            (length(x) == 2L) &&
            !isTRUE(checkmate::check_integerish(
                x = x[2L],
                lower = 1L,
                upper = frequency_ts
            ))
    ) {
        err <- try(
            expr = checkmate::assert_integerish(
                x[2L],
                lower = 1L,
                upper = frequency_ts,
                .var.name = "period"
            ),
            silent = TRUE
        )
        warning(attr(err, "condition")$message, call. = FALSE)
    }

    return(output)
}

#' @rdname check_date_ts
#' @export
#'
assert_date_ts <- function(
    x,
    frequency_ts,
    add = NULL,
    .var.name = checkmate::vname(x),
    warn = TRUE
) {
    if (is.null(add)) {
        coll <- checkmate::makeAssertCollection()
    } else {
        coll <- add
    }

    # Check de warn
    checkmate::assert_flag(
        warn,
        add = coll,
        .var.name = "warn",
        na.ok = FALSE,
        null.ok = FALSE
    )
    check_warn <- checkmate::check_flag(warn, na.ok = FALSE, null.ok = FALSE)

    # Check de la fréquence
    if (isTRUE(check_warn)) {
        frequency_ts <- assert_frequency(
            frequency_ts,
            add = coll,
            .var.name = "frequency_ts",
            warn = warn
        )
    } else {
        frequency_ts <- assert_frequency(
            frequency_ts,
            add = coll,
            .var.name = "frequency_ts",
            warn = TRUE
        )
    }

    checkmate::assert_numeric(
        x,
        any.missing = FALSE,
        add = coll,
        .var.name = .var.name,
        min.len = 1L,
        max.len = 2L,
        finite = TRUE
    )
    x_corr <- x

    # Check du type
    # Ici on passe d'abord par un check car il y a une génération de warning
    # non voulue sinon... (voir issue mllg/checkmate#242)
    if (
        isTRUE(checkmate::check_numeric(
            x,
            any.missing = FALSE,
            min.len = 1L,
            max.len = 2L,
            finite = TRUE
        ))
    ) {
        x_corr <- checkmate::assert_integerish(
            x,
            coerce = TRUE,
            any.missing = FALSE,
            add = coll,
            .var.name = .var.name
        )
    }

    if (is.null(add)) {
        checkmate::reportAssertions(coll)
    }

    if (isTRUE(check_date_ts(x, frequency_ts, warn = FALSE))) {
        if (isTRUE(check_warn) && warn) {
            if (!isTRUE(checkmate::check_integer(x))) {
                err <- try(
                    expr = checkmate::assert_integer(x, .var.name = .var.name),
                    silent = TRUE
                )
                warning(attr(err, "condition")$message, call. = FALSE)
            }

            if (
                (length(x) == 2L) &&
                    !isTRUE(checkmate::check_integerish(
                        x = x[2L],
                        lower = 1L,
                        upper = frequency_ts
                    ))
            ) {
                err <- try(
                    expr = checkmate::assert_integerish(
                        x = x[2L],
                        lower = 1L,
                        upper = frequency_ts,
                        .var.name = "period"
                    ),
                    silent = TRUE
                )
                warning(attr(err, "condition")$message, call. = FALSE)
            }
        }

        x <- normalize_date_ts(x_corr, frequency_ts, test = FALSE)
    }

    return(invisible(x))
}

#' @title Vérifie la conformité d'un objet ts
#'
#' @description Les fonctions `assert_ts` et `check_ts` vérifient qu'un objet ts
#' est bien conforme.
#'
#' @param x Un objet ts unidimensionnel
#' @param add Collection pour stocker les messages d'erreurs (Default is NULL)
#' @param .var.name Nom de l'objet à vérifier pour afficher dans les messages
#' @param allow_mts Booleen. Est ce que les objects \code{mts} sont acceptés ?
#'
#' @returns En sortie la fonction retourne l'objet `x` de manière invisible ou
#' une erreur.
#' @details Les fonctions du package date4ts sont faites pour fonctionner
#' avec des times-series de fréquence mensuelle ou trimestrielle et basées sur
#' le système des mois, trimestres et années classiques.
#' On travaille avec des données numériques (integer, double ou logical) mais
#' les autres types atomic sont acceptés également.
#' On cherche donc à favoriser l'utilisation de séries temporelles classiques
#' utilisants des types atomiques.
#' Lorsque l'objet `x` en entrée est au mauvais format, une erreur est généré.
#'
#' Selon le préfixe de la fonction :
#'
#' - si le check réussi :
#'     - la fonction `assert_ts` retourne l'objet `x` de manière invisible;
#'     - la fonction `check_ts` retourne le booléen `TRUE`.
#'
#' - si le check échoue :
#'     - la fonction `assert_ts` retourne un message d'erreur;
#'     - la fonction `check_ts` retourne une chaîne de caractère signalant le
#'     problème.
#'
#' @export
#'
#' @examples
#' ts1 <- ts(1:100, start = 2010L, frequency = 12L)
#' ts2 <- ts(1:10, start = c(2020L, 4L), frequency = 4L)
#'
#' assert_ts(ts1)
#' assert_ts(ts2)
#'
#' check_ts(ts1)
#' check_ts(ts2)
#'
#' # Exemples avec des erreurs
#'
#' check_ts(1)
#' check_ts(ts(1:10, start = 2010L, frequency = 2L))
#' check_ts(1:10)
#'
check_ts <- function(x, .var.name = checkmate::vname(x), allow_mts = FALSE) {
    output <- make_check_collection()

    # Check de la classe de l'objet
    check_1 <- checkmate::check_class(x, classes = "ts", null.ok = FALSE)
    output <- add_check_collection(
        coll = output,
        check_output = check_1,
        .var.name = .var.name
    )

    if (isTRUE(check_1)) {
        # Check de la fréquence
        check_2 <- check_expression({
            stats::frequency(x)
        })
        output <- add_check_collection(coll = output, check_output = check_2)

        if (isTRUE(check_2)) {
            frequency_ts <- stats::frequency(x)

            check_3 <- check_frequency(
                frequency_ts,
                warn = FALSE,
                .var.name = "frequency_ts"
            )
            output <- add_check_collection(
                coll = output,
                check_output = check_3
            )

            if (isTRUE(check_3)) {
                # Check de la temporalité - start
                check_4 <- check_expression(expr = {
                    stats::start(x)
                })
                output <- add_check_collection(
                    coll = output,
                    check_output = check_4
                )

                if (isTRUE(check_4)) {
                    start_ts <- stats::start(x)

                    check_5 <- check_date_ts(
                        start_ts,
                        frequency_ts = frequency_ts,
                        warn = FALSE,
                        .var.name = paste0("stats::start(", .var.name, ")")
                    )
                    output <- add_check_collection(
                        coll = output,
                        check_output = check_5
                    )
                }

                # Check de la temporalité - end
                check_6 <- check_expression(expr = {
                    stats::end(x)
                })
                output <- add_check_collection(
                    coll = output,
                    check_output = check_6
                )

                if (isTRUE(check_6)) {
                    end_ts <- stats::end(x)

                    check_7 <- check_date_ts(
                        end_ts,
                        frequency_ts = frequency_ts,
                        warn = FALSE,
                        .var.name = paste0("stats::end(", .var.name, ")")
                    )
                    output <- add_check_collection(
                        coll = output,
                        check_output = check_7
                    )
                }
            }
        }

        # Check que l'objet ne soit pas un mts
        check_8 <- ifelse(
            test = allow_mts,
            yes = TRUE,
            no = checkmate::check_false(stats::is.mts(x))
        )
        output <- add_check_collection(
            coll = output,
            check_output = check_8,
            .var.name = paste0("stats::is.mts(", .var.name, ")")
        )

        # Check du type de données
        check_9 <- checkmate::check_atomic_vector(x)
        check_10 <- checkmate::check_matrix(x, mode = "atomic", null.ok = FALSE)

        cond_mts <- isTRUE(check_9) || isTRUE(check_10)
        check_11 <- ifelse(
            test = cond_mts,
            yes = TRUE,
            no = paste(check_9, check_10, sep = " OR ")
        )

        check_12 <- ifelse(
            test = allow_mts,
            yes = check_11,
            no = check_9
        )

        output <- add_check_collection(
            coll = output,
            check_output = check_12,
            .var.name = .var.name
        )
    }

    return(output)
}

#' @rdname check_ts
#' @export
#'
assert_ts <- function(
    x,
    add = NULL,
    .var.name = checkmate::vname(x),
    allow_mts = FALSE
) {
    if (is.null(add)) {
        coll <- checkmate::makeAssertCollection()
    } else {
        coll <- add
    }

    checkmate::assert_class(
        x,
        classes = "ts",
        add = coll,
        .var.name = .var.name
    )

    # Check de la fréquence
    frequency_ts <- assert_expression(
        expr = stats::frequency(x)
    )
    frequency_ts <- assert_frequency(
        frequency_ts,
        add = coll,
        .var.name = "frequency_ts",
        warn = FALSE
    )

    # Check de la temporalité
    start_ts <- assert_expression(
        expr = stats::start(x)
    )
    start_ts <- assert_date_ts(
        start_ts,
        frequency_ts = frequency_ts,
        add = coll,
        .var.name = "start",
        warn = FALSE
    )

    end_ts <- assert_expression(
        expr = stats::end(x)
    )
    end_ts <- assert_date_ts(
        end_ts,
        frequency_ts = frequency_ts,
        add = coll,
        .var.name = "end",
        warn = FALSE
    )

    # Check de la classe de l'objet
    if (!allow_mts) {
        checkmate::assert_false(
            x = stats::is.mts(x),
            add = coll,
            .var.name = paste0("is.mts(", .var.name, ")")
        )
    }

    # Check du type de données
    cond_mts <- isTRUE(checkmate::check_atomic_vector(x)) ||
        isTRUE(checkmate::check_matrix(x, mode = "atomic", null.ok = FALSE))
    check_1 <- checkmate::check_atomic_vector(x)
    check_2 <- checkmate::check_matrix(x, mode = "atomic", null.ok = FALSE)

    if (allow_mts && !cond_mts) {
        coll$push(msg = paste(check_1, check_2, sep = " OR "))
    } else if (!allow_mts) {
        checkmate::assert_atomic_vector(x, add = coll, .var.name = .var.name)
    }

    if (is.null(add)) {
        checkmate::reportAssertions(coll)
    }

    return(invisible(x))
}

#' @title Vérifie la conformité d'un objet TimeUnits
#'
#' @description La fonction `assert_timeunits` vérifie qu'un objet est un
#' TimeUnits.
#'
#' @param x un numérique qui représente le time units de
#' @param frequency_ts un entier qui vaut `4L` (ou `4.0`) pour les séries
#' trimestrielles et `12L` (ou `12.0`) pour les séries mensuelles.
#' @param add Collection pour stocker les messages d'erreurs (Default is NULL)
#' @param .var.name Nom de l'objet à vérifier pour afficher dans les messages
#'
#' @returns En sortie la fonction retourne l'objet `x` de manière invisible ou
#' une erreur.
#'
#' @details
#' Un objet de type TimeUnits est un numérique qui désigne l'année et la période
#' en cours avec ses décimales.
#' Ainsi pour une série temporelle mensuelle, `2020.5` représente la moitié de
#' l'année donc juillet 2020 et s'écrit `c(2020L, 7L)` au format date_ts.
#'
#' Selon le préfixe de la fonction :
#'
#' - si le check réussi :
#'     - la fonction `assert_timeunits` retourne l'objet `x` de manière
#'     invisible;
#'     - la fonction `check_timeunits` retourne le booléen `TRUE`.
#'
#' - si le check échoue :
#'     - la fonction `assert_timeunits` retourne un message d'erreur;
#'     - la fonction `check_timeunits` retourne une chaîne de caractère
#'     signalant le problème.
#'
#' @export
#'
#' @examples
#'
#' assert_timeunits(2020.5, frequency_ts = 12L)
#' assert_timeunits(2020.5, frequency_ts = 4L)
#' assert_timeunits(2023., frequency_ts = 12L)
#'
#' assert_timeunits(2000. + 5. / 12.0, frequency_ts = 12L)
#' assert_timeunits(2015. + 3. / 4.0, frequency_ts = 4L)
#'
#' check_timeunits(2020.5, frequency_ts = 12L)
#' check_timeunits(2015. + 3. / 4.0, frequency_ts = 4L)
#'
#' # Avec erreur
#'
#' check_timeunits(list(1.), frequency_ts = 12L)
#' check_timeunits(2000., frequency_ts = 1L)
#'
check_timeunits <- function(x, frequency_ts, .var.name = checkmate::vname(x)) {
    output <- make_check_collection()

    check_1 <- check_frequency(frequency_ts, .var.name = "frequency_ts")
    check_2 <- checkmate::check_number(x, finite = TRUE, na.ok = FALSE)

    output <- add_check_collection(coll = output, check_output = check_1)
    output <- add_check_collection(
        coll = output,
        check_output = check_2,
        .var.name = .var.name
    )

    if (isTRUE(check_1) && isTRUE(check_2)) {
        check_3 <- checkmate::check_int(x * frequency_ts)
        output <- add_check_collection(
            coll = output,
            check_output = check_3,
            .var.name = paste(.var.name, "* frequency_ts")
        )
    }

    return(output)
}

#' @rdname check_timeunits
#' @export
#'
assert_timeunits <- function(
    x,
    frequency_ts,
    add = NULL,
    .var.name = checkmate::vname(x)
) {
    if (is.null(add)) {
        coll <- checkmate::makeAssertCollection()
    } else {
        coll <- add
    }

    # Check de la fréquence
    frequency_ts <- assert_frequency(
        frequency_ts,
        add = coll,
        .var.name = "frequency_ts"
    )
    # Check de l'objet x (TimeUnits)
    checkmate::assert_number(
        x,
        add = coll,
        .var.name = .var.name,
        finite = TRUE
    )

    if (
        isTRUE(check_frequency(frequency_ts, warn = FALSE)) &&
            isTRUE(checkmate::check_number(x, finite = TRUE))
    ) {
        checkmate::assert_int(
            x * frequency_ts,
            add = coll,
            .var.name = paste0(.var.name, " * frequency_ts")
        )
    }

    if (is.null(add)) {
        checkmate::reportAssertions(coll)
    }

    return(invisible(x))
}

#' @title Vérifie la conformité d'une fréquence
#'
#' @param x un entier qui vaut `4L` (ou `4.0`) pour les séries trimestrielles et
#' `12L` (ou `12.0`) pour les séries mensuelles.
#' @param warn un booleen
#' @param add Collection pour stocker les messages d'erreurs (Default is NULL)
#' @param .var.name Nom de l'objet à vérifier pour afficher dans les messages
#'
#' @details La fréquence d'une série temporelle est soit mensuelle (`12L` ou
#' `12.0`) soit trimestrielle (`4L` ou `4.0`). Les autres fréquences ne sont pas
#' acceptées.
#' Cette fonction s'appuie essentiellement sur les fonctions
#' `checkmate::check_numeric`, `checkmate::check_int` et
#' `checkmate::check_choice`.
#' Il y a néanmoins une petite subtilité : on vérifie si l'objet `x` est de type
#' double ou integer.
#' Dans le premier cas, on affichera un warning et on corrigera l'objet au
#' format integer pour les traitements ultérieurs. En sortie, `x` est retourné
#' de manière invisible.
#' Si l'argument `warn` est `FALSE`, alors la fonction ne retournera pas de
#' warning lors de l'évaluation.
#'
#' Selon le préfixe de la fonction :
#'
#' - si le check réussi :
#'     - la fonction `assert_frequency` retourne l'objet `x` de manière
#'     invisible;
#'     - la fonction `check_frequency` retourne le booléen `TRUE`.
#'
#' - si le check échoue :
#'     - la fonction `assert_frequency` retourne un message d'erreur;
#'     - la fonction `check_frequency` retourne une chaîne de caractère
#'     signalant le problème.
#'
#' @returns En sortie la fonction retourne l'objet `x` de manière invisible ou
#' une erreur.
#'
#' @export
#'
#' @examples
#'
#' assert_frequency(4L)
#' assert_frequency(12L)
#'
#' check_frequency(4L)
#' check_frequency(12L)
#'
#' # Avec des erreurs,
#'
#' check_frequency(Inf, warn = FALSE)
#' check_frequency(1:10)
#' check_frequency(1L)
#'
check_frequency <- function(x, .var.name = checkmate::vname(x), warn = TRUE) {
    output <- make_check_collection()

    check_1 <- checkmate::check_numeric(x, finite = TRUE, any.missing = FALSE)
    check_2 <- checkmate::check_flag(warn, na.ok = FALSE, null.ok = FALSE)
    check_3 <- checkmate::check_integer(x)
    check_4 <- checkmate::check_int(x)
    check_5 <- checkmate::check_choice(x, choices = c(4L, 12L))

    output <- add_check_collection(
        coll = output,
        check_output = check_1,
        .var.name = .var.name
    )
    output <- add_check_collection(
        coll = output,
        check_output = check_2,
        .var.name = "warn"
    )

    if (isTRUE(check_1)) {
        output <- add_check_collection(
            coll = output,
            check_output = check_4,
            .var.name = .var.name
        )
        output <- add_check_collection(
            coll = output,
            check_output = check_5,
            .var.name = .var.name
        )

        if (isTRUE(check_2) && warn && !isTRUE(check_3)) {
            err <- try(
                expr = checkmate::assert_integer(
                    x = x,
                    .var.name = .var.name
                ),
                silent = TRUE
            )
            warning(attr(err, "condition")$message, call. = FALSE)
        }
    }

    return(output)
}

#' @rdname check_frequency
#' @export
#'
assert_frequency <- function(
    x,
    add = NULL,
    .var.name = checkmate::vname(x),
    warn = TRUE
) {
    if (is.null(add)) {
        coll <- checkmate::makeAssertCollection()
    } else {
        coll <- add
    }

    # Check de warn
    checkmate::assert_flag(
        warn,
        add = coll,
        .var.name = "warn",
        na.ok = FALSE,
        null.ok = FALSE
    )
    check_warn <- checkmate::check_flag(warn, na.ok = FALSE, null.ok = FALSE)

    # Check du type
    # Ici on passe d'abord par un check car il y a une génération de warning
    # non voulue sinon... (voir issue #242)
    check_1 <- checkmate::check_numeric(x, any.missing = FALSE, finite = TRUE)
    if (isTRUE(check_1)) {
        x_corr <- checkmate::assert_int(
            x,
            coerce = TRUE,
            add = coll,
            .var.name = .var.name
        )
        checkmate::assert_choice(
            x_corr,
            choices = c(4L, 12L),
            add = coll,
            .var.name = .var.name
        )
    } else {
        checkmate::assert_numeric(
            x,
            any.missing = FALSE,
            finite = TRUE,
            add = coll,
            .var.name = .var.name
        )
    }

    if (is.null(add)) {
        checkmate::reportAssertions(coll)
    }

    if (isTRUE(check_frequency(x, warn = FALSE))) {
        if (
            isTRUE(check_warn) && warn && (!isTRUE(checkmate::check_integer(x)))
        ) {
            err <- try(
                expr = checkmate::assert_integer(x, .var.name = .var.name),
                silent = TRUE
            )
            warning(attr(err, "condition")$message, call. = FALSE)
        }
        x <- x_corr
    }

    return(invisible(x))
}


#' @title Vérifie la conformité d'un entier scalaire
#'
#' @param x un entier relatif (positif, négatif ou nul)
#' @param add Collection pour stocker les messages d'erreurs (Default is NULL)
#' @param .var.name Nom de l'objet à vérifier pour afficher dans les messages
#' @param warn un booleen
#'
#' @returns En sortie la fonction retourne l'objet `x` de manière invisible ou
#' une erreur.
#'
#' @details
#' On vérifie que l'objet `x` en entrée est bien un entier.
#' Cette fonction s'appuie essentiellement sur la fonction
#' `checkmate::assert_int`.
#' Il y a néanmoins une petite subtilité : on vérifie si l'objet `x` est de
#' type double ou integer. Si l'objet est de type double (et non integer), la
#' fonction retournera aussi un warning.
#' Dans le premier cas, on affichera un warning et on corrigera l'objet au
#' format integer pour les traitements ultérieurs. En sortie, `x` est retourné
#' de manière invisible.
#' Si l'argument `warn` vaut `FALSE`, alors la fonction ne retournera pas de
#' warning lors de l'évaluation.
#'
#' Selon le préfixe de la fonction :
#'
#' - si le check réussi :
#'     - la fonction `assert_scalar_integer` retourne l'objet `x` de manière
#' invisible;
#'     - la fonction `check_scalar_integer` retourne le booléen `TRUE`.
#'
#' - si le check échoue :
#'     - la fonction `assert_scalar_integer` retourne un message d'erreur;
#'     - la fonction `check_scalar_integer` retourne une chaîne de caractère
#' signalant le problème.
#'
#' @export
#'
#' @seealso [check_scalar_natural()], [assert_scalar_natural()]
#'
#' @examples
#'
#' assert_scalar_integer(1L)
#' assert_scalar_integer(100L)
#' assert_scalar_integer(-4L)
#' assert_scalar_integer(0L)
#'
#' check_scalar_integer(1L)
#' check_scalar_integer(100L)
#' check_scalar_integer(-4L)
#' check_scalar_integer(0L)
#'
#' # Avec des erreurs,
#'
#' check_scalar_integer(Inf)
#' check_scalar_integer(1:10)
#' check_scalar_integer(pi)
#' check_scalar_integer(2.)
#'
check_scalar_integer <- function(x, warn = TRUE) {
    output <- make_check_collection()

    check_1 <- checkmate::check_int(x)
    check_2 <- checkmate::check_flag(warn, na.ok = FALSE, null.ok = FALSE)
    check_3 <- checkmate::check_integer(x)

    output <- add_check_collection(
        coll = output,
        check_output = check_1,
        .var.name = "x"
    )
    output <- add_check_collection(
        coll = output,
        check_output = check_2,
        .var.name = "warn"
    )

    if (isTRUE(output) && warn && !isTRUE(check_3)) {
        err <- try(
            checkmate::assert_integer(x),
            silent = TRUE
        )
        warning(attr(err, "condition")$message, call. = FALSE)
    }

    return(output)
}

#' @rdname check_scalar_integer
#' @export
#'
assert_scalar_integer <- function(
    x,
    add = NULL,
    .var.name = checkmate::vname(x),
    warn = TRUE
) {
    if (is.null(add)) {
        coll <- checkmate::makeAssertCollection()
    } else {
        coll <- add
    }

    # Qqs variables de check
    check_warn <- checkmate::check_flag(warn, na.ok = FALSE, null.ok = FALSE)
    check_int_var <- checkmate::check_int(x)

    # Check de warn
    checkmate::assert_flag(
        warn,
        add = coll,
        .var.name = "warn",
        na.ok = FALSE,
        null.ok = FALSE
    )
    checkmate::assert_int(x, add = coll, .var.name = .var.name)

    if (isTRUE(check_int_var) && !isTRUE(checkmate::check_integer(x))) {
        if (isTRUE(check_warn) && warn) {
            err <- try(
                checkmate::assert_integer(x, .var.name = .var.name),
                silent = TRUE
            )
            warning(attr(err, "condition")$message, call. = FALSE)
        }

        x <- checkmate::assert_int(
            x,
            coerce = TRUE,
            add = coll,
            .var.name = .var.name
        )
    }

    if (is.null(add)) {
        checkmate::reportAssertions(coll)
    }

    return(invisible(x))
}

#' @title Vérifie la conformité d'un entier naturel
#'
#' @description
#' Le but de cett fonction est de tester si une variable x est un nombre naturel
#' strictement positif.
#'
#' @param x un entier naturel strictement positif
#' @param add Collection pour stocker les messages d'erreurs (Default is NULL)
#' @param .var.name Nom de l'objet à vérifier pour afficher dans les messages
#' @param warn un booleen
#'
#' @returns En sortie la fonction retourne l'objet `x` de manière invisible ou
#' une erreur.
#'
#' @details
#' Cette fonction s'appuie essentiellement sur la fonction
#' `checkmate::assert_count`.
#' Il y a néanmoins une petite subtilité : on vérifie si l'objet `x` est de type
#' double ou integer.
#' Dans le premier cas, on affichera un warning et on corrigera l'objet au
#' format integer pour les traitements ultérieurs. En sortie, `x` est retourné
#' de manière invisible.
#' Si l'argument `warn` est `FALSE`, alors la fonction ne retournera pas de
#' warning lors de l'évaluation.
#'
#' Selon le préfixe de la fonction :
#'
#' - si le check réussi :
#'     - la fonction `assert_scalar_natural` retourne l'objet `x` de manière
#' invisible;
#'     - la fonction `check_scalar_natural` retourne le booléen `TRUE`.
#'
#' - si le check échoue :
#'     - la fonction `assert_scalar_natural` retourne un message d'erreur;
#'     - la fonction `check_scalar_natural` retourne une chaîne de caractère
#' signalant le problème.
#'
#' @export
#'
#' @seealso [check_scalar_integer()], [assert_scalar_integer()]
#'
#' @examples
#'
#' # Avec des entier integer
#' assert_scalar_natural(1L)
#' assert_scalar_natural(100L)
#'
#' # Avec des entiers double
#' assert_scalar_natural(2.)
#' assert_scalar_natural(457)
#'
check_scalar_natural <- function(x, warn = TRUE) {
    output <- make_check_collection()

    check_1 <- checkmate::check_count(
        x,
        positive = TRUE,
        na.ok = FALSE,
        null.ok = FALSE
    )
    check_2 <- checkmate::check_flag(warn, na.ok = FALSE, null.ok = FALSE)
    check_3 <- checkmate::check_integer(x)

    output <- add_check_collection(
        coll = output,
        check_output = check_1,
        .var.name = "x"
    )
    output <- add_check_collection(
        coll = output,
        check_output = check_2,
        .var.name = "warn"
    )

    if (isTRUE(output) && warn && !isTRUE(check_3)) {
        err <- try(
            checkmate::assert_integer(x),
            silent = TRUE
        )
        warning(attr(err, "condition")$message, call. = FALSE)
    }

    return(output)
}

#' @rdname check_scalar_natural
#' @export
#'
assert_scalar_natural <- function(
    x,
    add = NULL,
    .var.name = checkmate::vname(x),
    warn = TRUE
) {
    if (is.null(add)) {
        coll <- checkmate::makeAssertCollection()
    } else {
        coll <- add
    }

    # Check de warn
    checkmate::assert_flag(
        warn,
        add = coll,
        .var.name = "warn",
        na.ok = FALSE,
        null.ok = FALSE
    )
    check_warn <- checkmate::check_flag(warn, na.ok = FALSE, null.ok = FALSE)

    # Check du type
    # Ici on passe d'abord par un check car il y a une génération de warning
    # non voulue sinon... (voir issue #242)
    check_1 <- checkmate::check_numeric(x, any.missing = FALSE, finite = TRUE)
    x_corr <- x
    if (isTRUE(check_1)) {
        x_corr <- checkmate::assert_count(
            x,
            coerce = TRUE,
            positive = TRUE,
            add = coll,
            .var.name = .var.name
        )
    } else {
        checkmate::assert_numeric(
            x,
            any.missing = FALSE,
            finite = TRUE,
            add = coll,
            .var.name = .var.name
        )
    }

    if (is.null(add)) {
        checkmate::reportAssertions(coll)
    }

    if (
        isTRUE(check_1) &&
            isTRUE(check_warn) &&
            warn &&
            !isTRUE(checkmate::check_integer(x))
    ) {
        err <- try(
            expr = checkmate::assert_integer(x, .var.name = .var.name),
            silent = TRUE
        )
        warning(attr(err, "condition")$message, call. = FALSE)
    }
    x <- x_corr

    return(invisible(x))
}

#' @title Vérifie la conformité d'une date scalaire
#'
#' @param x un objet de type `Date`.
#' @param add Collection pour stocker les messages d'erreurs (Default is NULL)
#' @param .var.name Nom de l'objet à vérifier pour afficher dans les messages
#'
#' @returns En sortie la fonction retourne l'objet `x` de manière invisible ou
#' une erreur.
#'
#' @details
#' On vérifie que l'objet `x` en entrée est bien au format `Date` et qu'il
#' s'agit d'un scalaire (vecteur de taille 1).
#' Cette fonction s'appuie essentiellement sur la fonction
#' `checkmate::assert_date`.
#'
#' Selon le préfixe de la fonction :
#'
#' - si le check réussi :
#'     - la fonction `assert_scalar_date` retourne l'objet `x` de manière
#'     invisible;
#'     - la fonction `check_scalar_date` retourne le booléen `TRUE`.
#'
#' - si le check échoue :
#'     - la fonction `assert_scalar_date` retourne un message d'erreur;
#'     - la fonction `check_scalar_date` retourne la chaîne de caractère
#'     correspondante à l'erreur du check.
#'
#' @export
#'
#' @examples
#'
#' assert_scalar_date(as.Date("2018-01-24"))
#' assert_scalar_date(as.Date("2000-02-29"))
#' assert_scalar_date(Sys.Date())
#'
#' check_scalar_date(as.Date("2018-01-24"))
#' check_scalar_date(as.Date("2000-02-29"))
#' check_scalar_date(Sys.Date())
#'
#' # Avec des erreurs
#'
#' check_scalar_date(2L)
#' check_scalar_date(seq(from = as.Date("2000-01-01"), to = Sys.Date(), by =
#' "year"))
#'
check_scalar_date <- function(x) {
    output <- make_check_collection()

    output <- add_check_collection(output, checkmate::check_date(x))
    output <- add_check_collection(output, checkmate::check_scalar(x))

    output <- paste(output, collapse = "\n")

    return(output)
}

#' @rdname check_scalar_date
#' @export
#'
assert_scalar_date <- function(x, add = NULL, .var.name = checkmate::vname(x)) {
    if (is.null(add)) {
        coll <- checkmate::makeAssertCollection()
    } else {
        coll <- add
    }
    checkmate::assert_date(
        x,
        add = coll,
        .var.name = .var.name,
        any.missing = FALSE,
        len = 1L
    )

    if (is.null(add)) {
        checkmate::reportAssertions(coll)
    }

    return(invisible(x))
}
#' @title Vérifie la conformité d'une expression
#'
#' @param expr une expression à évaluer
#'
#' @returns En sortie la fonction retourne l'objet `x` (le résultat de
#' l'évaluation de l'expression `expr`) de manière invisible ou une erreur.
#'
#' @details La fonction évalue l'expression `expr`. Le check vérifie si la
#' fonction génère une erreur ou un warning. Si elle ne génère aucun message
#' particulier, on retourne alors l'objet `x` (le résultat de l'évaluation de
#' l'expression `expr`), sans erreur.
#'
#' Selon le préfixe de la fonction :
#'
#' - si le check réussi :
#'     - la fonction `assert_expression` retourne l'objet `x` de manière
#'     invisible;
#'     - la fonction `check_expression` retourne le booléen `TRUE`.
#'
#' - si le check échoue :
#'     - la fonction `assert_expression` retourne un message d'erreur;
#'     - la fonction `check_expression` retourne la chaîne de caractère
#'     "Invalid expression".
#'
#' @export
#'
#' @examples
#'
#' assert_expression(expr = {2 + 2})
#' assert_expression(expr = {is.integer(1L)})
#' try(assert_expression(expr = {log("a")}), silent = TRUE)
#'
#' check_expression(expr = {2 + 2})
#' check_expression(expr = {is.integer(1L)})
#' check_expression(expr = {log("a")})
#'
check_expression <- function(expr) {
    out <- tryCatch(
        expr,
        error = function(e) e,
        warning = function(w) w
    )

    if (inherits(out, "warning") || inherits(out, "error")) {
        return(paste("Invalid expression :", deparse(substitute(expr))))
    }

    return(TRUE)
}

#' @rdname check_expression
#' @export
#'
assert_expression <- function(expr) {
    out <- tryCatch(
        expr,
        error = function(e) e,
        warning = function(w) w
    )

    if (inherits(out, "warning") || inherits(out, "error")) {
        stop("Invalid expression :", deparse(substitute(expr)), call. = FALSE)
    }

    return(invisible(expr))
}

#' @title Crée une collection de checks
#'
#' @description
#' Initialise une collection vide destinée à stocker les résultats des checks
#' des différents arguments, fonctions et contenus.
#' Cette collection peut ensuite être enrichie progressivement à l’aide de
#' la fonction \code{add_check_collection()}.
#'
#' @details
#' La collection de vérifications est représentée par une valeur logique `TRUE`
#' au moment de son initialisation. Cela indique qu’aucune erreur ou alerte
#' n’a encore été détectée.
#' Lorsqu’un contrôle échoue, des messages sont ajoutés à cette collection
#' sous forme de chaînes de caractères.
#'
#' @return
#' Un objet logique `TRUE` représentant une collection vide de vérifications.
#'
#' @examples
#' coll <- make_check_collection()
#' coll
#'
#' @keywords internal
#' @noRd
make_check_collection <- function() {
    return(TRUE)
}

#' @title Ajoute un résultat de checks à une collection
#'
#' @description
#' Ajoute un message de checks à une collection existante créée par
#' \code{make_check_collection()}.
#' Cette fonction permet d’agréger plusieurs messages d’erreurs ou
#' d’avertissements dans un seul objet, utile pour des fonctions de validation
#' interne.
#'
#' @param coll Une collection de checks, généralement créée avec
#' \code{make_check_collection()}.
#' Peut être une valeur logique (`TRUE`) ou une chaîne de caractères contenant
#' déjà des messages.
#' @param check_output Résultat du contrôle. Doit être `TRUE` si le contrôle
#' est validé, ou une chaîne de caractères décrivant le problème sinon.
#' @param .var.name (optionnel) Nom de la variable ou de l’objet concerné
#' par le contrôle. Si fourni, il est ajouté au début du message.
#'
#' @details
#' Si `check_output` vaut `TRUE`, la collection est retournée telle quelle.
#' Dans le cas contraire, le message est ajouté au texte existant dans la
#' collection. Le résultat final est une chaîne de caractères contenant
#' l’ensemble des messages, séparés par des sauts de ligne.
#'
#' @return
#' Une chaîne de caractères contenant tous les messages de checks,
#' ou `TRUE` si aucun problème n’a été détecté.
#'
#' @examples
#' coll <- make_check_collection()
#' coll <- add_check_collection(coll, "Valeur hors intervalle", .var.name = "x")
#' coll
#'
#' @keywords internal
#' @noRd
add_check_collection <- function(coll, check_output, .var.name = NULL) {
    if (isTRUE(check_output)) {
        return(coll)
    } else if (!is.null(.var.name)) {
        check_output <- paste("*", .var.name, check_output)
    }

    if (isTRUE(coll)) {
        return(check_output)
    } else {
        return(paste(coll, "\n", check_output))
    }
}
