R/internal.R

In poissonconsulting/nrp: Kootenay Lake Nutrient Restoration Program Data Loading

named_list <- function() {
  list(x = 1)[-1]
}

all_na <- function(data) {
  apply(data, 1, function(x) {
    all(is.na(x))
  })
}

fill_date_query <- function(table, col, end, start, connection) {
  if (is.null(start) && is.null(end)) {
    end <- DBI::dbGetQuery(connection, paste0("SELECT MAX(`", col, "`) FROM ", table))[1, 1]
    start <- as.character(dttr2::dtt_add_years(dttr2::dtt_date(end), -1))
  } else if (is.null(start) && !is.null(end)) {
    start <- DBI::dbGetQuery(connection, paste0("SELECT MIN(`", col, "`) FROM ", table))[1, 1]
  } else if (!is.null(start) && is.null(end)) {
    end <- DBI::dbGetQuery(connection, paste0("SELECT MAX(`", col, "`) FROM ", table))[1, 1]
  }
  c("start_date" = start, "end_date" = end)
}

fill_date_time_query <- function(table, col, end, start, connection) {
  if (is.null(start) && is.null(end)) {
    end <- DBI::dbGetQuery(connection, paste0("SELECT MAX(`", col, "`) FROM ", table))[1, 1]
    start <- as.character(dttr2::dtt_add_years(dttr2::dtt_date_time(end), -1))
  } else if (is.null(start) && !is.null(end)) {
    start <- DBI::dbGetQuery(connection, paste0("SELECT MIN(`", col, "`) FROM ", table))[1, 1]
  } else if (!is.null(start) && is.null(end)) {
    end <- DBI::dbGetQuery(connection, paste0("SELECT MAX(`", col, "`) FROM ", table))[1, 1]
  }
  c("start_date_time" = start, "end_date_time" = end)
}

clean_input_cols <- function(data, lookup) {
  missing_cols <- names(lookup)[!names(lookup) %in% names(data)]
  excess_cols <- names(data)[!names(data) %in% names(lookup)]

  if (length(missing_cols) > 0) {
    warning <- paste(
      "The input data is missing the following columns which will be assigned NA: ",
      paste(missing_cols, collapse = ", ")
    )
    warning(warning)
    data[missing_cols] <- NA
  }

  if (length(excess_cols) > 0) {
    warning <- paste(
      "The input data contains the following unnecessary columns that will be discarded: ",
      paste(excess_cols, collapse = ", ")
    )
    warning(warning)
    data[excess_cols] <- NULL
  }

  reclassed <- map_dfc(names(data), function(x) {
    col <- dplyr::pull(data, x)
    new_class <- as.character(lookup[x])

    if (new_class == "date") {
      col <- dttr2::dtt_date(as.integer(col), origin = "1899-12-30") %>%
        tryCatch(
          warning = function(w) {
            if (str_detect(w$message, "NAs introduced by coercion")) {
              err("Ivalid date format for column: '", x, "'.please ensure column is formatted as 'date' (yyyy-mm-dd) in Excel.")
            }
            dttr2::dtt_date(as.integer(col), origin = "1899-12-30") %>%
              suppressWarnings()
          },
          error = function(e) err("Ivalid date format for column: '", x, "'. Please ensure column is formatted as 'date' (yyyy-mm-dd) in Excel.")
        )
    } else {
      col <- methods::as(col, new_class) %>%
        tryCatch(warning = function(w) {
          if (str_detect(w$message, "NAs introduced by coercion")) {
            err("NAs introduced when cleaning data columns. Please Ensure all values in excel column: '", x, "' are type: '", new_class, "'.")
          }
          methods::as(col, new_class) %>% suppressWarnings()
        })

      col <- suppressWarnings(methods::as(col, new_class))
    }

    col <- as.data.frame(col)
    names(col) <- x
    as_tibble(col)
  })

  select(reclassed, all_of(names(lookup)))
}

nrp_install_unit <- function(x) {
  result <- units::install_unit(x) %>%
    suppressWarnings() %>%
    try(silent = TRUE)

  if (length(result) && !str_detect(result, "already maps to existing but different unit")) {
    err("Unit", x, " could not be installed.")
  }
}

paste_vec <- function(x) paste0("'", unique(x), "'", collapse = ", ")

ask_user <- function(msg, auto_yes = getOption("nrp.ask_user.auto_yes", FALSE)) {
  chk::chk_chr(msg)
  chk::chk_flag(auto_yes)

  if (auto_yes) {
    return(TRUE)
  } else {
    yesno::yesno(msg)
  }
}