some flag twiddling but I plan to change it

R/AllClass.R

@@ -587,50 +587,88 @@ handleFlagsInternal <- function(object, flags, actions, debug) {
 #' @templateVar class oce
 #' @templateVar note This generic function is overridden by specialized functions for some object classes.
 #' @template setFlagsTemplate
-setGeneric("setFlags", function(object, name=NULL, i=NULL, value=NULL, default=NULL, debug=0) {
+setGeneric("setFlags", function(object, name=NULL, i=NULL, value=NULL, initial=NULL, scheme=NULL, debug=0) {
            standardGeneric("setFlags")
          })
 
+
 #' @templateVar class oce
 #' @templateVar note This generic function is overridden by specialized functions for some object classes.
 #' @template setFlagsTemplate
 setMethod("setFlags",
-          c(object="oce", name="ANY", i="ANY", value="ANY", default="ANY", debug="ANY"),
-          function(object, name=NULL, i=NULL, value=NULL, default=NULL, debug=getOption("oceDebug")) {
-              setFlagsInternal(object=object, name=name, i=i, value=value, default=default, debug=debug)
+          c(object="oce", name="ANY", i="ANY", value="ANY", initial="ANY", scheme="ANY", debug="ANY"),
+          function(object, name=NULL, i=NULL, value=NULL, initial=NULL, scheme=scheme, debug=getOption("oceDebug")) {
+              setFlagsInternal(object=object, name=name, i=i, value=value, initial=initial, scheme=scheme, debug=debug)
           })
 
-setFlagsInternal <- function(object, name=NULL, i=NULL, value=NULL, default=NULL, debug=getOption("oceDebug"))
+setFlagsInternal <- function(object, name=NULL, i=NULL,
+                             value=NULL, initial=NULL, scheme=NULL, debug=getOption("oceDebug"))
 {
     oceDebug(debug, "setFlagsInternal(object, name='", name, "', value=", value,
              ", default=", default, ", i=", paste(i, collapse=" "),
              ", debug=", debug, ") {\n", sep="",
              unindent=1)
+    res <- object
+    ## Ensure proper argument setup.
     if (is.null(name))
         stop("must supply a name")
     if (length(name) > 1)
-        stop("must specify one 'name' at a time")
+        stop("must specify one 'name' at a time") # maybe this should be a warning
     if (!(name %in% names(object@data)))
         stop("object data slot does not contain '", name, "'; try one of: ",
              paste(names(object@data), collapse=" "))
-    if (is.null(value))
-        stop("must supply a value")
-    ## Check for 'i', but 'j' is optional
     if (is.null(i))
         stop("must supply 'i'")
-    if (!is.null(default) && length(default) > 1)
-        stop("default must be of length one")
+    if (is.null(value))
+        stop("must supply 'value'")
+    if (!is.null(scheme)) {
+        if (is.null(res@metadata$flagsScheme))
+            res@metadata$flagsScheme <- scheme
+        else
+            warning("ignoring 'scheme' because already set to: ",
+                    as.character(deparse(scheme)))
+    }
+    ##> ## Warn if supplying 'initial' when it won't be used.
+    ##> if (!is.null(object@metadata$flags[[name]]) && !is.null(initial))
+    ##>     warning("ignoring 'initial' because the object already has a flag for '", name, "'")
+    ## Demand that 'initial' be supplied when it is needed.
+    if (is.null(object@metadata$flags[[name]]) && is.null(initial))
+        stop("must give 'initial' to initialize flags for '", name, "'")
+    ## Done with basic tests.
     flagName <- paste(name, "Flag", sep="")
-    res <- object
+
+    ## Permit 'value' and 'initial' to be character strings, if a scheme already
+    ## exists and if these are contained within it.
+    if (is.character(value)) {
+        if (is.null(res@metadata$flagScheme)) {
+            stop("cannot have character 'value' without a 'scheme' supplied (or existing in object)")
+        } else {
+            if (value %in% names(res@metadata$flagScheme))
+                value <- res@metadata$flagScheme[[value]]
+            else
+                stop("value=\"", value, "\" is not defined the 'scheme' supplied (or existing in object)")
+        }
+    }
+    if (is.character(initial)) {
+        if (is.null(res@metadata$flagScheme)) {
+            stop("cannot have character 'initial' without a 'scheme' supplied (or existing in object)")
+        } else {
+            if (value %in% names(res@metadata$flagScheme))
+                initial <- res@metadata$flagScheme[[initial]]
+            else
+                stop("initial=\"", initial, "\" is not defined the 'scheme' supplied (or existing in object)")
+        }
+    }
+    ## Finally, apply the value (after initializing the flag to 'initial', if necessary)
     if (is.vector(object@data[[name]])) {
         oceDebug(debug, name, " is a vector\n")
         if (!is.vector(i))
             stop("'i' must be a vector, because ", name, " is a vector")
         if (!(name %in% names(object@metadata$flags))) {
-            oceDebug(debug, "initializing flag to default ", default, " prior to setting the flag\n")
-            if (is.null(default))
-                stop("cannot have a NULL default value")
-            res@metadata$flags[[name]] <- rep(default, length(object@data[[name]]))
+            oceDebug(debug, "initializing flag to ", initial, " prior to setting the flag\n")
+            if (is.null(initial))
+                stop("cannot have a NULL initial value")
+            res@metadata$flags[[name]] <- rep(initial, length(object@data[[name]]))
         }
         res@metadata$flags[[name]][i] <- value
     } else if (is.array(object@data[[name]])) {
@@ -646,10 +684,10 @@ setFlagsInternal <- function(object, name=NULL, i=NULL, value=NULL, default=NULL
             if (ncol(i) != length(dimData))
                 stop("data frame 'i' must have ", length(dimData), " columns to match shape of '", name, "'")
             if (!(name %in% names(object@metadata$flags))) {
-                oceDebug(debug, "initializing flag to default ", default, " prior to setting the flag\n")
-                if (is.null(default))
-                    stop("cannot have a NULL default value")
-                res@metadata$flags[[name]] <- array(default, dim=dimData)
+                oceDebug(debug, "initializing flag to ", initial, " prior to setting the flag\n")
+                if (is.null(initial))
+                    stop("cannot have a NULL initial value")
+                res@metadata$flags[[name]] <- array(initial, dim=dimData)
             }
             for (j in seq_len(nrow(i))) {
                 res@metadata$flags[[name]][i[j,1], i[j,2], i[j,3]] <- value
@@ -660,6 +698,9 @@ setFlagsInternal <- function(object, name=NULL, i=NULL, value=NULL, default=NULL
     } else{
         stop("only works for vectors and arrays (please report this as an error)")
     }
+    res@processingLog <- processingLogAppend(res@processingLog,
+                                             paste("setFlags(object, \"", name, "\", i, value=", value,
+                                             ", initial=", initial, ", scheme=", deparse(scheme), ")", collapse=""))
     oceDebug(debug, "} # setFlagsInternal \n", unindent=1)
     res
 }

R/adp.R

@@ -373,13 +373,13 @@ setMethod("handleFlags",
 #'
 #' @family things related to \code{adp} data
 setMethod("setFlags",
-          c(object="adp", name="ANY", i="ANY", value="ANY", default="ANY", debug="ANY"),
-          function(object, name=NULL, i=NULL, value=NULL, default=NULL, debug=getOption("oceDebug")) {
+          c(object="adp", name="ANY", i="ANY", value="ANY", initial="ANY", scheme="ANY", debug="ANY"),
+          function(object, name=NULL, i=NULL, value=NULL, initial=NULL, scheme=NULL, debug=getOption("oceDebug")) {
               if (is.null(name))
                   stop("must specify 'name'")
               if (name != "v")
                   stop("in adp objects, the only flag that can be set is for \"v\"")
-              setFlagsInternal(object=object, name=name, i=i, value=value, default=default, debug=debug-1)
+              setFlagsInternal(object=object, name=name, i=i, value=value, initial=initial, scheme=scheme, debug=debug-1)
           })
 
 

R/ctd.R

@@ -243,7 +243,7 @@ setMethod("handleFlags",
 
 #' @templateVar class ctd
 #'
-#' @templateVar note Since all the entries in the \code{data} slot of ctd objects are vectors, \code{i} must be a vector (either logical as in Example 1 or integer as in Example 2), or a function taking a \code{ctd} object and returning such a vector (see \dQuote{Indexing rules}). Note that \code{value} defaults to 4, the WHP-exchange code for a bad CTD measurement, and \code{default} defaults to 2, the code for an acceptable CTD measurement.
+#' @templateVar note Since all the entries in the \code{data} slot of ctd objects are vectors, \code{i} must be a vector (either logical as in Example 1 or integer as in Example 2), or a function taking a \code{ctd} object and returning such a vector (see \dQuote{Indexing rules}). Note that \code{value} defaults to 4, the WHP-exchange code for a bad CTD measurement, and \code{initial} defaults to 2, the code for an acceptable CTD measurement.  Setting \code{scheme="WHP CTD exchange"} (the default) is the same as setting \code{scheme=list(uncalibrated=1, acceptable=2, questionable=3, bad=4, unreported=5, interpolated=6, despiked=7, unsampled=9)}.
 #'
 #' @template setFlagsTemplate
 #'
@@ -254,7 +254,7 @@ setMethod("handleFlags",
 #' ## Salinity range check
 #' S <- ctdRaw[["salinity"]]
 #' oddS <- S < 25 | 40 < S
-#' qc1 <- setFlags(ctdRaw, name="salinity", i=oddS, value=4, default=2)
+#' qc1 <- setFlags(ctdRaw, name="salinity", i=oddS, value=4, initial=2)
 #' pressure <- ctdRaw[["pressure"]]
 #' # Pressure must not jump wildly
 #' pressureSpike <- abs(pressure - smooth(pressure)) > 1
@@ -264,7 +264,8 @@ setMethod("handleFlags",
 #' notDowncast <- c(FALSE, diff(smooth(pressure)) < 0.1)
 #' badPressure <- pressureSpike | lowPressure | notDowncast
 #' # Note that we are adding a flag, so use qc1 below.
-#' qc2 <- setFlags(qc1, name="pressure", i=badPressure, value=4, default=2)
+#' qc2 <- setFlags(qc1, name="pressure", i=badPressure,
+#'                 value=4, initial=2, scheme="WHP CTD exchange")
 #' # Compare results in TS and pressure-scan space
 #' par(mfrow=c(2, 2))
 #' plotTS(ctdRaw)
@@ -289,20 +290,25 @@ setMethod("handleFlags",
 #'         break
 #'     i <- which.min(abs(ctdQC[["SA"]] - xy$x)/Sspan + abs(ctdQC[["CT"]] - xy$y)/Tspan)
 #'     # WHP-CTD convention: 2=acceptable, 4=bad
-#'     ctdQC <- setFlags(ctdQC, "salinity", value=3, i=i, default=2)
+#'     ctdQC <- setFlags(ctdQC, "salinity", value=3, i=i, initial=2)
 #'     ctdQC <- handleFlags(ctdQC)
 #'     plotTS(ctdQC, type="o")
 #' }
 #'}
 #'
 #' @family things related to \code{ctd} data
 setMethod("setFlags",
-          c(object="ctd", name="ANY", i="ANY", value="ANY", default="ANY", debug="ANY"),
-          function(object, name=NULL, i=NULL, value=4, default=2, debug=getOption("oceDebug")) {
-              oceDebug(debug, "setFlags,ctd-method name=", name, ", value=", value, ", default=", default, ", i=", i, "\n")
+          c(object="ctd", name="ANY", i="ANY", value="ANY", initial="ANY", scheme="ANY", debug="ANY"),
+          function(object, name=NULL, i=NULL, value=4, initial=2, scheme=NULL, debug=getOption("oceDebug")) {
+              oceDebug(debug, "setFlags,ctd-method name=", name, ", i, value=", value, ", initial=", initial, "\n")
+              if (!is.null(scheme) && scheme == "WHP CTD exchange")
+                   scheme <- list(uncalibrated=1, acceptable=2, questionable=3, bad=4,
+                                  unreported=5, interpolated=6, despiked=7, unsampled=9)
+
               if (is.null(i) || (!is.vector(i) && !is.function(i)))
                   stop("must supply 'i', a vector or a function returning a vector")
-              res <- setFlagsInternal(object=object, name=name, i=i, value=value, default=default, debug=debug-1)
+              res <- setFlagsInternal(object=object, name=name, i=i,
+                                      value=value, initial=initial, scheme=scheme, debug=debug-1)
               res
           })
 

man-roxygen/setFlagsTemplate.R

@@ -43,16 +43,18 @@
 #' @param name Character string indicating the name of the variable to be flagged. If
 #' this variable is not contained in the object's \code{data} slot, an error is reported.
 #'
-#' @param value The value to be inserted in the flag.
-#'
 #' @param i Indication of where to insert the flags; see \dQuote{Description} for
 #' general rules and \dQuote{Details} for rules for \code{\link{<%=class%>-class}}
 #' objects.
 #'
-#' @param default The default (good) value of the flag. This is used only if
-#' the object does not yet have yet have a entry for \code{name} flags. In that case,
-#' storage is set up for the flag and it is filled with the \code{default} value, after
-#' which \code{setFlags} returns to the task of setting flag values at indicated locations.
+#' @param value The value to be inserted in the flag.
+#'
+#' @param initial A flag value to be used to initialize the flag structure, which
+#' will be done if \code{object} lacks an entry for flags of the indicated
+#' \code{name}.
+#'
+#' @param scheme A list describing the flag scheme, or a character string naming a standardized
+#' scheme (see \dQuote{Details}). This scheme is written in the processing log.
 #'
 #' @param debug Integer set to 0 for quiet action or to 1 for some debugging.
 #'