R/subset.R
In dankelley/argoFloats: Analysis of Oceanographic Argo Floats
## vim:textwidth=128:expandtab:shiftwidth=4:softtabstop=4
## OLD use_sf_package <- TRUE
#' Subset an argoFloats Object
#'
#' Return a subset of an [`argoFloats-class`] object. This applies
#' only to objects of type `"index"`, as created with [getIndex()] or `subset()`
#' acting on such a value, or of type `"argos"`, as created with [readProfiles()].
#' (It cannot be used on objects of type `"profiles"`, as created with [getProfiles()].)
#' There are two ways to use `subset()`. **Method 1.** supply
#' the `subset` argument. This may be a logical vector indicating
#' which entries to keep (by analogy to the base-R `subset()`
#' function) or it may be an integer vector holding the indices of entries to
#' be retained. **Method 2.** do not supply `subset`. In this
#' case, the action is determined by the third (`...`)
#' argument; see \sQuote{Details}.
#'
#' The possibilities for the `...` argument are as follows.
#'
#' 1. An integer vector giving indices to keep.
#'
#' 2. A list named `circle` with numeric elements named `longitude`,
#' `latitude` and `radius`. The first two give the center of
#' the subset region, and the third gives the radius of
#' that region, in kilometers.
#'
#' 3. A list named `rectangle` that has elements named
#' `longitude` and `latitude`, two-element numeric vectors
#' giving the western and eastern, and southern and northern
#' limits of the selection region.
#'
#' 4. A list named `polygon` that has elements named `longitude` and `latitude`
#' that are numeric vectors specifying a polygon within which profiles
#' will be retained. The polygon must not be self-intersecting,
#' and an error message will be issued if it is. If the polygon is not closed
#' (i.e. if the first and last points do not coincide) the first point is pasted
#' onto the end, to close it.
#'
#' 5. A vector or list named `parameter` that holds character values that
#' specify the names of measured parameters to keep. See section 3.3 of
#' Reference 1 for a list of parameters.
#'
#' 6. A list named `time` that has elements `from` and `to` that are either
#' POSIXt times, or character strings that `subset()` will convert to
#' POSIXt times using [as.POSIXct()] with `tz="UTC"`.
#'
#' 7. A list named `institution` that holds a single character element that
#' names the institution. The permitted values are:
#' `"AO"` for Atlantic Oceanographic and Meteorological Laboratory;
#' `"BO"` for British Oceanographic Data Centre;
#' `"CS"` for Commonwealth Scientific and Industrial Research Organization;
#' `"HZ"` for China Second Institute of Oceanography;
#' `"IF"` for Ifremer, France;
#' `"IN"` for India National Centre for Ocean Information Services;
#' `"JA"` for Japan Meteorological Agency;
#' `"KM"` for Korea Meteorological Agency;
#' `"KO"` for Korea Ocean Research and Development Institute;
#' `"ME"` for Marine Environment Data Section; and
#' `"NM"` for National Marine Data & Information Service.
#'
#' 8. A list named `deep` that holds a logical value indicating whether argo floats
#' are deep argo (i.e. `profiler_type` 849, 862, and 864).
#'
#' 9. A list named `ID` that holds a character value specifying a float identifier.
#'
#' 10. A list named `ocean` that holds a single character element that names the
#' ocean. The permitted values are:
#' `"A"` for Atlantic Ocean Area, from 70 W to 20 E,
#' `"P"` for Pacific Ocean Area, from 145 E to 70 W, and
#' `"I"` for Indian Ocean Area, from 20 E to 145 E.
#'
#' 11. A character value named `dataMode`, equal to either `realtime` or `delayed`,
#' that selects whether to retain real-time data or delayed data. There are two
#' possibilities, depending on the `type` of the `x` argument.
#' **Case 1.** If `x` is of `type="index"`, then the subset is done by looking for the letters
#' `R` or `D` in the source filename. Note that a file in the
#' latter category may contain some profiles that are of delayed mode *and also*
#' some profiles that are of `realtime` or `adjusted` mode.
#' **Case 2.** If `x` is
#' of type `argos`, then the subset operation is done for each profile within
#' the dataset. Sometimes this will yield data arrays with zero columns.
#'
#' 12. An integer or character value named `cycle` that specifies which cycles are to be retained.
#' This is done by regular-expression matching of the filename, looking between the
#' underline character (`"_"`) and the suffix (`.nc`), but note that the expression
#' is made up of a compulsory component comprising 3 or 4 digits, and an optional
#' component that is either blank or the character `"D"` (which designates a
#' descending profile). Thus, `001` will match both `*_001.nc` and `*_001D.nc`.
#' Note this can be used for both `"index"` and `"argos"` types.
#'
#' 13. A character value named `direction`, equal to either "descent" or "ascent",
#' that selects whether to retain data from the ascent or decent phase.
#'
#' 14. An integer value named `profile` that selects which profiles
#' to retain. Note that this type of subset is possible only
#' for objects of type `"argos"`.
#'
#' 15. An integer value named `cycle` that selects which cycles
#' to retain.
#'
#' 16. A character value named `dataStateIndicator`, equal to either "0A", "1A",
#' "2B", "2B+", "2C", "2C+", "3B", or "3C" that selects which `dataStateIndicator`
#' to keep (see table 6 of Reference 1 for details of these codes).
#' This operation only works for objects of type `"argos"`.
#'
#' 17. A list named `section` that has four elements:
#' `longitude`,`latitude`, `width`, and `segments`. The first two of these
#' are numeric vectors that define the spine of the section, in degrees East
#' and North, respectively. These are both mandatory, while both `width` and `segments`
#' are optional. If given, `width` is taken as maximal distance between an Argo
#' and the spine, for that float to be retained. If `width` is not given, it
#' defaults to 100km. If given, `segments` is either `NULL` or a positive
#' integer. Setting `segments` to `NULL` will cause the float-spine distance
#' to be computed along a great-circle route. By contrast, if `segments` is an
#' integer, then the spine is traced using `stats::approx()`, creating
#' `segments` new points. If `segments` is not provided, it defaults to 100.
#'
#' In all cases, the notation is that longitude is positive
#' for degrees East and negative for degrees West, and that latitude
#' is positive for degrees North and negative for degrees South.
#' For more on this function, see Kelley et al. (2021).
#'
#' @param x an [`argoFloats-class`] object as created by [getIndex()].
#'
#' @param subset optional numerical or logical vector that indicates which
#' indices of `x@data$index` to keep (example 1).
#'
#' @param ... the first entry here must be either (a) a list named `circle`,
#' `rectangle`, `polygon`, `parameter`, `time`, `institution`,
#' `ID`,`ocean`,`dataMode`,`cycle`, `direction`, `profile`, or `section`.
#' (examples 2 through 8, and 10 through 17),
#' or (b) a logical value named `deep` (example 9). Optionally, this entry
#' may be followed by second entry named `silent`, which is a logical
#' value indicating whether to prevent the printing of messages that
#' indicate the number (and percentage) of data that are kept
#' during the subsetting operation.
#' See \dQuote{Details} and \dQuote{Examples}.
#'
#' @return An [`argoFloats-class`] object, restricted as indicated.
#'
#' @examples
#' library(argoFloats)
#' data(index)
#' data(indexSynthetic)
#'
#' # Subset to the first 3 profiles in the (built-in) index
#' indexFirst3 <- subset(index, 1:3)
#'
#' # Subset to a circle near Abaco Island
#' indexCircle <- subset(index, circle = list(longitude = -77.5, latitude = 27.5, radius = 50))
#' #
#' # # NOTE: this example was removed because it requires using tempdir, which
#' # # is not something we want to encourage, since it goes against the whole idea
#' # # of caching.
#' # # Example 2B: subset a 300 km radius around Panama using "maps" package
#' # # This example requires downloading.
#' #
#' \donttest{
#' # library("maps")
#' # data(world.cities)
#' # ai <- getIndex()
#' # panama <- subset(world.cities, name=="Panama")
#' # index1 <- subset(ai, circle=list(longitude=panama$long, latitude=panama$lat, radius=200))
#' #
#' }
#'
#' # Subset to a rectangle near Abaco Island
#' lonlim <- c(-76.5, -76)
#' latlim <- c(26.5, 27.5)
#' indexRectangle <- subset(index, rectangle = list(longitude = lonlim, latitude = latlim))
#'
#' # Subset to a polygon near Abaco Island
#' lonp <- c(-77.492, -78.219, -77.904, -77.213, -76.728, -77.492)
#' latp <- c(26.244, 25.247, 24.749, 24.987, 25.421, 26.244)
#' indexPolygon <- subset(index, polygon = list(longitude = lonp, latitude = latp))
#' #
#' # # Show some of these subsets on a map
#' # plot(index, bathymetry=FALSE)
#' # points(index2[["longitude"]], index2[["latitude"]], col=2, pch=20, cex=1.4)
#' # points(index3[["longitude"]], index3[["latitude"]], col=3, pch=20, cex=1.4)
#' # rect(lonRect[1], latRect[1], lonRect[2], latRect[2], border=3, lwd=2)
#' # points(index4[["longitude"]], index4[["latitude"]], col=4, pch=20, cex=1.4)
#' # polygon(p$longitude, p$latitude, border=4)
#'
#' # Subset to year 2019
#' index2019 <- subset(index, time = list(from = "2019-01-01", to = "2019-12-31"))
#'
#' # Subset to Canadian MEDS data
#' indexMEDS <- subset(index, institution = "ME")
#' #
#' # # NOTE: this example was removed because it requires using tempdir, which
#' # # is not something we want to encourage, since it goes against the whole idea
#' # # of caching.
#' # # Example 8: subset to a specific ID
#' # # This example requires downloading.
#' #
#' \donttest{
#' # ai <- getIndex(filename="synthetic")
#' # index9 <- subset(ai, ID="1900722")
#' #
#' }
#' #
#' # # NOTE: this example was removed because it requires using tempdir, which
#' # # is not something we want to encourage, since it goes against the whole idea
#' # # of caching.
#' # # Example 9: subset data to only include deep argo
#' # # This example requires downloading.
#' #
#' \donttest{
#' # ai <- getIndex(filename="synthetic")
#' # index8 <- subset(ai, deep=TRUE)
#' #
#' }
#' #
#' # # NOTE: this example was removed because it requires using tempdir, which
#' # # is not something we want to encourage, since it goes against the whole idea
#' # # of caching.
#' # # Example 10: subset data by ocean
#' # # This example requires downloading.
#' #
#' \donttest{
#' # ai <- getIndex()
#' # index10 <- subset(ai, circle=list(longitude=-83, latitude=9, radius=500))
#' # plot(index10, which="map", bathymetry=FALSE)
#' # atlantic <- subset(index10, ocean="A") # Subsetting for Atlantic Ocean
#' # pacific <- subset(index10, ocean="P")
#' # points(atlantic[["longitude"]], atlantic[["latitude"]], pch=20, col=2)
#' # points(pacific[["longitude"]], pacific[["latitude"]], pch=20, col=3)
#' #
#' }
#' #
#' # # NOTE: there is no example 11.
#' #
#' # # NOTE: this example was removed because it requires using tempdir, which
#' # # is not something we want to encourage, since it goes against the whole idea
#' # # of caching.
#' # # Example 11: subset by delayed time
#' # # This example requires downloading.
#' #
#' \donttest{
#' # data(indexBgc)
#' # index11 <- subset(indexBgc, dataMode="delayed")
#' # profiles <- getProfiles(index11)
#' # argos <- readProfiles(profiles)
#' # oxygen <- argos[["oxygen"]][[3]]
#' # pressure <- argos[["pressure"]][[3]]
#' # plot(oxygen, pressure, ylim=rev(range(pressure, na.rm=TRUE)),
#' # ylab="Pressure (dbar)", xlab="Oxygen (umol/kg)")
#' #
#' }
#' #
#' # # Example 12: subset by cycle
#' # data(index)
#' # index12A <- subset(index, cycle="124")
#' # index12B <- subset(index, cycle=0:2)
#' # cat("File names with cycle number 124:", paste(index12A[["file"]]), "\n")
#' # cat("File names with cycle number between 0 and 2:", paste(index12B[["file"]]), "\n")
#' #
#' #
#' # # NOTE: this example was removed because it requires using tempdir, which
#' # # is not something we want to encourage, since it goes against the whole idea
#' # # of caching.
#' # # Example 13: subset by direction
#' # # This example requires downloading.
#' #
#' \donttest{
#' # library(argoFloats)
#' # index13A <- subset(getIndex(), deep=TRUE)
#' # index13B <- subset(index13A, direction="descent")
#' # head(index13B[["file"]])
#' #
#' }
#' #
#' # # NOTE: this example was removed because it requires using tempdir, which
#' # # is not something we want to encourage, since it goes against the whole idea
#' # # of caching.
#' # # Example 14: subset by profile (for argos type)
#' # # This example requires downloading.
#' #
#' \donttest{
#' # library(argoFloats)
#' # index14A <- subset(getIndex(filename="synthetic"), ID="5903889")
#' # index14B <- subset(index14A, cycle="074")
#' # argos14A <- readProfiles(getProfiles(index14B))
#' # argos14B <- subset(argos14A, profile=1)
#' # D <- data.frame(Oxygen = argos14A[["oxygen"]],
#' # col1= argos14B[["oxygen"]][[1]])
#' #
#' }
#' #
#' # # NOTE: this example was removed because it requires using tempdir, which
#' # # is not something we want to encourage, since it goes against the whole idea
#' # # of caching.
#' # # Example 15: subset by cycle (for argos type) to create TS diagram
#' # # This example requires downloading.
#' #
#' \donttest{
#' # data("index")
#' # index15 <- subset(index, ID="1901584")
#' # profiles <- getProfiles(index15)
#' # argos <- readProfiles(profiles)
#' # plot(subset(argos, cycle="147"), which="TS")
#' #
#' }
#' #
#' # # NOTE: this example was removed because it requires using tempdir, which
#' # # is not something we want to encourage, since it goes against the whole idea
#' # # of caching.
#' # # Example 16: subset by dataStateIndicator
#' # # This example requires downloading.
#' #
#' \donttest{
#' # data("index")
#' # index16 <- subset(index, 1:40)
#' # argos <- readProfiles(getProfiles(index16))
#' # argos16A <- subset(argos, dataStateIndicator="2C")
#' # argos16B <- subset(argos, dataStateIndicator="2B")
#' #
#' }
#' #
#' # # Example 17: subset by section to create a map plot
#' # if (requireNamespace("s2")) {
#' # data("index")
#' # lon <- c(-78, -77, -76)
#' # lat <-c(27.5,27.5,26.5)
#' # index17 <- subset(index,
#' # section=list(longitude=lon, latitude=lat, width=50))
#' # plot(index17, bathymetry=FALSE)
#' # points(lon, lat, pch=21, col="black", bg="red", type="o", lwd=3)
#' # }
#'
#' # Subset to profiles with oxygen data
#' indexOxygen <- subset(indexSynthetic, parameter = "DOXY")
#'
#' # Subset to profiles with both salinity and 380-nm downward irradiance data
#' indexSalinityIrradiance <- subset(indexSynthetic, parameter = c("PSAL", "DOWN_IRRADIANCE380"))
#'
#' @references
#' 1. Carval, Thierry, Bob Keeley, Yasushi Takatsuki, Takashi Yoshida, Stephen Loch,
#' Claudia Schmid, and Roger Goldsmith. Argo User's Manual V3.3. Ifremer, 2019.
#' `doi:10.13155/29825`.
#' 2. Kelley, D. E., Harbin, J., & Richards, C. (2021). argoFloats: An R package for analyzing
#' Argo data. Frontiers in Marine Science, (8), 636922.
#' \doi{10.3389/fmars.2021.635922}
#'
#' @importFrom stats approx
#'
#' @importFrom oce geodDist
#'
#' @export
#'
#' @author Dan Kelley and Jaimie Harbin
setMethod(
f = "subset",
signature = "argoFloats",
definition = function(x, subset = NULL, ...) {
if (x@metadata$type == "profiles") {
stop("in subset,argoFloats-method() :\n subset doesn't work for type = profiles", call. = FALSE)
}
## subsetString <- paste(deparse(substitute(subset)), collapse=" ")
dots <- list(...)
dotsNames <- names(dots)
## Clear the "debug" and "silent" entries from dots, because later we insist that length(dots) be 1.
debug <- 0
if ("debug" %in% dotsNames) {
debug <- dots$debug
dots$debug <- NULL
dotsNames <- names(dots)
}
silent <- 0
if ("silent" %in% dotsNames) {
silent <- dots$silent
dots$silent <- NULL
dotsNames <- names(dots)
}
## All done with manipulating dots now.
argoFloatsDebug(debug, "subset,argoFloats-method() {\n", style = "bold", sep = "", unindent = 1)
## message("type =", x@metadata$type)
## Step 1: handle "argo" type first. Note that "subset" is ignored; rather, we insist that either
## "profile" or "cycle" be provided.
if (x@metadata$type == "argos") {
N <- x[["length"]]
if (!missing(subset)) {
N <- x[["length"]]
if (is.logical(subset)) {
if (length(subset) != x[["length"]]) {
stop("in subset,argoFloats-method() :\n 'subset' length (", length(subset), ") must match x length (", x[["length"]], ")",
call. = FALSE
)
}
keep <- which(subset)
} else if (is.numeric(subset)) {
if (!all(subset > 0)) {
stop("in subset,argoFloats-method() :\n 'subset' must consist only of positive integers",
call. = FALSE
)
}
if (any(subset > x[["length"]])) {
stop("in subset,argoFloats-method() :\n 'subset' must not contain indices beyond range of `x` (in this case, ", x[["length"]], ")",
call. = FALSE
)
}
keep <- subset
} else {
stop("in subset,argoFloats-method() :\n 'subset' must either be a logical vector or a list of indices",
call. = FALSE
)
}
res <- x
res@data$argos <- x@data$argos[keep]
if (!silent) {
message("Kept ", length(keep), " cycles (", sprintf("%.3g", 100 * length(keep) / N), "%)")
}
argoFloatsDebug(debug, "} # subset,argoFloats-method()\n", style = "bold", sep = "", unindent = 1)
return(res)
}
argoFloatsDebug(debug, "subsetting with type=\"argos\"\n")
if (length(dotsNames) == 0) {
stop("in subset,argoFloats-method() :\n must give \"profile\" , \"cycle\", or \"dataStateIndicator\" argument", call. = FALSE)
}
if (dotsNames[1] == "profile") {
argoFloatsDebug(debug, "subsetting by profile ", profile, "\n")
profile <- dots[[1]]
## Loop over all objects within the data, and within that loop look at data within the object,
## and for each of them, if its a vactor subset according to profile and if its a matrix
## subset according to profile
res <- x
argos <- x[["argos"]]
## Loop over all objects
## message("profile=",paste(profile, collapse=" "))
for (iargo in seq_along(argos)) {
argo <- argos[[iargo]]
## Handle the metadata slot
for (name in names(argo@metadata)) {
## message("name=",name)
argoFloatsDebug(debug, "subsetting metadata item named \"", name, "\"\n", sep = "")
## Pass some things through directly.
if (name %in% c("units", "filename", "flagScheme", "dataNamesOriginal")) {
next
}
item <- argo@metadata[[name]]
## Handle things that are encoded as characters in a string,
## namely "direction", "juldQC", and "positionQC".
if (name == "direction" || grepl("QC$", name)) {
## message(" -- character")
res@data$argos[[iargo]]@metadata[[name]] <- paste(strsplit(item, "")[[1]][profile], collapse = "")
} else if (is.list(item)) {
## message("list")
for (l in seq_along(item)) {
## print(dim(item[[l]]))
D <- dim(item[[l]])
if (profile > D[2]) {
stop("in subset,argoFloats-method() :\n cannot access profile ", profile, " of metadata item \"", name, "\" because its dimension is ", paste(D, collapse = " "), call. = FALSE)
}
## cat("BEFORE:\n");print(dim(res@data$argos[[iargo]]@metadata[[name]][[l]]))
res@data$argos[[iargo]]@metadata[[name]][[l]] <- item[[l]][, profile, drop = FALSE]
## cat("AFTER:\n");print(dim(res@data$argos[[iargo]]@metadata[[name]][[l]]))
}
} else if (is.vector(name)) {
## message("vector")
res@data$argos[[iargo]]@metadata[[name]] <- item[profile]
} else if (is.matrix(name)) {
## message("matrix")
res@data$argos[[iargo]]@metadata[[name]] <- item[, profile, drop = FALSE]
} else if (is.array(name)) {
argoFloatsDebug(debug, "name=", name, " has dim ", paste(dim(res@metadata[[name]]), collapse = " "), "\n")
if (length(dim(res@metadata[[name]])) <= 3) {
res@metadata[[name]] <- item[, , keep, drop = FALSE]
} else {
warning("not subsetting \"", name, "\" in metadata, because it is an array of rank > 3")
}
} else {
stop("cannot subset metadata item named \"", name, "\" because it is not a length-one string, a vector, or a matrix")
}
}
## Handle the data slot
for (name in names(argo@data)) {
item <- argo@data[[name]]
if (is.matrix(item)) {
dim <- dim(item)
if (profile > dim[2]) {
stop("in subset,argoFloats-method() :\n Only have ", dim[2], " profiles", call. = FALSE)
}
newItem <- item[, profile, drop = FALSE]
res@data$argos[[iargo]]@data[[name]] <- newItem
} else {
length <- length(item)
if (profile > length) {
stop("in subset,argoFloats-method() :\n Only have ", length, " profiles", call. = FALSE)
}
newItem <- item[profile, drop = FALSE]
res@data$argos[[iargo]]@data[[name]] <- newItem
}
}
}
argoFloatsDebug(debug, "} # subset,argoFloats-method()\n", style = "bold", sep = "", unindent = 1)
res@processingLog <- oce::processingLogAppend(
res@processingLog,
paste("subset argos type for profile=", profile)
)
return(res)
} else if (dotsNames[1] == "ID") {
istraj <- identical(x@metadata$subtype, "trajectories")
argoFloatsDebug(debug, "subsetting an argos object by ID\n")
ID <- as.character(dots[[1]]) # convert in case it is numeric
xID <- x[["ID"]]
keep <- rep(FALSE, length(xID))
for (thisID in ID) {
keep <- keep | grepl(thisID, xID)
}
if (!silent && !istraj) {
message("Kept ", sum(keep), " cycles (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
} else if (!silent && istraj) {
message("Kept ", sum(keep), " trajectories (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
}
x@data$argos <- x@data$argos[keep]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset argos type by float ID", ID)
)
} else if (dotsNames[1] == "cycle") {
argoFloatsDebug(debug, "subsetting by cycle for 'argos' type\n")
cycle <- dots[[1]]
if (!is.character(cycle) & !is.numeric(cycle)) {
stop("in subset,argoFloats-method() : \"cycle\" must be character value or numeric value", call. = FALSE)
}
## Calculate 'keep', a logical vector that will be used for the actual subsetting.
xcycle <- x[["cycle"]]
argoFloatsDebug(debug, "x[[\"cycle\"]]: ", paste(xcycle, collapse = " "), "\n")
argoFloatsDebug(debug, "cycle: ", cycle, "\n")
if (is.character(cycle)) {
argoFloatsDebug(debug, "subsetting by cycle as a character value\n")
## Here, keep is logical
keep <- rep(FALSE, length(xcycle))
for (thisCycle in cycle) {
keep <- keep | grepl(thisCycle, xcycle)
}
nkeep <- sum(keep)
} else if (is.numeric(cycle)) {
argoFloatsDebug(debug, "subsetting by cycle as a numeric value\n")
## Here, keep is integer
keep <- NULL
xcycle <- as.integer(gsub("AD", "", xcycle)) # change e.g. "123D" to "123"
for (thisCycle in cycle) {
keep <- c(keep, which(thisCycle == xcycle))
## message("thisCycle=", thisCycle, " keep=", paste(keep, collapse=" "))
}
nkeep <- length(keep)
}
if (nkeep < 1) {
warning("In subset,argoFloats-method(..., parameter) : found no profiles with given cycle(s)", call. = FALSE)
}
if (!silent) {
message("Kept ", nkeep, " cycles ")
}
x@data[[1]] <- x@data[[1]][keep]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset argos type for cycle=", cycle)
)
} else if (dotsNames[1] == "dataStateIndicator") {
argoFloatsDebug(debug, "subsetting by dataStateIndicator\n")
dataStateIndicator <- dots[[1]]
if (is.list(dots[1])) {
dataStateIndicator <- unlist(dataStateIndicator)
}
## Reference Table 6, in section 3.6, of
## Argo Data Management Team. “Argo User's Manual V3.3.”
## Ifremer, November 28, 2019. https://doi.org/10.13155/29825.
if (!is.character(dataStateIndicator)) {
stop("in subset,argoFloats-method() : \"dataStateIndicator\" must be character value", call. = FALSE)
}
## In next, [1] means we take the first element (first profile) of the cycle.
dsi <- sapply(x[["argos"]], function(a) a[["dataStateIndicator"]][1])
keep <- rep(FALSE, length(dsi))
for (dataStateIndicatorThis in dataStateIndicator) {
keep <- keep | grepl(dataStateIndicatorThis, dsi, fixed = TRUE)
## > message(dataStateIndicatorThis)
## > print(keep)
}
x@data[[1]] <- x@data[[1]][keep]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset argos type by dataStateIndicator=", dataStateIndicator)
)
} else if (dotsNames[1] == "dataMode") {
seeking <- dots$dataMode
# This testing of 'dataMode' may be overly complex
if (length(seeking) != 1) {
stop("in subset,argoFloats-method(): length of 'dataMode' must be 1", call. = FALSE)
}
if (!seeking %in% c("realtime", "adjusted", "delayed")) {
stop('in subset,argoFloats-method(): \'dataMode\' must be "realtime", "adjusted" or "delayed", not "', seeking, '"', call. = FALSE)
}
seeking <- switch(seeking,
realtime = "R",
adjusted = "A",
delayed = "D"
)
res <- x
a <- x@data$argos
for (i in seq_along(a)) {
A <- a[[i]]
keepProfile <- A[["dataMode"]] == seeking
#> message("i=", i, ", keepProfile=", paste(keepProfile, collapse=" "))
## flags
for (flagName in names(A@metadata$flags)) {
A@metadata$flags[[flagName]] <- A@metadata$flags[[flagName]][, keepProfile, drop = FALSE]
}
# dataMode
A@metadata$dataMode <- A@metadata$dataMode[keepProfile, drop = FALSE]
# data
for (dataName in names(A@data)) {
if (is.vector(A@data[[dataName]])) {
#> message("subset ", dataName, " vector from ", paste(A@data[[dataName]], collapse=" "))
A@data[[dataName]] <- A@data[[dataName]][keepProfile]
#> message(" ... to ", paste(A@data[[dataName]], collapse=" "))
} else if (is.array(A@data[[dataName]])) {
A@data[[dataName]] <- A@data[[dataName]][, keepProfile, drop = FALSE]
}
}
res@data$argos[[i]] <- A
}
res@processingLog <- oce::processingLogAppend(res@processingLog, paste(deparse(match.call()), sep = "", collapse = ""))
argoFloatsDebug(debug, "} # subset,argoFloats-method()\n", style = "bold", sep = "", unindent = 1)
return(res)
} else {
stop("in subset,argoFloats-method():\n the \"...\" argument \"", dotsNames[1], "\" is not permitted for an argos-type object. The only valid choices are \"cycle\", \"dataMode\", \"ID\", \"dataSateIndicator\" and \"profile\".", call. = FALSE)
}
}
## Step 2: Now we know the type is either "index" or "profiles". In either case,
## "subset" can be provided, so we check for its existence first.
if (missing(subset)) {
# argoFloatsDebug(debug, "no subset was given, so it must be circle=, rectangle=, or similar\n")
if (length(dots) == 0) {
stop("in subset,argoFloats-method() :\n for indices, must specify the subset, with \"subset\" argument, \"circle\",\"rectangle\", \"parameter\",\"polygon\", \"time\", \"institution\", \"deep\", \"ID\", \"ocean\", dataMode\", \"cycle\",\"direction\", or \"section\"", call. = FALSE)
}
if (length(dots) > 1) {
stop("in subset,argoFloats-method() :\n cannot give more than one method in the \"...\" argument", call. = FALSE)
}
N <- length(x@data$index[[1]]) # used in calculating percentages
if (x@metadata$type == "index") {
istraj <- identical(x@metadata$subtype, "trajectories")
if (dotsNames[1] == "circle" && !istraj) {
argoFloatsDebug(debug, "subsetting an index by circle\n")
circle <- dots[[1]]
if (!is.list(dots[1])) {
stop("in subset,argoFloats-method() :\n \"circle\" must be a list containing \"longitude\", \"latitude\" and \"radius\".", call. = FALSE)
}
if (3 != sum(c("longitude", "latitude", "radius") %in% sort(names(circle)))) {
stop("in subset,argoFloats-method() :\n \"circle\" must be a list containing \"longitude\", \"latitude\" and \"radius\"", call. = FALSE)
}
if (!requireNamespace("oce", quietly = TRUE)) {
stop("must install.packages(\"oce\") to subset by circle")
}
dist <- oce::geodDist(x[["longitude"]], x[["latitude"]], circle$longitude, circle$latitude)
keep <- dist < circle$radius
keep[is.na(keep)] <- FALSE
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset index type by circle with longitude= ", circle$longitude, " , latitude= ", circle$latitude, ", and radius= ", circle$radius)
)
if (!silent) {
message("Kept ", sum(keep), " cycles (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
}
} else if (dotsNames[1] == "circle" && istraj) {
stop("in subset,argoFloats-method(): cannot subset circle for \"index\" type with subtype = trajectories", call. = FALSE)
} else if (dotsNames[1] == "rectangle") {
argoFloatsDebug(debug, "subsetting an index by rectangle\n")
rectangle <- dots[[1]]
if (!is.list(dots[1])) {
stop("in subset,argoFloats-method():\n \"rectangle\" must be a list containing \"longitude\" and \"latitude\"", call. = FALSE)
}
if (2 != sum(c("longitude", "latitude") %in% sort(names(rectangle)))) {
stop("in subset,argoFloats-method():\n \"rectangle\" must be a list containing \"longitude\" and \"latitude\"", call. = FALSE)
}
if (!istraj) {
keeplon <- rectangle$longitude[1] <= x[["longitude"]] & x[["longitude"]] <= rectangle$longitude[2]
keeplat <- rectangle$latitude[1] <= x[["latitude"]] & x[["latitude"]] <= rectangle$latitude[2]
ok <- is.finite(keeplon) & is.finite(keeplat)
keeplon[!ok] <- FALSE
keeplat[!ok] <- FALSE
keep <- keeplon & keeplat
} else if (istraj) {
if (!requireNamespace("sf", quietly = TRUE)) {
stop("must install sf package for subset(...,circle,...) to work with trajectory files")
}
sE <- rectangle$longitude[2]
sW <- rectangle$longitude[1]
sS <- rectangle$latitude[1]
sN <- rectangle$latitude[2]
s <- rbind(c(sW, sS), c(sW, sN), c(sE, sN), c(sE, sS), c(sW, sS))
S <- sf::st_polygon(list(s))
n <- nrow(x@data$index)
keep <- rep(FALSE, n)
for (i in seq_len(n)) {
# message("i equals ", i)
# print(x@data$index[i,])
tE <- as.numeric(x@data$index$longitude_max[i])
tW <- as.numeric(x@data$index$longitude_min[i])
tS <- as.numeric(x@data$index$latitude_min[i])
tN <- as.numeric(x@data$index$latitude_max[i])
t <- rbind(c(tW, tS), c(tW, tN), c(tE, tN), c(tE, tS), c(tW, tS))
T <- sf::st_polygon(list(t))
intersection <- sf::st_intersection(T, S)
keep[i] <- length(intersection) > 0
# print(intersects)
# message('intersects ', length(intersects) > 0)
}
}
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset index type by rectangle with longitude= ", rectangle$longitude, " and latitude= ", rectangle$latitude)
)
if (!silent) {
message("Kept ", sum(keep), " cycles (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
}
} else if (dotsNames[1] == "parameter") {
argoFloatsDebug(debug, "subsetting an index by parameter\n")
parameter <- dots[[1]]
if (is.list(dots[1])) {
parameters <- unlist(parameter)
}
nparameters <- length(parameters)
parametersList <- lapply(x[["parameters"]], function(p) strsplit(p, " ")[[1]])
keep <- unlist(lapply(parametersList, function(pl) nparameters == sum(parameters %in% pl)))
# if (sum(keep) < 1)
# warning("in subset,argoFloats-method(..., parameter):\n found no profiles with given parameter", call.=FALSE)
if (!silent && !istraj) {
message("Kept ", sum(keep), " cycles (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
} else if (!silent && istraj) {
message("Kept ", sum(keep), " trajectories (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
}
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset index type by parameter= ", parameter)
)
} else if (dotsNames[1] == "polygon" && !istraj) {
argoFloatsDebug(debug, "subsetting an index by polygon\n")
if (!requireNamespace("sf", quietly = TRUE)) {
stop("must install.packages(\"sf\") for subset() by polygon to work")
}
polygon <- dots[[1]]
if (!is.list(dots[1])) {
stop("in subset,argoFloats-method():\n \"polygon\" must be a list", call. = FALSE)
}
if (length(polygon) != 2) {
stop("in subset,argoFloats-method():\n \"polygon\" must be a list of two elements", call. = FALSE)
}
if (2 != sum(c("longitude", "latitude") %in% names(polygon))) {
stop("in subset,argoFloats-method():\n \"polygon\" must be a list containing \"longitude\" and \"latitude\"", call. = FALSE)
}
plat <- polygon$latitude
plon <- polygon$longitude
if (!length(plat) > 2) {
stop("Must give at least three latitude coordinates.")
}
if (!length(plon) > 2) {
stop("Must give at least three longitude coordinates.")
}
if (length(plat) != length(plon)) {
stop(
"lengths of polygon$longitude and polygon$latitude must match, but they are ",
length(plat), " and ", length(plon)
)
}
if ((head(plon, 1) != tail(plon, 1)) || head(plat, 1) != tail(plat, 1)) {
# warning("In subset,argoFloats-method(): Closing the polygon, since the first and last points did not match.\n", call.=FALSE)
plon <- c(plon, plon[1])
plat <- c(plat, plat[1])
}
alon <- x[["longitude"]]
alat <- x[["latitude"]]
## We need the *index* of points to keep, and not just a lon-lat subset of
## points. It is not too difficult to get the index with the sp
## package, but the only solution I could come up with using the sf
## package is to tack 1,2,3,etc onto the lon-lat points as a third
## dimension, so that after we select for the points inside, we can skim
## that third dimension and that gives us the keep value that we need. There
## may be a more straightforward way, but my (admittedly shallow) reading
## of the sf function list did not uncover anything promising, and my
## tests show that this scheme works.
##
## See https://github.com/ArgoCanada/argoFloats/issues/86
ok <- is.finite(alon) & is.finite(alat)
if (!requireNamespace("sf", quietly = TRUE)) {
stop("must install sf package for subset(...,polygon,...) to work")
}
Polygon <- sf::st_polygon(list(outer = cbind(plon, plat, rep(0, length(plon)))))
## DOES NOT WORK (REQUIRES OTHER SOFTWARE??): Polygon <- sf::st_make_valid(Polygon)
if (!is.finite(sf::st_is_valid(Polygon))) {
errorMessage <- sf::st_is_valid(Polygon, reason = TRUE)
stop(paste0("Error in subset,argoFloats-method():\n polygon is invalid, because of ", errorMessage), call. = FALSE)
}
## multipoint does not permit NA values, so we set them to zero and remove them later
Points <- sf::st_multipoint(cbind(
ifelse(ok, alon, 0),
ifelse(ok, alat, 0),
seq_along(alon)
))
if (!sf::st_is_valid(Points)) {
errorMessage <- sf::st_is_valid(Points, reason = TRUE)
stop(paste0("Error in subset,argoFloats-method():\n \"Points\" is invalid, because of ", errorMessage), call. = FALSE)
}
Intersection <- sf::st_intersection(Points, Polygon)
keep <- Intersection[, 3]
if (!silent) {
message("Kept ", length(keep), " cycles (", sprintf("%.3g", 100 * length(keep) / N), "%)")
}
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset index type by polygon")
)
} else if (dotsNames[1] == "polygon" && istraj) {
stop("in subset,argoFloats-method(): cannot subset polygon for \"index\" type with subtype = trajectories", call. = FALSE)
} else if (dotsNames[1] == "time") {
argoFloatsDebug(debug, "subsetting an index by time\n")
time <- dots[[1]]
if (!is.list(dots[1])) {
stop("in subset,argoFloats-method():\n \"time\" must be a list", call. = FALSE)
}
if (2 != sum(c("from", "to") %in% names(time))) {
stop("in subset,argoFloats-method():\n \"time\" must be a list containing \"to\"and \"from\"", call. = FALSE)
}
if (length(time$from) != 1) {
stop("from must be of length 1")
}
if (length(time$to) != 1) {
stop("to must be of length 1")
}
if (!inherits(time$from, "POSIXt")) {
time$from <- try(as.POSIXct(time$from, tz = "UTC"))
if (inherits(time$from, "try-error")) {
stop("in subset,argoFloats-method():\n cannot convert \"time$from\" to a POSIX time", call. = FALSE)
}
}
if (!inherits(time$to, "POSIXt")) {
time$to <- try(as.POSIXct(time$to, tz = "UTC"))
if (inherits(time$to, "try-error")) {
stop("in subset,argoFloats-method():\n cannot convert \"time$to\" to a POSIX time", call. = FALSE)
}
}
if (time$to <= time$from) {
stop("in subset,argoFloats-method():\n \"to\" must be greater than \"from\"", call. = FALSE)
}
argoFloatsDebug(debug, "from= ", format(time$from, "%Y-%m-%d %H:%M:%S %z"), "\n")
argoFloatsDebug(debug, "to= ", format(time$to, "%Y-%m-%d %H:%M:%S %z"), "\n")
keep <- time$from[1] <= x[["date"]] & x[["date"]] <= time$to[1]
keep[is.na(keep)] <- FALSE
if (!silent && !istraj) {
message("Kept ", sum(keep), " cycles (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
} else if (!silent && istraj) {
message("Kept ", sum(keep), " trajectories (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
}
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset index type by time from", time$from, "to ", time$to)
)
} else if (dotsNames[1] == "institution") {
argoFloatsDebug(debug, "subsetting an index by institution\n")
institution <- dots[[1]]
if (!is.list(dots[1])) {
stop("in subset,argoFloats-method():\n \"institution\" must be a list")
}
if (length(institution) > 1) {
stop("\"institution\" cannot hold more than one element")
}
keep <- grepl(institution, x@data$index$institution)
keep[is.na(keep)] <- FALSE
if (!silent && !istraj) {
message("Kept ", sum(keep), " cycles (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
} else if (!silent && istraj) {
message("Kept ", sum(keep), " trajectories (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
}
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset index type by institution ", institution)
)
} else if (dotsNames[1] == "deep") {
argoFloatsDebug(debug, "subsetting an index by deep category\n")
deep <- dots[[1]]
if (!is.logical(deep)) {
stop("in subset,argoFloats-method():\n deep must be a logical vector indicating TRUE or FALSE", call. = FALSE)
}
if (deep) {
keep <- grep("849|862|864", x@data$index$profiler_type)
} else {
keep <- grep("849|862|864", x@data$index$profiler_type, invert = TRUE)
}
if (!silent && !istraj) {
message("Kept ", length(keep), " cycles (", sprintf("%.3g", 100 * length(keep) / N), "%)")
} else if (!silent && istraj) {
message("Kept ", length(keep), " trajectories (", sprintf("%.3g", 100 * length(keep) / N), "%)")
}
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset index type to only include deep data")
)
} else if (dotsNames[1] == "ID") {
argoFloatsDebug(debug, "subsetting an index by ID\n")
ID <- as.character(dots[[1]]) # convert in case it is numeric
xID <- x[["ID"]]
keep <- rep(FALSE, length(xID))
file <- x@data$index$file
for (thisID in ID) {
keep <- keep | grepl(thisID, xID)
}
if (!silent && !istraj) {
message("Kept ", sum(keep), " cycles (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
} else if (!silent && istraj) {
message("Kept ", sum(keep), " trajectories (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
}
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset index type by float ID", ID)
)
} else if (dotsNames[1] == "ocean" && !istraj) {
argoFloatsDebug(debug, "subsetting an index by ocean\n")
ocean <- dots[[1]]
if (!is.character(ocean)) {
stop("in subset,argoFloats-method() : \"ocean\" must be character value", call. = FALSE)
}
if (length(ocean) > 1) {
stop("in subset,argoFloats-method():\n \"ocean\" cannot hold more than one element", call. = FALSE)
}
keep <- grepl(ocean, x@data$index$ocean)
keep[is.na(keep)] <- FALSE
if (!silent) {
message("Kept ", sum(keep), " cycles (", sprintf("%.3g", 100.0 * sum(keep) / N), "%)")
}
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset index type by ocean", ocean)
)
} else if (dotsNames[1] == "ocean" && istraj) {
stop("in subset,argoFloats-method(): cannot subset ocean for \"index\" type with subtype = trajectories", call. = FALSE)
} else if (dotsNames[1] == "dataMode") {
argoFloatsDebug(debug, "subsetting an index by dataMode\n")
dataMode <- dots[[1]]
if (!is.character(dataMode)) {
stop("in subset,argoFloats-method():\n \"dataMode\" must be character value", call. = FALSE)
}
if (dataMode == "delayed" && !istraj) {
keep <- grepl("^[a-z]*/[0-9]*/profiles/.{0,1}D.*$", x[["file"]])
} else if (dataMode == "delayed" && istraj) {
keep <- grepl("^[a-z]*/[0-9]*/[0-9]*_.{0,1}D.*$", x[["file"]])
} else if (dataMode == "realtime" && !istraj) {
keep <- grepl("^[a-z]*/[0-9]*/profiles/.{0,1}R.*$", x[["file"]])
} else if (dataMode == "realtime" && istraj) {
keep <- grepl("^[a-z]*/[0-9]*/[0-9]*_.{0,1}R.*$", x[["file"]])
} else {
stop("in subset,argoFloats-method():\n \"dataMode\" must be either \"realtime\" or \"delayed\", not \"", dataMode, "\"", call. = FALSE)
}
if (!silent && !istraj) {
message("Kept ", sum(keep), " cycles (", sprintf("%.3g", 100.0 * sum(keep) / N), "%)")
} else if (!silent && istraj) {
message("Kept ", sum(keep), " trajectories (", sprintf("%.3g", 100.0 * sum(keep) / N), "%)")
}
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset index type by dataMode", dataMode)
)
} else if (dotsNames[1] == "cycle" && !istraj) {
cycle <- dots[[1]]
if (!is.character(cycle) & !is.numeric(cycle)) {
stop("in subset,argoFloats-method() : \"cycle\" must be character value or numeric value", call. = FALSE)
}
## Calculate 'keep', a logical vector that will be used for the actual subsetting.
xcycle <- x[["cycle"]]
# If cycle is numeric, we must convert it to character (so e.g. 1 becomes "001")
if (is.numeric(cycle)) {
cycle <- sprintf("%03d", as.integer(cycle))
argoFloatsDebug(debug, "subsetting an index by cycle of numeric type\n")
} else if (is.character(cycle)) {
argoFloatsDebug(debug, "subsetting an index by cycle of character type\n")
} else {
stop("cycle must be character or numeric")
}
keep <- rep(FALSE, length(xcycle))
for (thisCycle in cycle) {
keep <- keep | grepl(thisCycle, xcycle)
}
nkeep <- sum(keep)
if (nkeep < 1) {
warning("In subset,argoFloats-method(..., parameter) : found no profiles with given cycle(s)", call. = FALSE)
}
if (!silent) {
message("Kept ", nkeep, " cycles (", sprintf("%.3g", 100 * nkeep / N), "%)")
}
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset index type by cycle=", cycle)
)
} else if (dotsNames[1] == "cycle" && istraj) {
stop("in subset,argoFloats-method(): cannot subset cycle for \"index\" type with subtype = trajectories", call. = FALSE)
} else if (dotsNames[1] == "direction" && !istraj) {
argoFloatsDebug(debug, "subsetting an index by direction\n")
direction <- dots[[1]]
if (!is.character(direction)) {
stop("in subset,argoFloats-method():\n \"direction\" must be character value of either \"ascent\" or \"descent\"", call. = FALSE)
}
if (direction == "ascent") {
keep <- grepl("^.*[^D].nc$", x@data$index$file)
} else if (direction == "descent") {
keep <- grepl("^.*D.nc$", x@data$index$file)
} else {
stop("in subset,argoFloats-method():\n \"direction\" must be either \"ascent\" or \"descent\", not \"", direction, "\"", call. = FALSE)
}
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset index type by direction=", direction)
)
} else if (dotsNames[1] == "direction" && istraj) {
stop("in subset,argoFloats-method(): cannot subset direction for \"index\" type with subtype = trajectories", call. = FALSE)
} else if (dotsNames[1] == "section" && !istraj) {
# The following link shows a test of this method.
# https://github.com/ArgoCanada/argoFloats/issues/397#issuecomment-798960312
if (!requireNamespace("s2", quietly = TRUE)) {
stop("must install.packages(\"s2\") to subset by section")
}
argoFloatsDebug(debug, "subsetting an index by section\n")
section <- dots[[1]]
if (!is.list(section)) {
stop("in subset,argoFloats-method() :\n section must be a list containing \"longitude\", \"latitude\" and possibly \"width\" and \"segments\"", call. = FALSE)
}
# Handle mandatory components
if (!"longitude" %in% names(section)) {
stop("in subset,argoFloats-method() :\n section must have a \"longitude\" entry", call. = FALSE)
}
if (!"latitude" %in% names(section)) {
stop("in subset,argoFloats-method() :\n section must have a \"latitude\" entry", call. = FALSE)
}
if (length(section$longitude) != length(section$latitude)) {
stop("in subset,argoFloats-method() :\n length of section$longitude (",
length(section$longitude), ") and section$latitude (", length(section$latitude), ") disagree",
call. = FALSE
)
}
# Handle optional components
if (!"width" %in% names(section)) {
section$width <- 100
}
if (!"segments" %in% names(section)) {
section$segments <- 100
}
if (!is.null(section$segments)) {
if (!is.numeric(section$segments) || section$segments > 0) {
argoFloatsDebug(debug, "subdividing lon,lat trace (of length ", length(section$longitude), ") to increase length to ", section$segments, "\n", sep = "")
s <- seq(0, 1, length.out = length(section$longitude))
section$longitude <- stats::approx(s, section$longitude, seq(0, 1, length.out = section$segments))$y
section$latitude <- stats::approx(s, section$latitude, seq(0, 1, length.out = section$segments))$y
} else {
stop("in subset,argoFloats-method() :\n section$segments must be NULL or a positive integer", call. = FALSE)
}
}
# Create a spine for the section.
sectionSpine <- s2::s2_make_line(section$longitude, section$latitude)
# Create points for float locations. Blank the NAs, in case not allowed.
alon <- x[["longitude"]]
alat <- x[["latitude"]]
bad <- !is.finite(alon) | !is.finite(alat)
alon[bad] <- 0
alat[bad] <- 0
floatLocations <- s2::as_s2_geography(s2::s2_lnglat(alon, alat))
# Identify floats near the section spine
keep <- s2::s2_dwithin(floatLocations, sectionSpine, 1000 * section$width)
argoFloatsDebug(debug, "sum(keep)=", sum(keep), " i.e. ",
round(100 * sum(keep) / length(keep), 3), "% (before accounting for NA values)\n",
sep = ""
)
keep <- keep & !bad
argoFloatsDebug(debug, "sum(keep)=", sum(keep), " i.e. ",
round(100 * sum(keep) / length(keep), 3), "% (after accounting for NA values)\n",
sep = ""
)
if (!silent) {
message("Kept ", sum(keep), " cycles (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
}
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste0(
"subset index type by section with longitude=c(",
paste(section$longitude, collapse = ", "), "), latitude=c(",
paste(section$latitude, collapse = ", "), "), and width=",
section$width, " km"
)
)
} else if (dotsNames[1] == "section" && istraj) {
stop("in subset,argoFloats-method(): cannot subset section for \"index\" type with subtype = trajectories", call. = FALSE)
} else {
stop("in subset,argoFloats-method():\n the \"...\" argument \"", dotsNames[1], "\" is not permitted for an index-type object. The only valid choices are \"circle\", \"rectangle\", \"parameter\", \"polygon\", \"time\", \"institution\", \"deep\", \"ID\", \"ocean\", \"dataMode\", \"cycle\",\"direction\" and \"section\"", call. = FALSE)
}
}
} else {
## subset is not missing
if (length(dotsNames) != 0) {
stop("in subset,argoFloats-method():\n cannot give both \"subset\" and \"...\" arguments", call. = FALSE)
}
if (x@metadata$type == "index") {
if (!silent) {
if (is.logical(subset)) { # this simplifies the percentage count for the method
subset <- which(subset)
}
message("Kept ", length(subset), " cycles (", sprintf("%.3g", 100.0 * length(subset) / dim(x@data$index)[1]), "%)")
}
x@data$index <- x@data$index[subset, ]
} else {
stop("in subset,argoFloats-method():\n method not coded except for type=\"index\"", call. = FALSE)
}
}
argoFloatsDebug(debug, "} # subset,argoFloats-method()\n", style = "bold", sep = "", unindent = 1)
x
}
)
dankelley/argoFloats documentation built on June 11, 2025, 6:39 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
## vim:textwidth=128:expandtab:shiftwidth=4:softtabstop=4
## OLD use_sf_package <- TRUE
#' Subset an argoFloats Object
#'
#' Return a subset of an [`argoFloats-class`] object. This applies
#' only to objects of type `"index"`, as created with [getIndex()] or `subset()`
#' acting on such a value, or of type `"argos"`, as created with [readProfiles()].
#' (It cannot be used on objects of type `"profiles"`, as created with [getProfiles()].)
#' There are two ways to use `subset()`. **Method 1.** supply
#' the `subset` argument. This may be a logical vector indicating
#' which entries to keep (by analogy to the base-R `subset()`
#' function) or it may be an integer vector holding the indices of entries to
#' be retained. **Method 2.** do not supply `subset`. In this
#' case, the action is determined by the third (`...`)
#' argument; see \sQuote{Details}.
#'
#' The possibilities for the `...` argument are as follows.
#'
#' 1. An integer vector giving indices to keep.
#'
#' 2. A list named `circle` with numeric elements named `longitude`,
#' `latitude` and `radius`. The first two give the center of
#' the subset region, and the third gives the radius of
#' that region, in kilometers.
#'
#' 3. A list named `rectangle` that has elements named
#' `longitude` and `latitude`, two-element numeric vectors
#' giving the western and eastern, and southern and northern
#' limits of the selection region.
#'
#' 4. A list named `polygon` that has elements named `longitude` and `latitude`
#' that are numeric vectors specifying a polygon within which profiles
#' will be retained. The polygon must not be self-intersecting,
#' and an error message will be issued if it is. If the polygon is not closed
#' (i.e. if the first and last points do not coincide) the first point is pasted
#' onto the end, to close it.
#'
#' 5. A vector or list named `parameter` that holds character values that
#' specify the names of measured parameters to keep. See section 3.3 of
#' Reference 1 for a list of parameters.
#'
#' 6. A list named `time` that has elements `from` and `to` that are either
#' POSIXt times, or character strings that `subset()` will convert to
#' POSIXt times using [as.POSIXct()] with `tz="UTC"`.
#'
#' 7. A list named `institution` that holds a single character element that
#' names the institution. The permitted values are:
#' `"AO"` for Atlantic Oceanographic and Meteorological Laboratory;
#' `"BO"` for British Oceanographic Data Centre;
#' `"CS"` for Commonwealth Scientific and Industrial Research Organization;
#' `"HZ"` for China Second Institute of Oceanography;
#' `"IF"` for Ifremer, France;
#' `"IN"` for India National Centre for Ocean Information Services;
#' `"JA"` for Japan Meteorological Agency;
#' `"KM"` for Korea Meteorological Agency;
#' `"KO"` for Korea Ocean Research and Development Institute;
#' `"ME"` for Marine Environment Data Section; and
#' `"NM"` for National Marine Data & Information Service.
#'
#' 8. A list named `deep` that holds a logical value indicating whether argo floats
#' are deep argo (i.e. `profiler_type` 849, 862, and 864).
#'
#' 9. A list named `ID` that holds a character value specifying a float identifier.
#'
#' 10. A list named `ocean` that holds a single character element that names the
#' ocean. The permitted values are:
#' `"A"` for Atlantic Ocean Area, from 70 W to 20 E,
#' `"P"` for Pacific Ocean Area, from 145 E to 70 W, and
#' `"I"` for Indian Ocean Area, from 20 E to 145 E.
#'
#' 11. A character value named `dataMode`, equal to either `realtime` or `delayed`,
#' that selects whether to retain real-time data or delayed data. There are two
#' possibilities, depending on the `type` of the `x` argument.
#' **Case 1.** If `x` is of `type="index"`, then the subset is done by looking for the letters
#' `R` or `D` in the source filename. Note that a file in the
#' latter category may contain some profiles that are of delayed mode *and also*
#' some profiles that are of `realtime` or `adjusted` mode.
#' **Case 2.** If `x` is
#' of type `argos`, then the subset operation is done for each profile within
#' the dataset. Sometimes this will yield data arrays with zero columns.
#'
#' 12. An integer or character value named `cycle` that specifies which cycles are to be retained.
#' This is done by regular-expression matching of the filename, looking between the
#' underline character (`"_"`) and the suffix (`.nc`), but note that the expression
#' is made up of a compulsory component comprising 3 or 4 digits, and an optional
#' component that is either blank or the character `"D"` (which designates a
#' descending profile). Thus, `001` will match both `*_001.nc` and `*_001D.nc`.
#' Note this can be used for both `"index"` and `"argos"` types.
#'
#' 13. A character value named `direction`, equal to either "descent" or "ascent",
#' that selects whether to retain data from the ascent or decent phase.
#'
#' 14. An integer value named `profile` that selects which profiles
#' to retain. Note that this type of subset is possible only
#' for objects of type `"argos"`.
#'
#' 15. An integer value named `cycle` that selects which cycles
#' to retain.
#'
#' 16. A character value named `dataStateIndicator`, equal to either "0A", "1A",
#' "2B", "2B+", "2C", "2C+", "3B", or "3C" that selects which `dataStateIndicator`
#' to keep (see table 6 of Reference 1 for details of these codes).
#' This operation only works for objects of type `"argos"`.
#'
#' 17. A list named `section` that has four elements:
#' `longitude`,`latitude`, `width`, and `segments`. The first two of these
#' are numeric vectors that define the spine of the section, in degrees East
#' and North, respectively. These are both mandatory, while both `width` and `segments`
#' are optional. If given, `width` is taken as maximal distance between an Argo
#' and the spine, for that float to be retained. If `width` is not given, it
#' defaults to 100km. If given, `segments` is either `NULL` or a positive
#' integer. Setting `segments` to `NULL` will cause the float-spine distance
#' to be computed along a great-circle route. By contrast, if `segments` is an
#' integer, then the spine is traced using `stats::approx()`, creating
#' `segments` new points. If `segments` is not provided, it defaults to 100.
#'
#' In all cases, the notation is that longitude is positive
#' for degrees East and negative for degrees West, and that latitude
#' is positive for degrees North and negative for degrees South.
#' For more on this function, see Kelley et al. (2021).
#'
#' @param x an [`argoFloats-class`] object as created by [getIndex()].
#'
#' @param subset optional numerical or logical vector that indicates which
#' indices of `x@data$index` to keep (example 1).
#'
#' @param ... the first entry here must be either (a) a list named `circle`,
#' `rectangle`, `polygon`, `parameter`, `time`, `institution`,
#' `ID`,`ocean`,`dataMode`,`cycle`, `direction`, `profile`, or `section`.
#' (examples 2 through 8, and 10 through 17),
#' or (b) a logical value named `deep` (example 9). Optionally, this entry
#' may be followed by second entry named `silent`, which is a logical
#' value indicating whether to prevent the printing of messages that
#' indicate the number (and percentage) of data that are kept
#' during the subsetting operation.
#' See \dQuote{Details} and \dQuote{Examples}.
#'
#' @return An [`argoFloats-class`] object, restricted as indicated.
#'
#' @examples
#' library(argoFloats)
#' data(index)
#' data(indexSynthetic)
#'
#' # Subset to the first 3 profiles in the (built-in) index
#' indexFirst3 <- subset(index, 1:3)
#'
#' # Subset to a circle near Abaco Island
#' indexCircle <- subset(index, circle = list(longitude = -77.5, latitude = 27.5, radius = 50))
#' #
#' # # NOTE: this example was removed because it requires using tempdir, which
#' # # is not something we want to encourage, since it goes against the whole idea
#' # # of caching.
#' # # Example 2B: subset a 300 km radius around Panama using "maps" package
#' # # This example requires downloading.
#' #
#' \donttest{
#' # library("maps")
#' # data(world.cities)
#' # ai <- getIndex()
#' # panama <- subset(world.cities, name=="Panama")
#' # index1 <- subset(ai, circle=list(longitude=panama$long, latitude=panama$lat, radius=200))
#' #
#' }
#'
#' # Subset to a rectangle near Abaco Island
#' lonlim <- c(-76.5, -76)
#' latlim <- c(26.5, 27.5)
#' indexRectangle <- subset(index, rectangle = list(longitude = lonlim, latitude = latlim))
#'
#' # Subset to a polygon near Abaco Island
#' lonp <- c(-77.492, -78.219, -77.904, -77.213, -76.728, -77.492)
#' latp <- c(26.244, 25.247, 24.749, 24.987, 25.421, 26.244)
#' indexPolygon <- subset(index, polygon = list(longitude = lonp, latitude = latp))
#' #
#' # # Show some of these subsets on a map
#' # plot(index, bathymetry=FALSE)
#' # points(index2[["longitude"]], index2[["latitude"]], col=2, pch=20, cex=1.4)
#' # points(index3[["longitude"]], index3[["latitude"]], col=3, pch=20, cex=1.4)
#' # rect(lonRect[1], latRect[1], lonRect[2], latRect[2], border=3, lwd=2)
#' # points(index4[["longitude"]], index4[["latitude"]], col=4, pch=20, cex=1.4)
#' # polygon(p$longitude, p$latitude, border=4)
#'
#' # Subset to year 2019
#' index2019 <- subset(index, time = list(from = "2019-01-01", to = "2019-12-31"))
#'
#' # Subset to Canadian MEDS data
#' indexMEDS <- subset(index, institution = "ME")
#' #
#' # # NOTE: this example was removed because it requires using tempdir, which
#' # # is not something we want to encourage, since it goes against the whole idea
#' # # of caching.
#' # # Example 8: subset to a specific ID
#' # # This example requires downloading.
#' #
#' \donttest{
#' # ai <- getIndex(filename="synthetic")
#' # index9 <- subset(ai, ID="1900722")
#' #
#' }
#' #
#' # # NOTE: this example was removed because it requires using tempdir, which
#' # # is not something we want to encourage, since it goes against the whole idea
#' # # of caching.
#' # # Example 9: subset data to only include deep argo
#' # # This example requires downloading.
#' #
#' \donttest{
#' # ai <- getIndex(filename="synthetic")
#' # index8 <- subset(ai, deep=TRUE)
#' #
#' }
#' #
#' # # NOTE: this example was removed because it requires using tempdir, which
#' # # is not something we want to encourage, since it goes against the whole idea
#' # # of caching.
#' # # Example 10: subset data by ocean
#' # # This example requires downloading.
#' #
#' \donttest{
#' # ai <- getIndex()
#' # index10 <- subset(ai, circle=list(longitude=-83, latitude=9, radius=500))
#' # plot(index10, which="map", bathymetry=FALSE)
#' # atlantic <- subset(index10, ocean="A") # Subsetting for Atlantic Ocean
#' # pacific <- subset(index10, ocean="P")
#' # points(atlantic[["longitude"]], atlantic[["latitude"]], pch=20, col=2)
#' # points(pacific[["longitude"]], pacific[["latitude"]], pch=20, col=3)
#' #
#' }
#' #
#' # # NOTE: there is no example 11.
#' #
#' # # NOTE: this example was removed because it requires using tempdir, which
#' # # is not something we want to encourage, since it goes against the whole idea
#' # # of caching.
#' # # Example 11: subset by delayed time
#' # # This example requires downloading.
#' #
#' \donttest{
#' # data(indexBgc)
#' # index11 <- subset(indexBgc, dataMode="delayed")
#' # profiles <- getProfiles(index11)
#' # argos <- readProfiles(profiles)
#' # oxygen <- argos[["oxygen"]][[3]]
#' # pressure <- argos[["pressure"]][[3]]
#' # plot(oxygen, pressure, ylim=rev(range(pressure, na.rm=TRUE)),
#' # ylab="Pressure (dbar)", xlab="Oxygen (umol/kg)")
#' #
#' }
#' #
#' # # Example 12: subset by cycle
#' # data(index)
#' # index12A <- subset(index, cycle="124")
#' # index12B <- subset(index, cycle=0:2)
#' # cat("File names with cycle number 124:", paste(index12A[["file"]]), "\n")
#' # cat("File names with cycle number between 0 and 2:", paste(index12B[["file"]]), "\n")
#' #
#' #
#' # # NOTE: this example was removed because it requires using tempdir, which
#' # # is not something we want to encourage, since it goes against the whole idea
#' # # of caching.
#' # # Example 13: subset by direction
#' # # This example requires downloading.
#' #
#' \donttest{
#' # library(argoFloats)
#' # index13A <- subset(getIndex(), deep=TRUE)
#' # index13B <- subset(index13A, direction="descent")
#' # head(index13B[["file"]])
#' #
#' }
#' #
#' # # NOTE: this example was removed because it requires using tempdir, which
#' # # is not something we want to encourage, since it goes against the whole idea
#' # # of caching.
#' # # Example 14: subset by profile (for argos type)
#' # # This example requires downloading.
#' #
#' \donttest{
#' # library(argoFloats)
#' # index14A <- subset(getIndex(filename="synthetic"), ID="5903889")
#' # index14B <- subset(index14A, cycle="074")
#' # argos14A <- readProfiles(getProfiles(index14B))
#' # argos14B <- subset(argos14A, profile=1)
#' # D <- data.frame(Oxygen = argos14A[["oxygen"]],
#' # col1= argos14B[["oxygen"]][[1]])
#' #
#' }
#' #
#' # # NOTE: this example was removed because it requires using tempdir, which
#' # # is not something we want to encourage, since it goes against the whole idea
#' # # of caching.
#' # # Example 15: subset by cycle (for argos type) to create TS diagram
#' # # This example requires downloading.
#' #
#' \donttest{
#' # data("index")
#' # index15 <- subset(index, ID="1901584")
#' # profiles <- getProfiles(index15)
#' # argos <- readProfiles(profiles)
#' # plot(subset(argos, cycle="147"), which="TS")
#' #
#' }
#' #
#' # # NOTE: this example was removed because it requires using tempdir, which
#' # # is not something we want to encourage, since it goes against the whole idea
#' # # of caching.
#' # # Example 16: subset by dataStateIndicator
#' # # This example requires downloading.
#' #
#' \donttest{
#' # data("index")
#' # index16 <- subset(index, 1:40)
#' # argos <- readProfiles(getProfiles(index16))
#' # argos16A <- subset(argos, dataStateIndicator="2C")
#' # argos16B <- subset(argos, dataStateIndicator="2B")
#' #
#' }
#' #
#' # # Example 17: subset by section to create a map plot
#' # if (requireNamespace("s2")) {
#' # data("index")
#' # lon <- c(-78, -77, -76)
#' # lat <-c(27.5,27.5,26.5)
#' # index17 <- subset(index,
#' # section=list(longitude=lon, latitude=lat, width=50))
#' # plot(index17, bathymetry=FALSE)
#' # points(lon, lat, pch=21, col="black", bg="red", type="o", lwd=3)
#' # }
#'
#' # Subset to profiles with oxygen data
#' indexOxygen <- subset(indexSynthetic, parameter = "DOXY")
#'
#' # Subset to profiles with both salinity and 380-nm downward irradiance data
#' indexSalinityIrradiance <- subset(indexSynthetic, parameter = c("PSAL", "DOWN_IRRADIANCE380"))
#'
#' @references
#' 1. Carval, Thierry, Bob Keeley, Yasushi Takatsuki, Takashi Yoshida, Stephen Loch,
#' Claudia Schmid, and Roger Goldsmith. Argo User's Manual V3.3. Ifremer, 2019.
#' `doi:10.13155/29825`.
#' 2. Kelley, D. E., Harbin, J., & Richards, C. (2021). argoFloats: An R package for analyzing
#' Argo data. Frontiers in Marine Science, (8), 636922.
#' \doi{10.3389/fmars.2021.635922}
#'
#' @importFrom stats approx
#'
#' @importFrom oce geodDist
#'
#' @export
#'
#' @author Dan Kelley and Jaimie Harbin
setMethod(
f = "subset",
signature = "argoFloats",
definition = function(x, subset = NULL, ...) {
if (x@metadata$type == "profiles") {
stop("in subset,argoFloats-method() :\n subset doesn't work for type = profiles", call. = FALSE)
}
## subsetString <- paste(deparse(substitute(subset)), collapse=" ")
dots <- list(...)
dotsNames <- names(dots)
## Clear the "debug" and "silent" entries from dots, because later we insist that length(dots) be 1.
debug <- 0
if ("debug" %in% dotsNames) {
debug <- dots$debug
dots$debug <- NULL
dotsNames <- names(dots)
}
silent <- 0
if ("silent" %in% dotsNames) {
silent <- dots$silent
dots$silent <- NULL
dotsNames <- names(dots)
}
## All done with manipulating dots now.
argoFloatsDebug(debug, "subset,argoFloats-method() {\n", style = "bold", sep = "", unindent = 1)
## message("type =", x@metadata$type)
## Step 1: handle "argo" type first. Note that "subset" is ignored; rather, we insist that either
## "profile" or "cycle" be provided.
if (x@metadata$type == "argos") {
N <- x[["length"]]
if (!missing(subset)) {
N <- x[["length"]]
if (is.logical(subset)) {
if (length(subset) != x[["length"]]) {
stop("in subset,argoFloats-method() :\n 'subset' length (", length(subset), ") must match x length (", x[["length"]], ")",
call. = FALSE
)
}
keep <- which(subset)
} else if (is.numeric(subset)) {
if (!all(subset > 0)) {
stop("in subset,argoFloats-method() :\n 'subset' must consist only of positive integers",
call. = FALSE
)
}
if (any(subset > x[["length"]])) {
stop("in subset,argoFloats-method() :\n 'subset' must not contain indices beyond range of `x` (in this case, ", x[["length"]], ")",
call. = FALSE
)
}
keep <- subset
} else {
stop("in subset,argoFloats-method() :\n 'subset' must either be a logical vector or a list of indices",
call. = FALSE
)
}
res <- x
res@data$argos <- x@data$argos[keep]
if (!silent) {
message("Kept ", length(keep), " cycles (", sprintf("%.3g", 100 * length(keep) / N), "%)")
}
argoFloatsDebug(debug, "} # subset,argoFloats-method()\n", style = "bold", sep = "", unindent = 1)
return(res)
}
argoFloatsDebug(debug, "subsetting with type=\"argos\"\n")
if (length(dotsNames) == 0) {
stop("in subset,argoFloats-method() :\n must give \"profile\" , \"cycle\", or \"dataStateIndicator\" argument", call. = FALSE)
}
if (dotsNames[1] == "profile") {
argoFloatsDebug(debug, "subsetting by profile ", profile, "\n")
profile <- dots[[1]]
## Loop over all objects within the data, and within that loop look at data within the object,
## and for each of them, if its a vactor subset according to profile and if its a matrix
## subset according to profile
res <- x
argos <- x[["argos"]]
## Loop over all objects
## message("profile=",paste(profile, collapse=" "))
for (iargo in seq_along(argos)) {
argo <- argos[[iargo]]
## Handle the metadata slot
for (name in names(argo@metadata)) {
## message("name=",name)
argoFloatsDebug(debug, "subsetting metadata item named \"", name, "\"\n", sep = "")
## Pass some things through directly.
if (name %in% c("units", "filename", "flagScheme", "dataNamesOriginal")) {
next
}
item <- argo@metadata[[name]]
## Handle things that are encoded as characters in a string,
## namely "direction", "juldQC", and "positionQC".
if (name == "direction" || grepl("QC$", name)) {
## message(" -- character")
res@data$argos[[iargo]]@metadata[[name]] <- paste(strsplit(item, "")[[1]][profile], collapse = "")
} else if (is.list(item)) {
## message("list")
for (l in seq_along(item)) {
## print(dim(item[[l]]))
D <- dim(item[[l]])
if (profile > D[2]) {
stop("in subset,argoFloats-method() :\n cannot access profile ", profile, " of metadata item \"", name, "\" because its dimension is ", paste(D, collapse = " "), call. = FALSE)
}
## cat("BEFORE:\n");print(dim(res@data$argos[[iargo]]@metadata[[name]][[l]]))
res@data$argos[[iargo]]@metadata[[name]][[l]] <- item[[l]][, profile, drop = FALSE]
## cat("AFTER:\n");print(dim(res@data$argos[[iargo]]@metadata[[name]][[l]]))
}
} else if (is.vector(name)) {
## message("vector")
res@data$argos[[iargo]]@metadata[[name]] <- item[profile]
} else if (is.matrix(name)) {
## message("matrix")
res@data$argos[[iargo]]@metadata[[name]] <- item[, profile, drop = FALSE]
} else if (is.array(name)) {
argoFloatsDebug(debug, "name=", name, " has dim ", paste(dim(res@metadata[[name]]), collapse = " "), "\n")
if (length(dim(res@metadata[[name]])) <= 3) {
res@metadata[[name]] <- item[, , keep, drop = FALSE]
} else {
warning("not subsetting \"", name, "\" in metadata, because it is an array of rank > 3")
}
} else {
stop("cannot subset metadata item named \"", name, "\" because it is not a length-one string, a vector, or a matrix")
}
}
## Handle the data slot
for (name in names(argo@data)) {
item <- argo@data[[name]]
if (is.matrix(item)) {
dim <- dim(item)
if (profile > dim[2]) {
stop("in subset,argoFloats-method() :\n Only have ", dim[2], " profiles", call. = FALSE)
}
newItem <- item[, profile, drop = FALSE]
res@data$argos[[iargo]]@data[[name]] <- newItem
} else {
length <- length(item)
if (profile > length) {
stop("in subset,argoFloats-method() :\n Only have ", length, " profiles", call. = FALSE)
}
newItem <- item[profile, drop = FALSE]
res@data$argos[[iargo]]@data[[name]] <- newItem
}
}
}
argoFloatsDebug(debug, "} # subset,argoFloats-method()\n", style = "bold", sep = "", unindent = 1)
res@processingLog <- oce::processingLogAppend(
res@processingLog,
paste("subset argos type for profile=", profile)
)
return(res)
} else if (dotsNames[1] == "ID") {
istraj <- identical(x@metadata$subtype, "trajectories")
argoFloatsDebug(debug, "subsetting an argos object by ID\n")
ID <- as.character(dots[[1]]) # convert in case it is numeric
xID <- x[["ID"]]
keep <- rep(FALSE, length(xID))
for (thisID in ID) {
keep <- keep | grepl(thisID, xID)
}
if (!silent && !istraj) {
message("Kept ", sum(keep), " cycles (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
} else if (!silent && istraj) {
message("Kept ", sum(keep), " trajectories (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
}
x@data$argos <- x@data$argos[keep]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset argos type by float ID", ID)
)
} else if (dotsNames[1] == "cycle") {
argoFloatsDebug(debug, "subsetting by cycle for 'argos' type\n")
cycle <- dots[[1]]
if (!is.character(cycle) & !is.numeric(cycle)) {
stop("in subset,argoFloats-method() : \"cycle\" must be character value or numeric value", call. = FALSE)
}
## Calculate 'keep', a logical vector that will be used for the actual subsetting.
xcycle <- x[["cycle"]]
argoFloatsDebug(debug, "x[[\"cycle\"]]: ", paste(xcycle, collapse = " "), "\n")
argoFloatsDebug(debug, "cycle: ", cycle, "\n")
if (is.character(cycle)) {
argoFloatsDebug(debug, "subsetting by cycle as a character value\n")
## Here, keep is logical
keep <- rep(FALSE, length(xcycle))
for (thisCycle in cycle) {
keep <- keep | grepl(thisCycle, xcycle)
}
nkeep <- sum(keep)
} else if (is.numeric(cycle)) {
argoFloatsDebug(debug, "subsetting by cycle as a numeric value\n")
## Here, keep is integer
keep <- NULL
xcycle <- as.integer(gsub("AD", "", xcycle)) # change e.g. "123D" to "123"
for (thisCycle in cycle) {
keep <- c(keep, which(thisCycle == xcycle))
## message("thisCycle=", thisCycle, " keep=", paste(keep, collapse=" "))
}
nkeep <- length(keep)
}
if (nkeep < 1) {
warning("In subset,argoFloats-method(..., parameter) : found no profiles with given cycle(s)", call. = FALSE)
}
if (!silent) {
message("Kept ", nkeep, " cycles ")
}
x@data[[1]] <- x@data[[1]][keep]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset argos type for cycle=", cycle)
)
} else if (dotsNames[1] == "dataStateIndicator") {
argoFloatsDebug(debug, "subsetting by dataStateIndicator\n")
dataStateIndicator <- dots[[1]]
if (is.list(dots[1])) {
dataStateIndicator <- unlist(dataStateIndicator)
}
## Reference Table 6, in section 3.6, of
## Argo Data Management Team. “Argo User's Manual V3.3.”
## Ifremer, November 28, 2019. https://doi.org/10.13155/29825.
if (!is.character(dataStateIndicator)) {
stop("in subset,argoFloats-method() : \"dataStateIndicator\" must be character value", call. = FALSE)
}
## In next, [1] means we take the first element (first profile) of the cycle.
dsi <- sapply(x[["argos"]], function(a) a[["dataStateIndicator"]][1])
keep <- rep(FALSE, length(dsi))
for (dataStateIndicatorThis in dataStateIndicator) {
keep <- keep | grepl(dataStateIndicatorThis, dsi, fixed = TRUE)
## > message(dataStateIndicatorThis)
## > print(keep)
}
x@data[[1]] <- x@data[[1]][keep]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset argos type by dataStateIndicator=", dataStateIndicator)
)
} else if (dotsNames[1] == "dataMode") {
seeking <- dots$dataMode
# This testing of 'dataMode' may be overly complex
if (length(seeking) != 1) {
stop("in subset,argoFloats-method(): length of 'dataMode' must be 1", call. = FALSE)
}
if (!seeking %in% c("realtime", "adjusted", "delayed")) {
stop('in subset,argoFloats-method(): \'dataMode\' must be "realtime", "adjusted" or "delayed", not "', seeking, '"', call. = FALSE)
}
seeking <- switch(seeking,
realtime = "R",
adjusted = "A",
delayed = "D"
)
res <- x
a <- x@data$argos
for (i in seq_along(a)) {
A <- a[[i]]
keepProfile <- A[["dataMode"]] == seeking
#> message("i=", i, ", keepProfile=", paste(keepProfile, collapse=" "))
## flags
for (flagName in names(A@metadata$flags)) {
A@metadata$flags[[flagName]] <- A@metadata$flags[[flagName]][, keepProfile, drop = FALSE]
}
# dataMode
A@metadata$dataMode <- A@metadata$dataMode[keepProfile, drop = FALSE]
# data
for (dataName in names(A@data)) {
if (is.vector(A@data[[dataName]])) {
#> message("subset ", dataName, " vector from ", paste(A@data[[dataName]], collapse=" "))
A@data[[dataName]] <- A@data[[dataName]][keepProfile]
#> message(" ... to ", paste(A@data[[dataName]], collapse=" "))
} else if (is.array(A@data[[dataName]])) {
A@data[[dataName]] <- A@data[[dataName]][, keepProfile, drop = FALSE]
}
}
res@data$argos[[i]] <- A
}
res@processingLog <- oce::processingLogAppend(res@processingLog, paste(deparse(match.call()), sep = "", collapse = ""))
argoFloatsDebug(debug, "} # subset,argoFloats-method()\n", style = "bold", sep = "", unindent = 1)
return(res)
} else {
stop("in subset,argoFloats-method():\n the \"...\" argument \"", dotsNames[1], "\" is not permitted for an argos-type object. The only valid choices are \"cycle\", \"dataMode\", \"ID\", \"dataSateIndicator\" and \"profile\".", call. = FALSE)
}
}
## Step 2: Now we know the type is either "index" or "profiles". In either case,
## "subset" can be provided, so we check for its existence first.
if (missing(subset)) {
# argoFloatsDebug(debug, "no subset was given, so it must be circle=, rectangle=, or similar\n")
if (length(dots) == 0) {
stop("in subset,argoFloats-method() :\n for indices, must specify the subset, with \"subset\" argument, \"circle\",\"rectangle\", \"parameter\",\"polygon\", \"time\", \"institution\", \"deep\", \"ID\", \"ocean\", dataMode\", \"cycle\",\"direction\", or \"section\"", call. = FALSE)
}
if (length(dots) > 1) {
stop("in subset,argoFloats-method() :\n cannot give more than one method in the \"...\" argument", call. = FALSE)
}
N <- length(x@data$index[[1]]) # used in calculating percentages
if (x@metadata$type == "index") {
istraj <- identical(x@metadata$subtype, "trajectories")
if (dotsNames[1] == "circle" && !istraj) {
argoFloatsDebug(debug, "subsetting an index by circle\n")
circle <- dots[[1]]
if (!is.list(dots[1])) {
stop("in subset,argoFloats-method() :\n \"circle\" must be a list containing \"longitude\", \"latitude\" and \"radius\".", call. = FALSE)
}
if (3 != sum(c("longitude", "latitude", "radius") %in% sort(names(circle)))) {
stop("in subset,argoFloats-method() :\n \"circle\" must be a list containing \"longitude\", \"latitude\" and \"radius\"", call. = FALSE)
}
if (!requireNamespace("oce", quietly = TRUE)) {
stop("must install.packages(\"oce\") to subset by circle")
}
dist <- oce::geodDist(x[["longitude"]], x[["latitude"]], circle$longitude, circle$latitude)
keep <- dist < circle$radius
keep[is.na(keep)] <- FALSE
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset index type by circle with longitude= ", circle$longitude, " , latitude= ", circle$latitude, ", and radius= ", circle$radius)
)
if (!silent) {
message("Kept ", sum(keep), " cycles (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
}
} else if (dotsNames[1] == "circle" && istraj) {
stop("in subset,argoFloats-method(): cannot subset circle for \"index\" type with subtype = trajectories", call. = FALSE)
} else if (dotsNames[1] == "rectangle") {
argoFloatsDebug(debug, "subsetting an index by rectangle\n")
rectangle <- dots[[1]]
if (!is.list(dots[1])) {
stop("in subset,argoFloats-method():\n \"rectangle\" must be a list containing \"longitude\" and \"latitude\"", call. = FALSE)
}
if (2 != sum(c("longitude", "latitude") %in% sort(names(rectangle)))) {
stop("in subset,argoFloats-method():\n \"rectangle\" must be a list containing \"longitude\" and \"latitude\"", call. = FALSE)
}
if (!istraj) {
keeplon <- rectangle$longitude[1] <= x[["longitude"]] & x[["longitude"]] <= rectangle$longitude[2]
keeplat <- rectangle$latitude[1] <= x[["latitude"]] & x[["latitude"]] <= rectangle$latitude[2]
ok <- is.finite(keeplon) & is.finite(keeplat)
keeplon[!ok] <- FALSE
keeplat[!ok] <- FALSE
keep <- keeplon & keeplat
} else if (istraj) {
if (!requireNamespace("sf", quietly = TRUE)) {
stop("must install sf package for subset(...,circle,...) to work with trajectory files")
}
sE <- rectangle$longitude[2]
sW <- rectangle$longitude[1]
sS <- rectangle$latitude[1]
sN <- rectangle$latitude[2]
s <- rbind(c(sW, sS), c(sW, sN), c(sE, sN), c(sE, sS), c(sW, sS))
S <- sf::st_polygon(list(s))
n <- nrow(x@data$index)
keep <- rep(FALSE, n)
for (i in seq_len(n)) {
# message("i equals ", i)
# print(x@data$index[i,])
tE <- as.numeric(x@data$index$longitude_max[i])
tW <- as.numeric(x@data$index$longitude_min[i])
tS <- as.numeric(x@data$index$latitude_min[i])
tN <- as.numeric(x@data$index$latitude_max[i])
t <- rbind(c(tW, tS), c(tW, tN), c(tE, tN), c(tE, tS), c(tW, tS))
T <- sf::st_polygon(list(t))
intersection <- sf::st_intersection(T, S)
keep[i] <- length(intersection) > 0
# print(intersects)
# message('intersects ', length(intersects) > 0)
}
}
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset index type by rectangle with longitude= ", rectangle$longitude, " and latitude= ", rectangle$latitude)
)
if (!silent) {
message("Kept ", sum(keep), " cycles (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
}
} else if (dotsNames[1] == "parameter") {
argoFloatsDebug(debug, "subsetting an index by parameter\n")
parameter <- dots[[1]]
if (is.list(dots[1])) {
parameters <- unlist(parameter)
}
nparameters <- length(parameters)
parametersList <- lapply(x[["parameters"]], function(p) strsplit(p, " ")[[1]])
keep <- unlist(lapply(parametersList, function(pl) nparameters == sum(parameters %in% pl)))
# if (sum(keep) < 1)
# warning("in subset,argoFloats-method(..., parameter):\n found no profiles with given parameter", call.=FALSE)
if (!silent && !istraj) {
message("Kept ", sum(keep), " cycles (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
} else if (!silent && istraj) {
message("Kept ", sum(keep), " trajectories (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
}
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset index type by parameter= ", parameter)
)
} else if (dotsNames[1] == "polygon" && !istraj) {
argoFloatsDebug(debug, "subsetting an index by polygon\n")
if (!requireNamespace("sf", quietly = TRUE)) {
stop("must install.packages(\"sf\") for subset() by polygon to work")
}
polygon <- dots[[1]]
if (!is.list(dots[1])) {
stop("in subset,argoFloats-method():\n \"polygon\" must be a list", call. = FALSE)
}
if (length(polygon) != 2) {
stop("in subset,argoFloats-method():\n \"polygon\" must be a list of two elements", call. = FALSE)
}
if (2 != sum(c("longitude", "latitude") %in% names(polygon))) {
stop("in subset,argoFloats-method():\n \"polygon\" must be a list containing \"longitude\" and \"latitude\"", call. = FALSE)
}
plat <- polygon$latitude
plon <- polygon$longitude
if (!length(plat) > 2) {
stop("Must give at least three latitude coordinates.")
}
if (!length(plon) > 2) {
stop("Must give at least three longitude coordinates.")
}
if (length(plat) != length(plon)) {
stop(
"lengths of polygon$longitude and polygon$latitude must match, but they are ",
length(plat), " and ", length(plon)
)
}
if ((head(plon, 1) != tail(plon, 1)) || head(plat, 1) != tail(plat, 1)) {
# warning("In subset,argoFloats-method(): Closing the polygon, since the first and last points did not match.\n", call.=FALSE)
plon <- c(plon, plon[1])
plat <- c(plat, plat[1])
}
alon <- x[["longitude"]]
alat <- x[["latitude"]]
## We need the *index* of points to keep, and not just a lon-lat subset of
## points. It is not too difficult to get the index with the sp
## package, but the only solution I could come up with using the sf
## package is to tack 1,2,3,etc onto the lon-lat points as a third
## dimension, so that after we select for the points inside, we can skim
## that third dimension and that gives us the keep value that we need. There
## may be a more straightforward way, but my (admittedly shallow) reading
## of the sf function list did not uncover anything promising, and my
## tests show that this scheme works.
##
## See https://github.com/ArgoCanada/argoFloats/issues/86
ok <- is.finite(alon) & is.finite(alat)
if (!requireNamespace("sf", quietly = TRUE)) {
stop("must install sf package for subset(...,polygon,...) to work")
}
Polygon <- sf::st_polygon(list(outer = cbind(plon, plat, rep(0, length(plon)))))
## DOES NOT WORK (REQUIRES OTHER SOFTWARE??): Polygon <- sf::st_make_valid(Polygon)
if (!is.finite(sf::st_is_valid(Polygon))) {
errorMessage <- sf::st_is_valid(Polygon, reason = TRUE)
stop(paste0("Error in subset,argoFloats-method():\n polygon is invalid, because of ", errorMessage), call. = FALSE)
}
## multipoint does not permit NA values, so we set them to zero and remove them later
Points <- sf::st_multipoint(cbind(
ifelse(ok, alon, 0),
ifelse(ok, alat, 0),
seq_along(alon)
))
if (!sf::st_is_valid(Points)) {
errorMessage <- sf::st_is_valid(Points, reason = TRUE)
stop(paste0("Error in subset,argoFloats-method():\n \"Points\" is invalid, because of ", errorMessage), call. = FALSE)
}
Intersection <- sf::st_intersection(Points, Polygon)
keep <- Intersection[, 3]
if (!silent) {
message("Kept ", length(keep), " cycles (", sprintf("%.3g", 100 * length(keep) / N), "%)")
}
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset index type by polygon")
)
} else if (dotsNames[1] == "polygon" && istraj) {
stop("in subset,argoFloats-method(): cannot subset polygon for \"index\" type with subtype = trajectories", call. = FALSE)
} else if (dotsNames[1] == "time") {
argoFloatsDebug(debug, "subsetting an index by time\n")
time <- dots[[1]]
if (!is.list(dots[1])) {
stop("in subset,argoFloats-method():\n \"time\" must be a list", call. = FALSE)
}
if (2 != sum(c("from", "to") %in% names(time))) {
stop("in subset,argoFloats-method():\n \"time\" must be a list containing \"to\"and \"from\"", call. = FALSE)
}
if (length(time$from) != 1) {
stop("from must be of length 1")
}
if (length(time$to) != 1) {
stop("to must be of length 1")
}
if (!inherits(time$from, "POSIXt")) {
time$from <- try(as.POSIXct(time$from, tz = "UTC"))
if (inherits(time$from, "try-error")) {
stop("in subset,argoFloats-method():\n cannot convert \"time$from\" to a POSIX time", call. = FALSE)
}
}
if (!inherits(time$to, "POSIXt")) {
time$to <- try(as.POSIXct(time$to, tz = "UTC"))
if (inherits(time$to, "try-error")) {
stop("in subset,argoFloats-method():\n cannot convert \"time$to\" to a POSIX time", call. = FALSE)
}
}
if (time$to <= time$from) {
stop("in subset,argoFloats-method():\n \"to\" must be greater than \"from\"", call. = FALSE)
}
argoFloatsDebug(debug, "from= ", format(time$from, "%Y-%m-%d %H:%M:%S %z"), "\n")
argoFloatsDebug(debug, "to= ", format(time$to, "%Y-%m-%d %H:%M:%S %z"), "\n")
keep <- time$from[1] <= x[["date"]] & x[["date"]] <= time$to[1]
keep[is.na(keep)] <- FALSE
if (!silent && !istraj) {
message("Kept ", sum(keep), " cycles (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
} else if (!silent && istraj) {
message("Kept ", sum(keep), " trajectories (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
}
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset index type by time from", time$from, "to ", time$to)
)
} else if (dotsNames[1] == "institution") {
argoFloatsDebug(debug, "subsetting an index by institution\n")
institution <- dots[[1]]
if (!is.list(dots[1])) {
stop("in subset,argoFloats-method():\n \"institution\" must be a list")
}
if (length(institution) > 1) {
stop("\"institution\" cannot hold more than one element")
}
keep <- grepl(institution, x@data$index$institution)
keep[is.na(keep)] <- FALSE
if (!silent && !istraj) {
message("Kept ", sum(keep), " cycles (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
} else if (!silent && istraj) {
message("Kept ", sum(keep), " trajectories (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
}
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset index type by institution ", institution)
)
} else if (dotsNames[1] == "deep") {
argoFloatsDebug(debug, "subsetting an index by deep category\n")
deep <- dots[[1]]
if (!is.logical(deep)) {
stop("in subset,argoFloats-method():\n deep must be a logical vector indicating TRUE or FALSE", call. = FALSE)
}
if (deep) {
keep <- grep("849|862|864", x@data$index$profiler_type)
} else {
keep <- grep("849|862|864", x@data$index$profiler_type, invert = TRUE)
}
if (!silent && !istraj) {
message("Kept ", length(keep), " cycles (", sprintf("%.3g", 100 * length(keep) / N), "%)")
} else if (!silent && istraj) {
message("Kept ", length(keep), " trajectories (", sprintf("%.3g", 100 * length(keep) / N), "%)")
}
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset index type to only include deep data")
)
} else if (dotsNames[1] == "ID") {
argoFloatsDebug(debug, "subsetting an index by ID\n")
ID <- as.character(dots[[1]]) # convert in case it is numeric
xID <- x[["ID"]]
keep <- rep(FALSE, length(xID))
file <- x@data$index$file
for (thisID in ID) {
keep <- keep | grepl(thisID, xID)
}
if (!silent && !istraj) {
message("Kept ", sum(keep), " cycles (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
} else if (!silent && istraj) {
message("Kept ", sum(keep), " trajectories (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
}
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset index type by float ID", ID)
)
} else if (dotsNames[1] == "ocean" && !istraj) {
argoFloatsDebug(debug, "subsetting an index by ocean\n")
ocean <- dots[[1]]
if (!is.character(ocean)) {
stop("in subset,argoFloats-method() : \"ocean\" must be character value", call. = FALSE)
}
if (length(ocean) > 1) {
stop("in subset,argoFloats-method():\n \"ocean\" cannot hold more than one element", call. = FALSE)
}
keep <- grepl(ocean, x@data$index$ocean)
keep[is.na(keep)] <- FALSE
if (!silent) {
message("Kept ", sum(keep), " cycles (", sprintf("%.3g", 100.0 * sum(keep) / N), "%)")
}
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset index type by ocean", ocean)
)
} else if (dotsNames[1] == "ocean" && istraj) {
stop("in subset,argoFloats-method(): cannot subset ocean for \"index\" type with subtype = trajectories", call. = FALSE)
} else if (dotsNames[1] == "dataMode") {
argoFloatsDebug(debug, "subsetting an index by dataMode\n")
dataMode <- dots[[1]]
if (!is.character(dataMode)) {
stop("in subset,argoFloats-method():\n \"dataMode\" must be character value", call. = FALSE)
}
if (dataMode == "delayed" && !istraj) {
keep <- grepl("^[a-z]*/[0-9]*/profiles/.{0,1}D.*$", x[["file"]])
} else if (dataMode == "delayed" && istraj) {
keep <- grepl("^[a-z]*/[0-9]*/[0-9]*_.{0,1}D.*$", x[["file"]])
} else if (dataMode == "realtime" && !istraj) {
keep <- grepl("^[a-z]*/[0-9]*/profiles/.{0,1}R.*$", x[["file"]])
} else if (dataMode == "realtime" && istraj) {
keep <- grepl("^[a-z]*/[0-9]*/[0-9]*_.{0,1}R.*$", x[["file"]])
} else {
stop("in subset,argoFloats-method():\n \"dataMode\" must be either \"realtime\" or \"delayed\", not \"", dataMode, "\"", call. = FALSE)
}
if (!silent && !istraj) {
message("Kept ", sum(keep), " cycles (", sprintf("%.3g", 100.0 * sum(keep) / N), "%)")
} else if (!silent && istraj) {
message("Kept ", sum(keep), " trajectories (", sprintf("%.3g", 100.0 * sum(keep) / N), "%)")
}
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset index type by dataMode", dataMode)
)
} else if (dotsNames[1] == "cycle" && !istraj) {
cycle <- dots[[1]]
if (!is.character(cycle) & !is.numeric(cycle)) {
stop("in subset,argoFloats-method() : \"cycle\" must be character value or numeric value", call. = FALSE)
}
## Calculate 'keep', a logical vector that will be used for the actual subsetting.
xcycle <- x[["cycle"]]
# If cycle is numeric, we must convert it to character (so e.g. 1 becomes "001")
if (is.numeric(cycle)) {
cycle <- sprintf("%03d", as.integer(cycle))
argoFloatsDebug(debug, "subsetting an index by cycle of numeric type\n")
} else if (is.character(cycle)) {
argoFloatsDebug(debug, "subsetting an index by cycle of character type\n")
} else {
stop("cycle must be character or numeric")
}
keep <- rep(FALSE, length(xcycle))
for (thisCycle in cycle) {
keep <- keep | grepl(thisCycle, xcycle)
}
nkeep <- sum(keep)
if (nkeep < 1) {
warning("In subset,argoFloats-method(..., parameter) : found no profiles with given cycle(s)", call. = FALSE)
}
if (!silent) {
message("Kept ", nkeep, " cycles (", sprintf("%.3g", 100 * nkeep / N), "%)")
}
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset index type by cycle=", cycle)
)
} else if (dotsNames[1] == "cycle" && istraj) {
stop("in subset,argoFloats-method(): cannot subset cycle for \"index\" type with subtype = trajectories", call. = FALSE)
} else if (dotsNames[1] == "direction" && !istraj) {
argoFloatsDebug(debug, "subsetting an index by direction\n")
direction <- dots[[1]]
if (!is.character(direction)) {
stop("in subset,argoFloats-method():\n \"direction\" must be character value of either \"ascent\" or \"descent\"", call. = FALSE)
}
if (direction == "ascent") {
keep <- grepl("^.*[^D].nc$", x@data$index$file)
} else if (direction == "descent") {
keep <- grepl("^.*D.nc$", x@data$index$file)
} else {
stop("in subset,argoFloats-method():\n \"direction\" must be either \"ascent\" or \"descent\", not \"", direction, "\"", call. = FALSE)
}
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste("subset index type by direction=", direction)
)
} else if (dotsNames[1] == "direction" && istraj) {
stop("in subset,argoFloats-method(): cannot subset direction for \"index\" type with subtype = trajectories", call. = FALSE)
} else if (dotsNames[1] == "section" && !istraj) {
# The following link shows a test of this method.
# https://github.com/ArgoCanada/argoFloats/issues/397#issuecomment-798960312
if (!requireNamespace("s2", quietly = TRUE)) {
stop("must install.packages(\"s2\") to subset by section")
}
argoFloatsDebug(debug, "subsetting an index by section\n")
section <- dots[[1]]
if (!is.list(section)) {
stop("in subset,argoFloats-method() :\n section must be a list containing \"longitude\", \"latitude\" and possibly \"width\" and \"segments\"", call. = FALSE)
}
# Handle mandatory components
if (!"longitude" %in% names(section)) {
stop("in subset,argoFloats-method() :\n section must have a \"longitude\" entry", call. = FALSE)
}
if (!"latitude" %in% names(section)) {
stop("in subset,argoFloats-method() :\n section must have a \"latitude\" entry", call. = FALSE)
}
if (length(section$longitude) != length(section$latitude)) {
stop("in subset,argoFloats-method() :\n length of section$longitude (",
length(section$longitude), ") and section$latitude (", length(section$latitude), ") disagree",
call. = FALSE
)
}
# Handle optional components
if (!"width" %in% names(section)) {
section$width <- 100
}
if (!"segments" %in% names(section)) {
section$segments <- 100
}
if (!is.null(section$segments)) {
if (!is.numeric(section$segments) || section$segments > 0) {
argoFloatsDebug(debug, "subdividing lon,lat trace (of length ", length(section$longitude), ") to increase length to ", section$segments, "\n", sep = "")
s <- seq(0, 1, length.out = length(section$longitude))
section$longitude <- stats::approx(s, section$longitude, seq(0, 1, length.out = section$segments))$y
section$latitude <- stats::approx(s, section$latitude, seq(0, 1, length.out = section$segments))$y
} else {
stop("in subset,argoFloats-method() :\n section$segments must be NULL or a positive integer", call. = FALSE)
}
}
# Create a spine for the section.
sectionSpine <- s2::s2_make_line(section$longitude, section$latitude)
# Create points for float locations. Blank the NAs, in case not allowed.
alon <- x[["longitude"]]
alat <- x[["latitude"]]
bad <- !is.finite(alon) | !is.finite(alat)
alon[bad] <- 0
alat[bad] <- 0
floatLocations <- s2::as_s2_geography(s2::s2_lnglat(alon, alat))
# Identify floats near the section spine
keep <- s2::s2_dwithin(floatLocations, sectionSpine, 1000 * section$width)
argoFloatsDebug(debug, "sum(keep)=", sum(keep), " i.e. ",
round(100 * sum(keep) / length(keep), 3), "% (before accounting for NA values)\n",
sep = ""
)
keep <- keep & !bad
argoFloatsDebug(debug, "sum(keep)=", sum(keep), " i.e. ",
round(100 * sum(keep) / length(keep), 3), "% (after accounting for NA values)\n",
sep = ""
)
if (!silent) {
message("Kept ", sum(keep), " cycles (", sprintf("%.3g", 100 * sum(keep) / N), "%)")
}
x@data$index <- x@data$index[keep, ]
x@processingLog <- oce::processingLogAppend(
x@processingLog,
paste0(
"subset index type by section with longitude=c(",
paste(section$longitude, collapse = ", "), "), latitude=c(",
paste(section$latitude, collapse = ", "), "), and width=",
section$width, " km"
)
)
} else if (dotsNames[1] == "section" && istraj) {
stop("in subset,argoFloats-method(): cannot subset section for \"index\" type with subtype = trajectories", call. = FALSE)
} else {
stop("in subset,argoFloats-method():\n the \"...\" argument \"", dotsNames[1], "\" is not permitted for an index-type object. The only valid choices are \"circle\", \"rectangle\", \"parameter\", \"polygon\", \"time\", \"institution\", \"deep\", \"ID\", \"ocean\", \"dataMode\", \"cycle\",\"direction\" and \"section\"", call. = FALSE)
}
}
} else {
## subset is not missing
if (length(dotsNames) != 0) {
stop("in subset,argoFloats-method():\n cannot give both \"subset\" and \"...\" arguments", call. = FALSE)
}
if (x@metadata$type == "index") {
if (!silent) {
if (is.logical(subset)) { # this simplifies the percentage count for the method
subset <- which(subset)
}
message("Kept ", length(subset), " cycles (", sprintf("%.3g", 100.0 * length(subset) / dim(x@data$index)[1]), "%)")
}
x@data$index <- x@data$index[subset, ]
} else {
stop("in subset,argoFloats-method():\n method not coded except for type=\"index\"", call. = FALSE)
}
}
argoFloatsDebug(debug, "} # subset,argoFloats-method()\n", style = "bold", sep = "", unindent = 1)
x
}
)
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.