# Copyright (c) 2022 - 2026, Adrian Dusa
# All rights reserved.
# 
# Redistribution and use in source and binary forms, with or without
# modification, in whole or in part, are permitted provided that the
# following conditions are met:
#     * Redistributions of source code must retain the above copyright
#       notice, this list of conditions and the following disclaimer.
#     * Redistributions in binary form must reproduce the above copyright
#       notice, this list of conditions and the following disclaimer in the
#       documentation and/or other materials provided with the distribution.
#     * The names of its contributors may NOT be used to endorse or promote
#       products derived from this software without specific prior written
#       permission.
# 
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL ADRIAN DUSA BE LIABLE FOR ANY
# DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
# LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
# ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

#' @rdname declared
#'
#' @export
`as.declared` <- function (x, ...) {
  UseMethod ("as.declared")
}


#' @export
`as.declared.default` <- function (x, ...) {
  x <- sanitize_na_index_ (x)
  dots <- list (...)
  interactive <- isTRUE (dots$interactive)
  labels <- attr (x, "labels", exact = TRUE)
  na_index <- attr (x, "na_index", exact = TRUE)
  na_values <- attr (x, "na_values", exact = TRUE)
  na_range <- attr (x, "na_range", exact = TRUE)
  label <- attr (x, "label", exact = TRUE)
  measurement <- attr (x, "measurement", exact = TRUE)
  decimals <- attr (x, "decimals", exact = TRUE)
  xdate <- inherits (x, "Date") || isTRUE (attr (x, "date", exact = TRUE))

  metadata_present <- any (!vapply (
    list (labels, na_index, na_values, na_range, label, measurement, decimals),
    is.null,
    logical (1)
  ))

  if (metadata_present && (is.atomic (x) || inherits (x, "Date"))) {
    normalized_na_index <- !is.null (na_index) && length (na_index) > 0

    if (normalized_na_index) {
      return (direct_declared(
        x,
        na_index = na_index,
        na_values = na_values,
        na_range = na_range,
        labels = labels,
        label = label,
        measurement = measurement,
        decimals = decimals,
        date = xdate
      ))
    }

    return (declared(
      x,
      labels = labels,
      na_values = na_values,
      na_range = na_range,
      label = label,
      measurement = measurement,
      decimals = decimals
    ))
  }

  if (interactive) {
    msg <- "There is no automatic class method conversion for this type of"
    if (!is.null (dots$vname_)) {
      msg <- paste0 (dots$vname_, ": ", msg, " variable.")
    }
    else {
      msg <- paste (msg, "object.")
    }
    message (msg)
  }

  return (x)
}


#' @export
`as.declared.haven_labelled` <- function (x, ...) {

  dots <- list (...)

  na_values <- attr (x, "na_values")
  na_range <- attr (x, "na_range")
  labels <- attr (x, "labels", exact = TRUE)
  label <- attr (x, "label", exact = TRUE)
  xdate <- is.element ("Date", class (x))

  #---------------------------------------
  # necessary for DDIwR::convert
  format_spss <- attr (x, "format.spss")
  format_stata <- attr (x, "format.stata")
  format_sas <- attr (x, "format.sas")
  #---------------------------------------

  declared_nas <- NULL

  if (!inherits (x, "haven_labelled_spss")) {
    na_index <- which (hasTag_ (x))
    if (length (na_index) > 0) {
      declared_nas <- getTag_ (x[na_index])
      x[na_index] <- NA
      names(na_index) <- declared_nas
    }

    attributes (x) <- NULL

    if (!is.null (labels)) {
      nms <- names (labels)
      tagged <- hasTag_ (labels)

      if (any (tagged)) {
        labels[tagged] <- getTag_ (labels[tagged])
        na_values <- sort (unname (labels[tagged]))
      }

      # labels <- coerceMode_ (labels)
      names (labels) <- nms
    }

    misvals <- unique (sort (c (na_values, declared_nas)))
  } else {
    misvals <- all_missing_values (unclass (x))
    na_index <- which (is.element (x, misvals))
    if (length (na_index) > 0) {
      names (na_index) <- x[na_index]
      x[na_index] <- NA
    }
  }

  attributes (x) <- NULL
  pnx <- possibleNumeric_ (x) | all (is.na (x))

  charlabels <- FALSE
  if (!is.null (labels)) {
    if (length (setdiff (labels, na_values)) > 0) {
      charlabels <- !possibleNumeric_ (setdiff(labels, na_values))
    }
  }

  if (length (na_index) > 0) {
    attr (x, "na_index") <- na_index
  }
  attr (x, "na_values") <- na_values
  attr (x, "na_range") <- na_range
  attr (x, "labels") <- labels
  attr (x, "label") <- label
  attr (x, "format.spss") <- format_spss
  attr (x, "format.stata") <- format_stata
  attr (x, "format.sas") <- format_sas
  attr (x, "measurement") <- check_measurement (dots$measurement)
  attr (x, "date") <- xdate
  class(x) <- unique (c ("declared", class (x)))

  return (x)
}


#' @export
`as.declared.factor` <- function (x, ...) {
  return (declared (x, ... = ...))
}


#' @export
`as.declared.data.frame` <- function (x, ..., interactive = FALSE) {
  if (isFALSE (interactive)) {
    x[] <- lapply (x, as.declared, interactive = FALSE, ... = ...)
  }
  else {
    nms <- names (x)
    for (i in seq (length (nms))) {
      x[[i]] <- as.declared (x[[i]], vname_ = nms[i], ... = ...)
    }
  }

  return (x)
}
