[CHNOSZ-commits] r777 - in pkg/CHNOSZ: . R demo inst/tinytest

[noreply at r-forge.r-project.org]

Author: jedick
Date: 2023-03-10 15:57:39 +0100 (Fri, 10 Mar 2023)
New Revision: 777

Modified:
   pkg/CHNOSZ/DESCRIPTION
   pkg/CHNOSZ/R/thermo.R
   pkg/CHNOSZ/demo/yttrium.R
   pkg/CHNOSZ/inst/tinytest/test-thermo.R
Log:
Make argument handling in thermo() more like par()


Modified: pkg/CHNOSZ/DESCRIPTION
===================================================================
--- pkg/CHNOSZ/DESCRIPTION	2023-03-09 13:14:21 UTC (rev 776)
+++ pkg/CHNOSZ/DESCRIPTION	2023-03-10 14:57:39 UTC (rev 777)
@@ -1,6 +1,6 @@
-Date: 2023-03-09
+Date: 2023-03-10
 Package: CHNOSZ
-Version: 1.9.9-68
+Version: 1.9.9-69
 Title: Thermodynamic Calculations and Diagrams for Geochemistry
 Authors at R: c(
     person("Jeffrey", "Dick", , "j3ffdick at gmail.com", role = c("aut", "cre"),

Modified: pkg/CHNOSZ/R/thermo.R
===================================================================
--- pkg/CHNOSZ/R/thermo.R	2023-03-09 13:14:21 UTC (rev 776)
+++ pkg/CHNOSZ/R/thermo.R	2023-03-10 14:57:39 UTC (rev 777)
@@ -97,22 +97,65 @@
 }
 
 # A function to access or modify the thermo object 20190214
-thermo <- function(...) {
+# Revised for argument handling more like par() 20230310
+thermo <- function (...) {
+
+  # Get the arguments
   args <- list(...)
-  # Get the object
-  thermo <- get("thermo", CHNOSZ)
+
+  # This part is taken from graphics::par()
+  # To handle only names in c(), e.g. thermo(c("basis", "species"))
+  if (all(unlist(lapply(args, is.character))))
+      args <- as.list(unlist(args))
+#  # To handle an argument analogous to old.par in the example for ?par
+#  # ... but it breaks the "Adding an element" example in ?thermo
+#  if (length(args) == 1) {
+#      if (is.list(args[[1L]]) || is.null(args[[1L]])) 
+#          args <- args[[1L]]
+#  }
+
+  # Get the name of the arguments
+  argnames <- names(args)
+  # Use "" for the name of each unnamed argument
+  if(is.null(argnames)) argnames <- character(length(args))
+
+  # Get the current 'thermo' object
+  value <- original <- thermo <- get("thermo", CHNOSZ)
+  # Loop over arguments
   if(length(args) > 0) {
-    # Assign into the object
-    slots <- names(args)
-    for(i in 1:length(slots)) {
-      # Parse the name of the slot
-      names <- strsplit(slots[i], "$", fixed=TRUE)[[1]]
-      if(length(names) == 1) thermo[[names]] <- args[[i]]
-      if(length(names) == 2) thermo[[names[1]]][[names[2]]] <- args[[i]]
+
+    # Start with an empty return value with the right length
+    value <- vector("list", length(args))
+    for(i in 1:length(argnames)) {
+      if(argnames[i] == "") {
+        # For an unnnamed argument, retrieve the parameter from thermo
+        # Parse the argument value to get the slots
+        slots <- strsplit(args[[i]], "$", fixed = TRUE)[[1]]
+        names <- args[[i]]
+      } else {
+        # For a named argument, assign the parameter in thermo
+        # Parse the name of the argument to get the slots
+        slots <- strsplit(argnames[i], "$", fixed = TRUE)[[1]]
+        names <- argnames[i]
+        # Perform the assignment in the local 'thermo' object
+        if(length(slots) == 1) thermo[[slots[1]]] <- args[[i]]
+        if(length(slots) == 2) thermo[[slots[1]]][[slots[2]]] <- args[[i]]
+      }
+      # Get the (original) parameter value
+      if(length(slots) == 1) orig <- original[[slots[1]]]
+      if(length(slots) == 2) orig <- original[[slots[1]]][[slots[2]]]
+      # Put the parameter into the output value
+      if(!is.null(orig)) value[[i]] <- orig
+      names(value)[i] <- names
     }
+    # Finally perform the assignment to 'thermo' in the CHNOSZ environment
     assign("thermo", thermo, CHNOSZ)
-  } else {
-    # Return the object
-    thermo
+
   }
+
+  # Don't encapsulate a single unassigned parameter in a list
+  if(is.null(names(args)) & length(value) == 1) value <- value[[1]]
+  # Return the value
+  value
+
 }

Modified: pkg/CHNOSZ/demo/yttrium.R
===================================================================
--- pkg/CHNOSZ/demo/yttrium.R	2023-03-09 13:14:21 UTC (rev 776)
+++ pkg/CHNOSZ/demo/yttrium.R	2023-03-10 14:57:39 UTC (rev 777)
@@ -128,7 +128,7 @@
 # Use non-default ion size parameters 20230309
 Bdot_acirc <- thermo()$Bdot_acirc
 # Cl- and Y+3 override the defaults, and YCl+2 is a new species
-Bdot_acirc <- c("Cl-" = 4, "Y+3" = 5, "YCl+2" = 4, Bdot_acirc)
+Bdot_acirc <- c("Cl-" = 4, "Y+3" = 5, "YCl+2" = 4, "YCl2+" = 4, "YCl3" = 4, "YCl4-" = 4, Bdot_acirc)
 thermo("Bdot_acirc" = Bdot_acirc)
 
 # Run the functions to make plots for the demo

Modified: pkg/CHNOSZ/inst/tinytest/test-thermo.R
===================================================================
--- pkg/CHNOSZ/inst/tinytest/test-thermo.R	2023-03-09 13:14:21 UTC (rev 776)
+++ pkg/CHNOSZ/inst/tinytest/test-thermo.R	2023-03-10 14:57:39 UTC (rev 777)
@@ -16,3 +16,32 @@
 # Also check propagation of NA for aqueous species
 mod.OBIGT(name = "[Ala]", state = "aq", G = NA, S = NA)
 expect_true(all(is.na(subcrt("[Ala]", "aq")$out[[1]]$G)), info = info)
+
+
+### Tests added 20230310 for changes to thermo() argument handling more like par()
+
+info <- "Alternative indexing styles give the same result"
+E1 <- thermo()$opt$E.units  # The "old" way
+E2 <- thermo("opt$E.units") # The "new" way in CHNOSZ 2.0.0
+expect_equal(E2, E1, info = info)
+
+info <- "Value retrieved for opt$E.units is J"
+expect_equal(E1, "J", info = info)
+
+## Assign a strange value to opt$E.units
+#oldthermo <- thermo("opt$E.units" = 1234)
+#info <- "Restoring old parameter values is possible"
+#expect_silent(E3 <- thermo(oldthermo), info = info)
+#info <- "Old values are restored correctly"
+#E4 <- thermo("opt$E.units")
+#expect_equal(E4, E1, info = info)
+
+info <- "Parameters can be selected using c() or argument list"
+BS1 <- thermo("basis", "species")
+BS2 <- thermo(c("basis", "species"))
+expect_equal(BS1, BS2, info = info)
+
+info <- "Single parameter gives atomic vector"
+expect_null(names(E1), info = info)
+info <- "Two more parameters give named list"
+expect_equal(names(BS1), c("basis", "species"), info = info)