s2dv_cube.R

#'Creation of a 's2dv_cube' object
#'
#'@description This function allows to create an 's2dv_cube' object by passing 
#'information through its parameters. This function will be needed if the data 
#'hasn't been loaded using CST_Load or has been transformed with other methods. 
#'An 's2dv_cube' object has many different components including metadata. This 
#'function will allow to create 's2dv_cube' objects even if not all elements 
#'are defined and for each expected missed parameter a warning message will be 
#'returned.
#'
#'@author Perez-Zanon Nuria, \email{nuria.perez@bsc.es}
#'
#'@param data An array with any number of named dimensions, typically an object
#'  output from CST_Load, with the following dimensions: dataset, member, sdate, 
#'  ftime, lat and lon.
#'@param lon An array with one dimension containing the longitudes and 
#'  attributes: dim, cdo_grid_name, data_across_gw, array_across_gw, first_lon, 
#'  last_lon and projection.
#'@param lat An array with one dimension containing the latitudes and 
#'  attributes: dim, cdo_grid_name, first_lat, last_lat and projection.
#'@param other_coords A named list of vectors with corresponding dimension 
#'  coordinates different from lon and lat.
#'@param Variable A list of two elements: \code{varName} a character string 
#'  indicating the abbreviation of a variable name and \code{level} a character 
#'  string indicating the level (e.g., "2m"), if it is not required it could be
#'  set as NULL.
#'@param Datasets A named list with the dataset model with two elements: 
#'  \code{InitiatlizationDates}, containing a list of the start dates for each 
#'  member named with the names of each member, and \code{Members} containing a 
#'  vector with the member names (e.g., "Member_1")
#'@param Dates A named list of one to two elements: The first element, 
#'  \code{start}, is an array of dimensions (sdate, time) with the POSIX initial 
#'  date of each forecast time of each starting date. The second element, 
#'  \code{end} (optional), is an array of dimensions (sdate, time) with the POSIX
#'  final date of each forecast time of each starting date.
#'@param time_dims Deprecated and will be removed in the next release. Please 
#'  use dimension names in 'Dates' parameter.
#'@param when A time stamp of the date issued by the Load() call to obtain the 
#'  data.
#'@param source_files A vector of character strings with complete paths to all 
#'  the found files involved in the Load() call.
#'
#'@return The function returns an object of class 's2dv_cube'.
#'
#'@seealso \code{\link[s2dv]{Load}} and \code{\link{CST_Load}}
#'@examples
#'exp_original <- 1:100
#'dim(exp_original) <- c(lat = 2, time = 10, lon = 5)
#'exp1 <- s2dv_cube(data = exp_original)
#'class(exp1)
#'exp2 <- s2dv_cube(data = exp_original, lon = seq(-10, 10, 5), lat = c(45, 50)) 
#'class(exp2)
#'exp3 <- s2dv_cube(data = exp_original, lon = seq(-10, 10, 5), lat = c(45, 50),
#'                  Variable = list(varName = 'tas', level = '2m')) 
#'class(exp3)
#'exp4 <- s2dv_cube(data = exp_original, lon = seq(-10, 10, 5), lat = c(45, 50),
#'                  Variable = list(varName = 'tas', level = '2m'),
#'                  Dates = list(start = paste0(rep("01", 10), rep("01", 10), 1990:1999),
#'                               end = paste0(rep("31", 10), rep("01", 10), 1990:1999)))  
#'class(exp4)
#'dates = as.POSIXct(paste0(rep("01", 10), rep("01", 10), 1990:1999), format = "%d%m%Y")
#'dim(dates) <- c(time = 10)
#'attr(dates, 'start') <- as.POSIXct(paste0(rep("01", 10), rep("01", 10), 1990:1999), format = "%d%m%Y")
#'attr(dates, 'end') <- as.POSIXct(paste0(rep("31", 10), rep("01", 10), 1990:1999), format = "%d%m%Y")
#'exp5 <- s2dv_cube(data = exp_original, lon = seq(-10, 10, 5), lat = c(45, 50),
#'                  Variable = list(varName = 'tas', level = '2m'),
#'                  Dates = dates,
#'                  when = "2019-10-23 19:15:29 CET")  
#'class(exp5)
#'exp6 <- s2dv_cube(data = exp_original, lon = seq(-10, 10, 5), lat = c(45, 50),
#'                  Variable = list(varName = 'tas', level = '2m'),
#'                  Dates = dates,
#'                  when = "2019-10-23 19:15:29 CET", 
#'                  source_files = c("/path/to/file1.nc", "/path/to/file2.nc"))
#'class(exp6)
#'exp7 <- s2dv_cube(data = exp_original, lon = seq(-10, 10, 5), lat = c(45, 50),
#'                  Variable = list(varName = 'tas', level = '2m'),
#'                  Dates = dates,
#'                  when = "2019-10-23 19:15:29 CET", 
#'                  source_files = c("/path/to/file1.nc", "/path/to/file2.nc"),
#'                  Datasets = list(
#'                    exp1 = list(InitializationsDates = list(Member_1 = "01011990", 
#'                                                            Members = "Member_1"))))  
#'class(exp7)
#'dim(exp_original) <- c(dataset = 1, member = 1, sdate = 2, ftime = 5, lat = 2, lon = 5)
#'exp8 <- s2dv_cube(data = exp_original, lon = seq(-10, 10, 5), lat = c(45, 50),
#'                  Variable = list(varName = 'tas', level = '2m'),
#'                  Dates = dates)  
#'class(exp8)
#'@export
s2dv_cube <- function(data, lon = NULL, lat = NULL, other_coords = NULL, Variable = NULL, 
                      Datasets = NULL, Dates = NULL, time_dims = NULL, when = NULL, 
                      source_files = NULL) {

  # data
  if (is.null(data) | !is.array(data) | is.null(names(dim(data)))) {
    stop("Parameter 'data' must be an array with named dimensions.")
  }
  dims <- dim(data)
  # dims
  dims <- dim(data)
  ## other_coords
  coords <- sapply(names(dims), function(x) NULL)
  if (!is.null(other_coords)) {
    if (!is.list(other_coords)) {
      stop(paste0("Parameter 'other_coords' must be a named list with corresponding dimension ",
                  "coordinates vectors."))
    }
    if (any(names(other_coords) %in% names(dim(data)))) {
      other_coords <- other_coords[which(names(other_coords) %in% names(dim(data)))]
    } else {
      warning("Elements in 'other_coords' don't coincide with any dimensions in 'data'")
    }
    for (i_coord in names(dims)) {
      if (i_coord %in% names(other_coords)) {
        if (length(other_coords[[i_coord]]) == dims[i_coord]) {
          coords[[i_coord]] <- other_coords[[i_coord]]
        }
      }
    }
  }
  ## lon
  if (is.null(lon)) {
    if (any(.KnownLonNames() %in% names(dims))) {
      warning("Parameter 'lon' is not provided but data contains a ",
              "longitudinal dimension.")
    } else {
      warning("Parameter 'lon' is not provided so the data is from an ",
              "unknown location.")
    }
  } else {
    if (any(.KnownLonNames() %in% names(dims))) {
      name_lon <- names(dims[names(dims) %in% .KnownLonNames()])
      if (dims[name_lon] != length(lon) & dims[name_lon] != 1) {
           stop("Length of parameter 'lon' doesn't match the length of ",
                "longitudinal dimension in parameter 'data'.")
      }
      if (!is.null(names(dim(lon))) && !identical(name_lon, names(dim(lon)))) {
        stop("The dimension name of parameter 'lon' is not consistent ",
             "with data dimension name for longitude.")
      } else {
        dim(lon) <- length(lon)
        names(dim(lon)) <- name_lon
      }
    } else if (!is.null(names(dim(lon))) && names(dim(lon)) %in% names(dims)) {
      name_lon <- names(dims[names(dim(lon))])
      if (length(lon) != dims[name_lon]) {
        stop("The length of the longitudinal dimension doesn't match ", 
             "with the length of 'lon' parameter.")
      } else {
        warning(paste0("Detected the longitude dimension name to be ", names(dim(lon)), 
                       ", which is not the expected names ('lon' or 'longitude') by s2dv_cube."))
      }
    } else {
      stop("Parameter 'lon' is provided but data doesn't contain a ",
           "longitudinal dimension.")
    }
    coords[[name_lon]] <- lon
  }
  ## lat
  if (is.null(lat)) {
    if (any(.KnownLatNames() %in% names(dims))) {
      warning("Parameter 'lat' is not provided but data contains a ",
              "latitudinal dimension.")
    } else {
      warning("Parameter 'lat' is not provided so the data is from an ",
              "unknown location.")
    }
  } else {
    if (any(.KnownLatNames() %in% names(dims))) {
      name_lat <- names(dims[names(dims) %in% c('lat', 'latitude')])
      if (dims[name_lat] != length(lat) & dims[name_lat] != 1) {
           stop("Length of parameter 'lat' doesn't match the length of ",
                "longitudinal dimension in parameter 'data'.")
      }
      if (!is.null(names(dim(lat))) && !identical(name_lat, names(dim(lat)))) {
        stop("The dimension name of parameter 'lat' is not consistent ",
             "with data dimension name for latitude.")
      } else {
        dim(lat) <- length(lat)
        names(dim(lat)) <- name_lat
      }
    } else if (!is.null(names(dim(lat))) && names(dim(lat)) %in% names(dims)) {
      name_lat <- names(dims[names(dim(lat))])
      if (length(lat) != dims[name_lat]) {
        stop("The length of the latgitudinal dimension doesn't match ", 
             "with the length of 'lat' parameter.")
      } else {
        warning(paste0("Detected the latitude dimension name to be ", names(dim(lat)), 
                       ", which is not the expected names ('lat' or 'latitude') by s2dv_cube."))
      }
    } else {
      stop("Parameter 'lat' is provided but data doesn't contain a ",
           "latitudinal dimension.")
    }
    coords[[name_lat]] <- lat
  }
  # attrs
  attrs <- list()
  ## Variable
  if (is.null(Variable)) {
    warning("Parameter 'Variable' is not provided so the metadata ",
            "of 's2dv_cube' object will be incomplete.")
  } else {
    if (!is.list(Variable)) {
       Variable <- list(Variable)
    }
    # if (names(Variable)[1] != 'varName' | names(Variable)[2] != 'level') {
    #    warning("The name of the first element of parameter 'Variable' is ",
    #            "expected to be 'varName' and the second 'level'.")
    # }
    # if (!is.character(Variable[[1]])) {
    #    warning("The element 'Varname' of parameter 'Variable' must be ",
    #            "a character.")
    # }
    attrs[['Variable']] <- Variable
  }
  # Datasets
  if (is.null(Datasets)) {
    warning("Parameter 'Datasets' is not provided so the metadata ",
            "of 's2dv_cube' object will be incomplete.")
  } else {
    attrs[['Datasets']] <- Datasets
  }
  # time_dims
  if (!is.null(time_dims)) {
    warning(paste0("Parameter 'time_dims' is deprecated and will be removed in the next release."))
  }
  # Dates
  if (is.null(Dates)) {
    if (any(.KnownTimeNames() %in% names(dims))) {
      warning("Parameter 'Dates' is not provided but data contains a ",
              "temporal dimension.")
    }
  } else {
    if (!is.array(Dates)) {
      stop("Parameter 'Dates' must be an array with named time dimensions.")
    }
    attrs[['Dates']] <- Dates
  }
  # when
  if (is.null(when)) {
    warning("Parameter 'when' is not provided so the metadata ",
            "of 's2dv_cube' object will be incomplete.")
  } else {
    attrs[['when']] <- when
  }
  # source_files
  if (is.null(source_files)) {
    warning("Parameter 'source_files' is not provided so the metadata ",
            "of 's2dv_cube' object will be incomplete.")
  } else {
    attrs[['source_files']] <- source_files
  }
  # object
  object <- list(data = data, dims = dims, coords = coords, attrs = attrs)
  class(object) <- 's2dv_cube'
  return(object)
}