R/internal_tests.R

In ptaconet/opendapr: Fast and Efficient Access to MODIS Earth Observation Data

#' @name .testIfCollExists
#' @title Test if collection specified exists
#' @noRd
#'

.testIfCollExists <- function(collection) {
  if (!inherits(collection, "character") || length(collection) != 1) {
    stop("Argument collection must be a character string of length 1")
  }

  collection <- opendapMetadata_internal$collection[which(opendapMetadata_internal$collection == collection)]

  if (length(collection) == 0) {
    stop("The collection that you specified does not exist. Check mf_list_collections() to see which collections are implemented\n")
  }
}

#' @name .testIfVarExists
#' @title Test if variable exists given other variables
#' @noRd
#'

.testIfVarExists <- function(specified_variables, existing_variables) {
  diff_vars <- NULL
  diff_vars <- setdiff(specified_variables, existing_variables)
  if (length(diff_vars) > 0) {
    stop("Specified variables do not exist or are not extractable for the specified collection. Use the function mf_list_variables to check which variables are available and extractable for the collection\n")
  }
}

# .testIfVarExists2<-function(collection,specified_variables,credentials=NULL){
#  variables <- NULL
#  .testIfCollExists(collection)
#  .testLogin(credentials)
#  variables <- mf_list_variables(collection,credentials)
#  variables <- variables$name
#  .testIfVarExists2(variables,specified_variables)
# }

#' @name .testLogin
#' @title Test login, else log
#' @noRd

.testLogin <- function(credentials = NULL) {
  mf_login <- NULL

  if (!is.null(credentials) || is.null(getOption("earthdata_mf_login"))) {
    mf_login <- mf_login(credentials)
    return(mf_login)
  }
}

#' @name .testRoi
#' @title Test roi
#' @noRd

.testRoi <- function(roi) {
  # if(!inherits(roi,"sf") || as.character(unique(sf::st_geometry_type(roi)))!="POLYGON" || !("id" %in% colnames(roi)) || !("geom" %in% colnames(roi)) || length(which(is.na(roi$id))) || length(which(is.na(roi$geom)))){stop("Argument roi must be an object of class sf or sfc with POLYGON-type feature geometry and at least two columns : 'id' and 'geom' that must not be NULL or NA")}
  if (!inherits(roi, "sf")) {
    stop("Argument roi must be an object of class sf or sfc")
  }
  if (as.character(unique(sf::st_geometry_type(roi))) != "POLYGON") {
    stop("Argument roi must have a POLYGON-type feature geometry")
  }
  if (!("id" %in% colnames(roi)) || length(which(is.na(roi$id)))) {
    stop("Argument roi must have at least two columns : 'id' (character string) and a geometry column that must not be NULL or NA")
  }
}

#' @name .testTimeRange
#' @title Test time range
#' @noRd

.testTimeRange <- function(time_range) {
  if (!inherits(time_range, "Date") && !inherits(time_range, "POSIXlt") || length(time_range) > 2 || is.na(time_range[1]) || is.na(time_range[2])) {
    stop("Argument time_range is not of class Date or POSIXlt or is not of length 1 or 2 \n")
  }
  if (length(time_range) == 2 && time_range[1] > time_range[2]) {
    stop("Time end is superior to time start in time_range argument \n")
  }
}

#' @name .testTimeRangeAvDates
#' @title Test that time range provided is ok with the collection
#' @noRd

.testTimeRangeAvDates <- function(time_range, collection) {
  start_date <- opendapMetadata_internal$start_date[which(opendapMetadata_internal$collection == collection)]
  if (time_range[1] < as.Date(start_date)) {
    stop("Time start in time_range argument is out of the temporal extent of the collection. Please modify time start.\n")
  }
  end_date <- opendapMetadata_internal$end_date[which(opendapMetadata_internal$collection == collection)]
  if(end_date != "ongoing"){
    if (length(time_range) == 2 && (time_range[2] > as.Date(end_date) | time_range[2] > Sys.Date())) {
     stop("Time end in time_range argument is out of the temporal extent of the collection. Please modify time end.\n")
    }
  }
}

#' @name .testFormat
#' @title Test format
#' @noRd

.testFormat <- function(output_format) {
  if (!(output_format %in% c("nc4", "ascii", "json"))) {
    stop("Specified output format is not valid. Please specify a valid output format \n")
  }
}

#' @name .testInternetConnection
#' @title Test internet connection
#' @importFrom curl has_internet
#' @noRd

.testInternetConnection <- function() {
  if (!curl::has_internet()) {
    stop("Internet connection is required. Are you connected to the Internet ?\n")
  }
}