Fixed saving CFArray when the original netCDF file was packed as well.

Author: pvanlaake

NEWS.md

@@ -1,6 +1,8 @@
 # ncdfCF (development version)
 
 -   Fixed `summarise()` when temporal result yields scalar time axis.
+-   Fixed saving a packed `CFArray` when the original netCDF file was packed as
+well.
 
 # ncdfCF 0.4.0
 

R/CFArray.R

@@ -34,6 +34,9 @@
 CFArray <- R6::R6Class("CFArray",
   inherit = CFVariableBase,
   private = list(
+    # The range of the values.
+    actual_range = c(NA_real_, NA_real_),
+
     # Orient self$values in such a way that it conforms to regular R arrays: axis
     # order will be Y-X-Z-T-others and Y values will go from the top to the bottom.
     # Returns a new array.
@@ -87,27 +90,25 @@ CFArray <- R6::R6Class("CFArray",
     #'   prepared for writing into a new netCDF file.
     #' @param values The data of this object. The structure of the data depends
     #'   on the method that produced it.
+    #' @param values_type The unpacked netCDF data type for this object.
     #' @param axes A `list` of [CFAxis] descendant instances that describe the
     #'   axes of the argument `value`.
     #' @param crs The [CFGridMapping] instance of this data object, or `NULL`
     #'   when no grid mapping is available.
     #' @param attributes A `data.frame` with the attributes associated with the
     #'   data in argument `value`.
     #' @return An instance of this class.
-    initialize = function(name, group, values, axes, crs, attributes) {
-      # FIXME: Various other data types
-      first <- typeof(as.vector(values)[1L])
-      dt <- if (first == "double") "NC_DOUBLE"
-            else if (first == "integer") "NC_INT"
-            else stop("Unsupported data type for the values", call. = FALSE)
-
+    initialize = function(name, group, values, values_type, axes, crs, attributes) {
       var <- NCVariable$new(-1L, name, group, dt, 0L, NULL)
       var$attributes <- attributes
       super$initialize(var, group, axes, crs)
 
       self$values <- values
-      if (!all(is.na(self$values)))
-        self$set_attribute("valid_range", dt, range(values, na.rm = TRUE))
+      private$values_type <- values_type
+      if (!all(is.na(self$values))) {
+        private$actual_range <- round(range(values, na.rm = TRUE), 8)
+        self$set_attribute("actual_range", values_type, private$actual_range)
+      }
     },
 
     #' @description Print a summary of the data object to the console.
@@ -117,14 +118,13 @@ CFArray <- R6::R6Class("CFArray",
       if (!is.na(longname) && longname != self$name)
         cat("Long name:", longname, "\n")
 
-      if (all(is.na(self$values))) {
+      if (is.na(private$actual_range[1L])) {
         cat("\nValues: -\n")
         cat(sprintf("    NA: %d (100%%)\n", length(self$values)))
       } else {
-        rng <- range(self$values, na.rm = TRUE)
         units <- self$attribute("units")
         if (is.na(units)) units <- ""
-        cat("\nValues: [", rng[1L], " ... ", rng[2L], "] ", units, "\n", sep = "")
+        cat("\nValues: [", private$actual_range[1L], " ... ", private$actual_range[2L], "] ", units, "\n", sep = "")
         NAs <- sum(is.na(self$values))
         cat(sprintf("    NA: %d (%.1f%%)\n", NAs, NAs * 100 / length(self$values)))
       }
@@ -240,8 +240,11 @@ CFArray <- R6::R6Class("CFArray",
 
     #' @description Save the data object to a netCDF file.
     #' @param fn The name of the netCDF file to create.
+    #' @param pack Logical to indicate if the data should be packed. Packing is
+    #' only useful for numeric data; packing is not performed on integer values.
+    #' Packing is always to the "NC_SHORT" data type, i.e. 16-bits per value.
     #' @return Self, invisibly.
-    save = function(fn) {
+    save = function(fn, pack = FALSE) {
       nc <- RNetCDF::create.nc(fn, prefill = FALSE, format = "netcdf4")
       if (!inherits(nc, "NetCDF"))
         stop("Could not create the netCDF file. Please check that the location of the supplied file name is writable.", call. = FALSE)
@@ -259,17 +262,27 @@ CFArray <- R6::R6Class("CFArray",
         self$set_attribute("grid_mapping", "NC_CHAR", self$crs$name)
       }
 
+      # Packing
+      pack <- pack && !is.na(private$actual_range[1L]) && private$values_type %in% c("NC_FLOAT", "NC_DOUBLE")
+      if (pack) {
+        self$set_attribute("add_offset", private$values_type, (private$actual_range[1L] + private$actual_range[2L]) * 0.5)
+        self$set_attribute("scale_factor", private$values_type, (private$actual_range[2L] - private$actual_range[1L]) / 65534)
+        self$set_attribute("missing_value", "NC_SHORT", -32767)
+      }
+
       # Data variable
-      # FIXME: Pack data
       dim_axes <- length(dim(self$values))
       axis_names <- sapply(self$axes, function(ax) ax$name)
-      RNetCDF::var.def.nc(nc, self$name, self$NCvar$vtype, axis_names[1L:dim_axes])
+      RNetCDF::var.def.nc(nc, self$name, if (pack) "NC_SHORT" else private$values_type, axis_names[1L:dim_axes])
       if (length(self$axes) > dim_axes)
         self$set_attribute("coordinates", "NC_CHAR", paste(axis_names[-(1L:dim_axes)]))
       self$write_attributes(nc, self$name)
-      RNetCDF::var.put.nc(nc, self$name, self$values)
-
+      RNetCDF::var.put.nc(nc, self$name, self$values, pack = pack, na.mode = 2)
       RNetCDF::close.nc(nc)
+
+      if (pack)
+        self$delete_attribute(c("scale_factor", "add_offset", "missing_value"))
+
       invisible(self)
     }
   ),

R/CFAxis.R

@@ -192,7 +192,11 @@ CFAxis <- R6::R6Class("CFAxis",
         self$NCdim$write(h)
         RNetCDF::var.def.nc(h, self$name, self$NCvar$vtype, self$name)
       }
+
+      if (self$orientation %in% c("X", "Y", "Z", "T"))
+        self$set_attribute("axis", "NC_CHAR", self$orientation)
       self$write_attributes(h, self$name)
+
       RNetCDF::var.put.nc(h, self$name, private$get_values())
 
       if (!is.null(self$bounds))

R/CFAxisTime.R

@@ -162,6 +162,20 @@ CFAxisTime <- R6::R6Class("CFAxisTime",
           CFAxisTime$new(group, var, dim, attr(idx, "CFTime"))
         }
       }
+    },
+
+    #' @description Write the axis to a netCDF file, including its attributes.
+    #' If the calendar name is "gregorian", it will be set to the functionally
+    #' identical calendar "standard" as the former is deprecated.
+    #' @param nc The handle of the netCDF file opened for writing or a group in
+    #'   the netCDF file. If `NULL`, write to the file or group where the axis
+    #'   was read from (the file must have been opened for writing). If not
+    #'   `NULL`, the handle to a netCDF file or a group therein.
+    #' @return Self, invisibly.
+    write = function(nc = NULL) {
+      if (self$values$cal$name == "gregorian")
+        self$set_attribute("calendar", "NC_CHAR", "standard")
+      super$write(nc)
     }
   ),
   active = list(

R/CFVariable.R

@@ -169,6 +169,19 @@ CFVariable <- R6::R6Class("CFVariable",
     initialize = function(grp, nc_var, axes) {
       super$initialize(nc_var, grp, axes, NULL)
       nc_var$CF <- self
+
+      # Sanitize attributes for valid range, missing values and packing
+      private$values_type <- self$attribute("scale_factor", "type")
+      if (is.na(private$values_type))
+        private$values_type <- self$attribute("add_offset", "type")
+      if (!is.na(private$values_type))
+        # Data is packed in the netCDF file, throw away the attributes and let
+        # RNetCDF deal with unpacking when reading the data.
+        self$delete_attribute(c("_FillValue", "scale_factor", "add_offset",
+                                "valid_range", "valid_min", "valid_max",
+                                "missing_value"))
+      else
+        private$values_type <- nc_var$vtype
     },
 
     #' @description Print a summary of the data variable to the console.
@@ -255,7 +268,7 @@ CFVariable <- R6::R6Class("CFVariable",
       atts <- self$attributes
       atts <- atts[!(atts$name == "coordinates"), ]
 
-      CFArray$new(self$name, out_group, d, axes, self$crs, atts)
+      CFArray$new(self$name, out_group, d, private$values_type, axes, self$crs, atts)
     },
 
     #' @description This method extracts a subset of values from the array of
@@ -454,7 +467,7 @@ CFVariable <- R6::R6Class("CFVariable",
       # Assemble the CFArray instance
       axes <- c(out_axes_dim, out_axes_other)
       names(axes) <- sapply(axes, function(a) a$name)
-      CFArray$new(self$name, out_group, d, axes, crs, atts)
+      CFArray$new(self$name, out_group, d, private$values_type, axes, crs, atts)
     }
   ),
   active = list(

R/CFVariableBase.R

@@ -10,6 +10,9 @@
 CFVariableBase <- R6::R6Class("CFVariableBase",
   inherit = CFObject,
   private = list(
+    # The netCDF type of the unpacked data of the variable.
+    values_type = NA_character_,
+
     # Return the R order of dimensional axes that "receive special treatment".
     # Scalar axes are not considered here.
     YXZT = function() {
@@ -168,11 +171,11 @@ CFVariableBase <- R6::R6Class("CFVariableBase",
       # Create the output
       len <- length(dt)
       if (len == 1L)
-        CFArray$new(name[1L], self$group, dt[[1L]], ax, self$crs, atts)
+        CFArray$new(name[1L], self$group, dt[[1L]], private$values_type, ax, self$crs, atts)
       else {
         if (length(name) < len)
           name <- c(name, paste0("result_", (length(name)+1L):len))
-        out <- lapply(1:len, function(i) CFArray$new(name[i], self$group, dt[[i]], ax, self$crs, atts))
+        out <- lapply(1:len, function(i) CFArray$new(name[i], self$group, dt[[i]], private$values_type, ax, self$crs, atts))
         names(out) <- name
         out
       }

R/CFVariableL3b.R

@@ -163,7 +163,7 @@ CFVariableL3b <- R6::R6Class("CFVariableL3b",
 
       axes <- lapply(self$axes, function(ax) ax$clone())
 
-      CFArray$new(self$name, out_group, self$as_matrix(), axes, self$crs, self$attributes)
+      CFArray$new(self$name, out_group, self$as_matrix(), private$values_type, axes, self$crs, self$attributes)
     },
 
     #' @description This method extracts a subset of values from the data of the
@@ -264,7 +264,7 @@ CFVariableL3b <- R6::R6Class("CFVariableL3b",
       # Assemble the CFArray instance
       axes <- c(out_axes_dim, out_axes_other)
       names(axes) <- sapply(axes, function(a) a$name)
-      CFArray$new(self$name, out_group, d, axes, self$crs, self$attributes)
+      CFArray$new(self$name, out_group, d, private$values_type, axes, self$crs, self$attributes)
     }
   )
 )

R/NCObject.R

@@ -160,12 +160,12 @@ NCObject <- R6::R6Class("NCObject",
       invisible(self)
     },
 
-    #' @description Delete an attribute. If an attribute `name` is not present
+    #' @description Delete attributes. If an attribute `name` is not present
     #' this method simply returns.
-    #' @param name The name of the attribute to delete.
+    #' @param name Vector of names of the attributes to delete.
     #' @return Self, invisibly.
     delete_attribute = function(name) {
-      self$attributes <- self$attributes[!self$attributes$name == name, ]
+      self$attributes <- self$attributes[!self$attributes$name %in% name, ]
       invisible(self)
     },
 

R/NCVariable.R

@@ -22,7 +22,9 @@ NCVariable <- R6::R6Class("NCVariable",
     #' @field group NetCDF group where this variable is located.
     group   = NULL,
 
-    #' @field vtype The netCDF data type of this variable.
+    #' @field vtype The netCDF data type of this variable. This could be the
+    #' packed type. Don't check this field but use the appropriate method in the
+    #' class of the object whose data type you are looking for.
     vtype   = NULL,
 
     #' @field ndims Number of dimensions that this variable uses.