#' Build the observations for a single QNAM
#'
#' @param dataset Input dataset
#' @param qnam  QNAM value
#' @param qlabel QLABEL value
#' @param idvar IDVAR variable name (provided as a string)
#' @param qeval QEVAL value to be populated for this QNAM
#' @param qorig QORIG value to be populated for this QNAM
#' @param verbose Character string controlling message verbosity. One of:
#'   \describe{
#'     \item{`"message"`}{Show both warnings and messages (default)}
#'     \item{`"warn"`}{Show warnings but suppress messages}
#'     \item{`"silent"`}{Suppress all warnings and messages}
#'   }
#'
#' @return Observations structured in SUPP format
#' @export
#'
build_qnam <- function(dataset, qnam, qlabel, idvar, qeval, qorig,
                       verbose = c("message", "warn", "silent")) {
  verbose <- validate_verbose(verbose)

  # Need QNAM as a variable
  qval <- as.symbol(qnam)

  # DM won't have an IDVAR so handle that
  if (is.na(idvar) || idvar == "") {
    dataset <- dataset %>%
      mutate(IDVARVAL = idvar)
    idvarval <- sym("IDVARVAL")
  } else {
    idvarval <- as.symbol(idvar)
  }

  dup_sup <- dataset %>%
    select(STUDYID, RDOMAIN = DOMAIN, USUBJID, !!idvarval, !!qval) %>%
    rename(IDVARVAL = !!idvarval, QVAL = !!qval) %>%
    filter(!is.na(QVAL)) %>%
    mutate(
      IDVAR = idvar,
      QNAM = qnam,
      QLABEL = qlabel,
      QORIG = qorig,
      QEVAL = qeval
    )

  out <- dup_sup %>%
    distinct(STUDYID, RDOMAIN,
      USUBJID, IDVARVAL, QNAM,
      .keep_all = TRUE
    ) %>%
    select(
      STUDYID, RDOMAIN, USUBJID, IDVAR,
      IDVARVAL, QNAM, QLABEL, QVAL,
      QORIG, QEVAL
    )

  test_out <- dup_sup %>%
    distinct()
  if (nrow(out) != nrow(test_out)) {
    stop("The combination of STUDYID, RDOMAIN, USUBJID, IDVARVAL, QNAM is ambiguous. Consider modifying the IDVAR",
      call. = FALSE
    )
  }

  blank_test <- out %>%
    pull(QVAL)
  if (any(blank_test == "")) {
    if (check_message(verbose)) {
      message(paste0("Empty QVAL rows removed for QNAM = ", unique(out$QNAM)))
    }
    out <- out %>%
      filter(QVAL != "")
  }
  out
}


#' Make Supplemental Qualifier
#'
#' @param dataset dataset the supp will be pulled from
#' @param metacore A subsetted metacore object to get the supp information from.
#'   If not already subsetted then a `dataset_name` will need to be provided
#' @param dataset_name `r lifecycle::badge("deprecated")` Optional string to
#'   specify the dataset that is being built. This is only needed if the metacore
#'   object provided hasn't already been subsetted.\cr
#'   Note: Deprecated in version 0.2.0. The `dataset_name` argument will be removed
#'   in a future release. Please use `metacore::select_dataset` to subset the
#'   `metacore` object to obtain metadata for a single dataset.
#'
#' @return a CDISC formatted SUPP dataset
#' @export
#'
#' @examples
#'
#' library(metacore)
#' library(safetyData)
#' library(tibble)
#' load(metacore_example("pilot_SDTM.rda"))
#' spec <- metacore %>% select_dataset("AE")
#' ae <- combine_supp(sdtm_ae, sdtm_suppae)
#' make_supp_qual(ae, spec) %>% as_tibble()
make_supp_qual <- function(dataset, metacore, dataset_name = deprecated()) {
  if (is_present(dataset_name)) {
    lifecycle::deprecate_warn(
      when = "0.2.0",
      what = "make_supp_qual(dataset_name)",
      details = cli_inform(c("i" = col_red("The {.arg dataset_name} argument will be removed in a future release.
      Please use {.fn metacore::select_dataset} to subset the {.obj metacore} object to obtain
      metadata for a single dataset.")))
    )
    metacore <- make_lone_dataset(metacore, dataset_name)
  }
  verify_DatasetMeta(metacore)

  supp_vars <- metacore$ds_vars %>%
    filter(supp_flag)
  if (nrow(supp_vars) == 0) {
    stop("No supplemental variables specified in metacore object. Please check your specifications",
      call. = FALSE
    )
  }

  supp_meta <- supp_vars %>%
    select(dataset, variable) %>%
    left_join(metacore$var_spec, by = "variable") %>%
    left_join(metacore$value_spec, by = c("dataset", "variable")) %>%
    left_join(metacore$supp, by = c("dataset", "variable")) %>%
    select(
      qnam = variable, qlabel = label,
      qorig = origin, qeval = qeval,
      idvar = idvar
    ) %>%
    distinct() # Protection against bad specs
  # TODO Addin in checks/coercion for when combining cols of different types
  pmap_dfr(supp_meta, build_qnam, dataset = dataset) %>%
    arrange(USUBJID, QNAM, IDVARVAL)
}

#' Combine the Domain and Supplemental Qualifier
#'
#' @param dataset Domain dataset
#' @param supp Supplemental Qualifier dataset
#'
#' @return a dataset with the supp variables added to it
#' @export
#
#' @examples
#' library(safetyData)
#' library(tibble)
#' combine_supp(sdtm_ae, sdtm_suppae) %>% as_tibble()
combine_supp <- function(dataset, supp) {
  if (!is.data.frame(dataset) | !is.data.frame(supp)) {
    stop("You must supply a domain and supplemental dataset", call. = FALSE)
  }
  if (nrow(supp) == 0) {
    warning("Zero rows in supp, returning original dataset unchanged")
    return(dataset)
  }

  # Verify required dataset cols are present
  required_vars <- c("STUDYID", "DOMAIN", "USUBJID")
  missing_vars <- setdiff(required_vars, names(dataset))

  if (length(missing_vars) > 0) {
    cli::cli_abort(c(
      "x" = "Core SDTM variables are missing from the dataset:",
      "i" = "{.val {missing_vars}}"
    ))
  }


  # Verify required supp cols are present
  supp_cols <- c(
    "STUDYID", "RDOMAIN", "USUBJID", "IDVAR", "IDVARVAL",
    "QNAM", "QLABEL", "QVAL", "QORIG"
  )
  maybe <- c("QEVAL")

  ext_supp_col <- setdiff(names(supp), c(supp_cols, maybe))
  mis_supp_col <- setdiff(supp_cols, names(supp))

  if (length(ext_supp_col) > 0 || length(mis_supp_col) > 0) {
    cli::cli_abort(c(
      "x" = "Supplemental Qualifier dataset does not comply with CDISC SDTM structure.",
      if (length(ext_supp_col) > 0) {
        c(
          "!" = "Unexpected columns detected (must be removed):",
          "i" = "{.val {ext_supp_col}}"
        )
      },
      if (length(mis_supp_col) > 0) {
        c(
          "!" = "Required columns are missing:",
          "i" = "{.val {mis_supp_col}}"
        )
      }
    ))
  }

  # Verify qnam values from supp do not conflict with main dataset
  all_qnam <- unique(supp$QNAM)
  existing_qnam <- intersect(all_qnam, names(dataset))

  if (length(existing_qnam) > 0) {
    cli::cli_abort(c(
      "x" = "Column name conflict detected when combining SUPP data.",
      "!" = "The following QNAM values would create variables that already exist in the dataset:",
      "x" = "{.val {existing_qnam}}",
      "i" = "Renaming or removing these SUPP qualifiers is required before merging."
    ))
  }

  # In order to prevent issues when there are multiple IDVARS we need to merge
  # each IDVAR into the domain separately (otherwise there is problems when the
  # two IDVARS don't overlap)
  supp_wides_prep <-
    supp %>%
    select(-any_of(c("QLABEL", "QORIG", "QEVAL"))) %>% # Removing columns not for the main dataset
    rename(DOMAIN = RDOMAIN) %>%
    group_by(IDVAR, QNAM) %>% # For when there are multiple IDs
    group_split()

  supp_wides <- purrr::pmap(.l = list(supp = supp_wides_prep), .f = combine_supp_make_wide)

  # Verify that each idvar in supp domain is present in the main dataset
  idvars <- sapply(supp_wides, function(x) x$IDVAR[1])
  invalid_idvars <- unique(
    idvars[
      !idvars %in% names(dataset) &
        !is.na(idvars) &
        idvars != "NA"
    ]
  )

  if (length(invalid_idvars) > 0) {
    supp_wides <- supp_wides[
      vapply(supp_wides, function(x) !(x$IDVAR[1] %in% invalid_idvars), logical(1))
    ]

    cli::cli_warn(c(
      "!" = "The following {.field IDVAR} values from the SUPP dataset will not be joined:",
      "x" = "{.val {invalid_idvars}}",
      "i" = "They do not exist as variables in the main dataset."
    ))
  }

  # If all idvars are invalid then return the main dataset
  if (length(supp_wides) == 0) {
    return(dataset)
  }

  ret <- reduce(.x = append(list(dataset), supp_wides), .f = combine_supp_join)
  ret$IDVARVAL <- NULL

  labels_to_add <- unique(supp[, c("QNAM", "QLABEL")])
  for (current_idx in seq_len(nrow(labels_to_add))) {
    current_col <- labels_to_add$QNAM[current_idx]
    current_label <- labels_to_add$QLABEL[current_idx]
    attr(ret[[current_col]], "label") <- current_label
  }

  ret
}

# Create a wide version of `supp` for merging into the source dataset.
combine_supp_make_wide <- function(supp) {
  stopifnot(length(unique(supp$IDVAR)) == 1)
  stopifnot(length(unique(supp$QNAM)) == 1)
  # Get the IDVAR value to allow for renaming of IDVARVAL
  id_var <- unique(supp$IDVAR)

  wide_x <-
    supp %>%
    pivot_wider(
      names_from = QNAM,
      values_from = QVAL
    )
  wide_x$QNAM <- unique(supp$QNAM)
  if (!is.na(id_var) && id_var != "") {
    wide_x <-
      wide_x %>%
      mutate(IDVARVAL = str_trim(as.character(IDVARVAL)))
  } else {
    wide_x$IDVARVAL <- NULL
  }
  wide_x
}

combine_supp_join <- function(dataset, supp) {
  current_idvar <- unique(supp$IDVAR)
  current_qnam <- unique(supp$QNAM)
  stopifnot(length(current_idvar) == 1)
  stopifnot(length(current_qnam) == 1)

  by <- intersect(names(supp), c("STUDYID", "DOMAIN", "USUBJID", "IDVARVAL"))
  supp_prep <- supp %>% select(-QNAM, -IDVAR)
  new_column <- setdiff(names(supp_prep), by)
  stopifnot(length(new_column) == 1)

  # Prepare IDVARVAL
  ret <- dataset
  if ("IDVARVAL" %in% by) {
    # Match the IDVARVAL column in supp
    ret$IDVARVAL <- str_trim(as.character(ret[[current_idvar]]))
  } else {
    # A dummy column that can be removed later
    ret$IDVARVAL <- FALSE
  }

  # Put the new data in
  if (new_column %in% names(dataset)) {
    # Patch the data
    mask_na_ret_before <- is.na(ret[[new_column]])
    ret_orig <- ret
    ret <- dplyr::rows_patch(x = ret, y = supp_prep, by = by)
    mask_na_ret_after <- is.na(ret[[new_column]])

    expected_na_difference <- sum(!is.na(supp_prep[[new_column]]))
    actual_na_difference <- sum(!mask_na_ret_after) - sum(!mask_na_ret_before)
    if (expected_na_difference != actual_na_difference) {
      cli::cli_abort(c(
        "X" = "SUPP domain merge failed due to inconsistent key mapping.",
        "i" = "While processing {.field QNAM} = {.val {current_qnam}} with {.field IDVAR} = {.val {current_idvar}}.",
        "i" = "This usually indicates that multiple records in the SUPP domain map to the same parent record.",
        "i" = "Each combination of STUDYID, USUBJID, IDVAR, and IDVARVAL should uniquely identify a row.",
        "i" = "Check for duplicate or conflicting mappings in SUPP-- for this QNAM."
      ), call = rlang::caller_env(n = 3)) # caller_env depth of 3 is "combine_supp"
    }
  } else {
    # Verify that nothing will be missed
    missing <- dplyr::anti_join(supp_prep, ret, by = by)

    # Add a message for when there are rows in the dataset that didn't get merged
    if (nrow(missing) > 0) {
      missing_display <- missing %>%
        dplyr::transmute(
          USUBJID,
          !!current_idvar := IDVARVAL
        )

      cli::cli_warn(c(
        "x" = "Some SUPP records were not merged into the main dataset.",
        "!" = "Unmatched rows:",
        sprintf(
          "{.strong USUBJID}: {.val %s}  |  {.strong %s}: {.val %s}",
          missing_display$USUBJID,
          current_idvar,
          missing_display[[current_idvar]]
        )
      ))
    }

    # join the data
    ret <- left_join(ret, supp_prep, by = by)
  }
  ret
}

#' Handles the combining of datasets and supps for a single IDVAR
#'
#' @param dataset Domain dataset
#' @param supp Supplemental Qualifier dataset with a single IDVAR
#'
#' @return list of datasets
#' @noRd
combine_supp_by_idvar <- function(dataset, supp) {
  # Get the IDVAR value to allow for renaming of IDVARVAL
  id_var <- unique(supp$IDVAR)

  wide_x <- supp %>%
    pivot_wider(
      names_from = QNAM,
      values_from = QVAL
    ) %>%
    select(-IDVAR)

  if (!is.na(id_var) && id_var != "") {
    id_var_sym <- sym(id_var)

    by <- c("STUDYID", "DOMAIN", "USUBJID", "IDVARVAL")
    wide_x <- wide_x %>%
      mutate(IDVARVAL = as.character(IDVARVAL) %>%
        str_trim())
    #  Make a dummy IDVARVAL variable to merge on, won't effect the dataset
    dataset_chr <- dataset %>%
      mutate(IDVARVAL = as.character(!!id_var_sym) %>%
        str_trim())

    out <- left_join(dataset_chr, wide_x,
      by = by
    ) %>%
      select(-IDVARVAL)
    missing <- anti_join(wide_x, dataset_chr, by = by)

    # Add message for when there are rows in the supp that didn't get merged
    if (nrow(missing) > 0) {
      missing_txt <- capture.output(missing %>%
        select(USUBJID, !!sym(id_var)) %>%
        print()) %>%
        paste0(collapse = "\n")
      stop(
        paste0(
          "Not all rows of the Supp were merged. The following rows are missing:\n",
          missing_txt
        ),
        call. = FALSE
      )
    }
  } else {
    wide_x <- wide_x %>%
      select(-IDVARVAL)
    out <- left_join(dataset, wide_x,
      by = c("STUDYID", "DOMAIN", "USUBJID")
    )
  }
  out
}
