Commit 968002bb authored by Marco De Lucia's avatar Marco De Lucia
Browse files

Bumped to 0.3.3; fixed AddProp, removed all references to "ListInfo",...

Bumped to 0.3.3; fixed AddProp, removed all references to "ListInfo", introduced some checks in Pourbaix
parent 196a22f9
### R ###
# History files
.Rhistory
.Rapp.history
# Session Data files
.RData
# User-specific files
.Ruserdata
# Example code in package build process
*-Ex.R
# Output files from R CMD build
/*.tar.gz
# Output files from R CMD check
/*.Rcheck/
# RStudio files
.Rproj.user/
# produced vignettes
vignettes/*.html
vignettes/*.pdf
# OAuth2 token, see https://github.com/hadley/httr/releases/tag/v0.3
.httr-oauth
# knitr and R markdown default cache directories
*_cache/
/cache/
# Temporary files created by R markdown
*.utf8.md
*.knit.md
# R Environment Variables
.Renviron
Package: RedModRphree Package: RedModRphree
Title: Programmable Interface to the PHREEQC Geochemical Solver Title: Utilities Leveraging the R Interface to the PHREEQC Geochemical Solver
Version: 0.3.2 Version: 0.3.3
Authors@R: c(person(given = "Marco", Authors@R: c(person(given = "Marco",
family = "De Lucia", family = "De Lucia",
email = "delucia@gfz-potsdam.de", email = "delucia@gfz-potsdam.de",
...@@ -10,10 +10,11 @@ Authors@R: c(person(given = "Marco", ...@@ -10,10 +10,11 @@ Authors@R: c(person(given = "Marco",
family = "Jatnieks", family = "Jatnieks",
email = "deltaxzz@gmail.com", email = "deltaxzz@gmail.com",
role = c("ctb"))) role = c("ctb")))
Description: Programmable interface to the phreeqc geochemical solver Description: Utilities and building blocks for programming with the
adding features such as surrogate models, reactive transport and PHREEQC geochemical solver. Includes features such as 1D reactive
Pourbaix diagrams. transport with surrogate models, database manipulation, parsing of
Depends: R (>= 3.2.0), doParallel, phreeqc, mgcv, graphics, methods, stats, utils, plyr, foreach PHREEQC output files and Pourbaix diagrams.
Depends: R (>= 4.0.1), doParallel, phreeqc, mgcv, graphics, methods, stats, utils, plyr, foreach
License: LGPL-2.1 License: LGPL-2.1
Encoding: UTF-8 Encoding: UTF-8
RoxygenNote: 7.1.1 RoxygenNote: 7.1.1
......
...@@ -20,6 +20,7 @@ export(FindAllSpeciesNames) ...@@ -20,6 +20,7 @@ export(FindAllSpeciesNames)
export(FindAllTotNames) export(FindAllTotNames)
export(FindLogK) export(FindLogK)
export(FindPhase) export(FindPhase)
export(FlattenList)
export(FormSelectedOutput) export(FormSelectedOutput)
export(FormulaFromBal) export(FormulaFromBal)
export(FormulaToExpression) export(FormulaToExpression)
......
### File-related utility functions for RedModRphree ### File-related utility functions for RedModRphree
### Marco De Lucia, delucia@gfz-potsdam.de, 2009-2018 ### Marco De Lucia, delucia@gfz-potsdam.de, 2009-2021
### Time-stamp: "Last modified 2021-04-28 16:52:34 delucia" ### Time-stamp: "Last modified 2021-04-29 18:02:02 delucia"
##' Reads a normal PHREEQC input file and prepares it for ##' Reads a normal PHREEQC input file and prepares it for
...@@ -245,19 +245,18 @@ RReadOut <- function(out) ...@@ -245,19 +245,18 @@ RReadOut <- function(out)
} }
##' Kinetics simulation: reads a phreeqc output file or buffer and ##' Kinetics simulation: reads a PHREEQC output file or buffer and
##' forms an output list. ##' forms an output list.
##' @title RReadOutKin, import the output file of a kinetic simulation ##' @title RReadOutKin, imports the output file of a kinetic
##' into R ##' simulation into R
##' @param out The PHREEQC output file or buffer ##' @param out The PHREEQC output file or buffer
##' @param strip logical. If TRUE, the "ListInfo" element will be
##' appended to the list
##' @param verbose logical. If TRUE more output is given to the ##' @param verbose logical. If TRUE more output is given to the
##' console (for debugging) ##' console (for debugging)
##' @return An output list ##' @return An output list containing one data.frame per
##' "logical block": desc, tot, pphases, species, kin
##' @author MDL ##' @author MDL
##' @export ##' @export
RReadOutKin <- function(out, strip=TRUE, verbose=FALSE) RReadOutKin <- function(out, verbose=FALSE)
{ {
if (length(out)==1) {## is it a buffer or a file? if (length(out)==1) {## is it a buffer or a file?
## note that empty lines are removed! ## note that empty lines are removed!
...@@ -301,10 +300,7 @@ RReadOutKin <- function(out, strip=TRUE, verbose=FALSE) ...@@ -301,10 +300,7 @@ RReadOutKin <- function(out, strip=TRUE, verbose=FALSE)
endtot <- grep('End of simulation',tot,fixed=TRUE) endtot <- grep('End of simulation',tot,fixed=TRUE)
endsim <- c(endsim, endtot-1) endsim <- c(endsim, endtot-1)
if (strip) ## do you want "ListInfo"? reslen <- ntot
reslen <- ntot
else
reslen <- ntot + 1
## create the container ## create the container
res <- vector(mode="list",length=reslen) res <- vector(mode="list",length=reslen)
...@@ -407,13 +403,9 @@ RReadOutKin <- function(out, strip=TRUE, verbose=FALSE) ...@@ -407,13 +403,9 @@ RReadOutKin <- function(out, strip=TRUE, verbose=FALSE)
## end loop over time steps ## end loop over time steps
} }
if (!strip) { names(res) <- c(paste("z",1:ntot,sep=""))
res[[reslen]] <- list(n=ntot,format=TRUE,years=years) attr(res,"time") <- years
names(res) <- c(paste("z",1:ntot,sep=""),"ListInfo")
} else {
names(res) <- c(paste("z",1:ntot,sep=""))
attr(res,"time") <- years
}
return(res) return(res)
} }
...@@ -426,9 +418,8 @@ RReadOutKin <- function(out, strip=TRUE, verbose=FALSE) ...@@ -426,9 +418,8 @@ RReadOutKin <- function(out, strip=TRUE, verbose=FALSE)
##' of specific valence state of an element ##' of specific valence state of an element
##' @param out The PHREEQC output file or buffer ##' @param out The PHREEQC output file or buffer
##' @param valence the specified element valence, e.g., Fe(2) ##' @param valence the specified element valence, e.g., Fe(2)
##' @return An output list, as if the simulation would have being run ##' @return An output list containing one data.frame per
##' through Rphree (the same blocks and the same names are ##' "logical block": desc, tot, pphases, species
##' returned)
##' @author MDL ##' @author MDL
##' @export ##' @export
RReadOutVal <- function(out, valence) RReadOutVal <- function(out, valence)
......
### Licence: LGPL version 2.1 ### Licence: LGPL version 2.1
## Time-stamp: "Last modified 2021-04-28 17:20:11 delucia" ## Time-stamp: "Last modified 2021-04-29 15:56:47 delucia"
##' @title Revert a string ##' @title Revert a string
##' @param x character vector. All element of the vector will be ##' @param x character vector. All element of the vector will be
...@@ -196,16 +196,39 @@ FormSelectedOutput <- function(sim, element) { ...@@ -196,16 +196,39 @@ FormSelectedOutput <- function(sim, element) {
##' Patm=1, base=base, aqonly=TRUE, db=llnl.dat) ##' Patm=1, base=base, aqonly=TRUE, db=llnl.dat)
##' b <- Pourbaix(element="Cu(2)", pe=seq(-10,12, length=51), pH=seq(2,10, length=51), ##' b <- Pourbaix(element="Cu(2)", pe=seq(-10,12, length=51), pH=seq(2,10, length=51),
##' Patm=1, base=base, aqonly=TRUE, db=llnl.dat) ##' Patm=1, base=base, aqonly=TRUE, db=llnl.dat)
Pourbaix <- function(element, pe=seq(-5,8), pH=seq(6,12), Tc=25, Patm=1, base, first, db, Pourbaix <- function(element,
aqonly=FALSE, suppress, ann.title, ann.sub, colors, procs=1, plot=TRUE, pe=seq(-5, 8, length.out = 31),
pH=seq(6, 12, length.out = 31),
Tc=25,
Patm=1,
base,
first,
db,
aqonly=FALSE,
suppress,
ann.title,
ann.sub,
colors,
procs=1,
plot=TRUE,
...) ...)
{ {
phreeqc::phrLoadDatabaseString(db) phreeqc::phrLoadDatabaseString(db)
phreeqc::phrSetOutputStringsOn(TRUE) phreeqc::phrSetOutputStringsOn(TRUE)
## treat "first" as a really optional argument ## "first" is an optional argument
if (missing(first)) if (missing(first))
first <- "" first <- ""
## some checks in "base" - pe, pH, pressure and temp must be
## there, if not, add them to base script
for (prop in c("temp", "pe", "pH", "pressure")) {
if (length(grep(prop,base))==0) {
base <- AddProp(base, name=prop, values = 1, cat="tot")
msg("Adding ", prop, "to base script")
}
}
## testrun of base script to get the output ## testrun of base script to get the output
aa <- phreeqc::phrRunString(c(first, base)) aa <- phreeqc::phrRunString(c(first, base))
con <- phreeqc::phrGetOutputStrings() con <- phreeqc::phrGetOutputStrings()
...@@ -215,7 +238,7 @@ Pourbaix <- function(element, pe=seq(-5,8), pH=seq(6,12), Tc=25, Patm=1, base, f ...@@ -215,7 +238,7 @@ Pourbaix <- function(element, pe=seq(-5,8), pH=seq(6,12), Tc=25, Patm=1, base, f
utils::capture.output(res <- RReadOutVal(con)[[1]]) utils::capture.output(res <- RReadOutVal(con)[[1]])
selout <- FormSelectedOutput(res) selout <- FormSelectedOutput(res)
} else { } else {
## first we distinguish if is total amount of element or if it is a given valence ## first we distinguish if we want total amount of element or a specific valence
if (length(grep("(", element, fixed=TRUE))>0) { if (length(grep("(", element, fixed=TRUE))>0) {
## now we call "valence" the full expression (including the parentheses) ## now we call "valence" the full expression (including the parentheses)
valence <- element valence <- element
...@@ -232,6 +255,7 @@ Pourbaix <- function(element, pe=seq(-5,8), pH=seq(6,12), Tc=25, Patm=1, base, f ...@@ -232,6 +255,7 @@ Pourbaix <- function(element, pe=seq(-5,8), pH=seq(6,12), Tc=25, Patm=1, base, f
} }
## do we only want aqueous species? ## do we only want aqueous species?
## if yes, just suppress SIs from selected output
if (aqonly) { if (aqonly) {
selout <- selout[-grep("-saturation_indices", selout, fixed=TRUE)] selout <- selout[-grep("-saturation_indices", selout, fixed=TRUE)]
} }
...@@ -284,9 +308,9 @@ Pourbaix <- function(element, pe=seq(-5,8), pH=seq(6,12), Tc=25, Patm=1, base, f ...@@ -284,9 +308,9 @@ Pourbaix <- function(element, pe=seq(-5,8), pH=seq(6,12), Tc=25, Patm=1, base, f
} }
doParallel::registerDoParallel(ThisRunCluster) doParallel::registerDoParallel(ThisRunCluster)
msg("Registered default doParallel cluster with ", procs, "nodes\n") msg("Registered default doParallel cluster with ", procs, "nodes")
parallel::clusterCall(cl=ThisRunCluster, phreeqc::phrLoadDatabaseString, db) parallel::clusterCall(cl=ThisRunCluster, phreeqc::phrLoadDatabaseString, db)
msg("Database loaded on each worker\n") msg("Database loaded on each worker")
items <- nrow(fcombs) items <- nrow(fcombs)
if (items %/% procs > 0) if (items %/% procs > 0)
...@@ -472,8 +496,14 @@ Pourbaix <- function(element, pe=seq(-5,8), pH=seq(6,12), Tc=25, Patm=1, base, f ...@@ -472,8 +496,14 @@ Pourbaix <- function(element, pe=seq(-5,8), pH=seq(6,12), Tc=25, Patm=1, base, f
box() box()
} ## plotting } ## plotting
invisible(list(mat=mat, displayed=todisplay, formula=parsednames, is.aq=is.aqueous, invisible(list(mat=mat,
displayed=todisplay,
formula=parsednames,
is.aq=is.aqueous,
phreeqc=list(input=c(first, selout, biginp), pqc=bigres, db=db, res=res), phreeqc=list(input=c(first, selout, biginp), pqc=bigres, db=db, res=res),
dat=dat, vec=vec, aq=aq, eq=eq)) dat=dat,
vec=vec,
aq=aq,
eq=eq))
} }
## Functions for dealing with surrogate simulations ## Functions for dealing with surrogate simulations
### Marco De Lucia, delucia@gfz-potsdam.de, 2009-2021 ### Marco De Lucia, delucia@gfz-potsdam.de, 2009-2021
### Time-stamp: "Last modified 2021-04-28 16:09:22 delucia" ### Time-stamp: "Last modified 2021-04-29 18:05:53 delucia"
##' Computes the average of absolute values of a vector ##' Computes the average of absolute values of a vector
##' @title Average of absolute values ##' @title Average of absolute values
...@@ -11,41 +11,24 @@ ...@@ -11,41 +11,24 @@
##' @export ##' @export
mae <- function(x) mean(abs(x)) mae <- function(x) mean(abs(x))
## ##' .. content for \description{} (no empty lines) ..
## ##' ##' This function is useful when parsing many output files in parallel.
## ##' .. content for \details{} .. ##' @title Flatten a list of Rphree lists
## ##' @title SoftMax transformation ##' @param list list of Rphree lists
## ##' @param obj numeric vector ##' @return a list whose elements are single Rphree simulations
## ##' @return ##' @author MDL
## ##' @author ##' @export
## SoftMax <- function(obj) { FlattenList <- function(list) {
## eo <- exp(obj-max(obj)) tot <- vector(mode="list", length=sum(sapply(list, length)))
## ss <- sum(eo) k <- 1
## scaled <- eo/ss for (i in seq_along(list)) {
## attr(res,"back") <- ss for (j in seq_along(list[[i]])) {
## return(res) tot[[k]] <- list[[i]][[j]]
## } k=k+1
}
## ## SoftMaxBackTransf <- function(vec, back) return(log(vec)+log(back)) }
return(tot)
## ##' @title Flatten out a Rphree list }
## ##' @param list list of Rphree lists
## ##' @param strip logical, should we delete "ListInfo"? Defaults to
## ##' true
## ##' @return a list whose elements are single Rphree simulations
## ##' @author MDL
## ##' @export
## FlattenList <- function(list) {
## tot <- vector(mode="list", length=sum(sapply(stripped, length)))
## k <- 1
## for (i in seq_along(stripped)) {
## for (j in seq_along(stripped[[i]])) {
## tot[[k]] <- stripped[[i]][[j]]
## k=k+1
## }
## }
## return(tot)
## }
##' @title Find all species occurring in the ensemble ##' @title Find all species occurring in the ensemble
...@@ -85,7 +68,7 @@ ExtractSpecies <- function(flatlist, species) { ...@@ -85,7 +68,7 @@ ExtractSpecies <- function(flatlist, species) {
tmp <- matrix(NA, len <- length(flatlist), speclen <- length(species)) tmp <- matrix(NA, len <- length(flatlist), speclen <- length(species))
colnames(tmp) <- species colnames(tmp) <- species
for (i in seq(speclen)) { for (i in seq(speclen)) {
tmp[,i] <- RPinfo(flatlist, "species", species[i], flex=TRUE) tmp[,i] <- RPinfo(flatlist, "species", species[i])
} }
return(tmp) return(tmp)
} }
...@@ -101,7 +84,7 @@ ExtractPphases <- function(flatlist, pphases) { ...@@ -101,7 +84,7 @@ ExtractPphases <- function(flatlist, pphases) {
tmp <- matrix(NA, len <- length(flatlist), speclen <- length(pphases)) tmp <- matrix(NA, len <- length(flatlist), speclen <- length(pphases))
colnames(tmp) <- pphases colnames(tmp) <- pphases
for (i in seq(speclen)) { for (i in seq(speclen)) {
tmp[,i] <- RPinfo(flatlist, "pphase", pphases[i], flex=TRUE) tmp[,i] <- RPinfo(flatlist, "pphase", pphases[i])
} }
return(tmp) return(tmp)
} }
...@@ -119,7 +102,7 @@ ExtractTotals <- function(flatlist, totals) { ...@@ -119,7 +102,7 @@ ExtractTotals <- function(flatlist, totals) {
tmp <- matrix(NA, len <- length(flatlist), speclen <- length(totals)) tmp <- matrix(NA, len <- length(flatlist), speclen <- length(totals))
colnames(tmp) <- totals colnames(tmp) <- totals
for (i in seq(speclen)) { for (i in seq(speclen)) {
tmp[,i] <- RPinfo(flatlist, "tot", totals[i], flex=TRUE) tmp[,i] <- RPinfo(flatlist, "tot", totals[i])
} }
return(tmp) return(tmp)
} }
......
### Utility functions for RedModRphree ### Utility functions for RedModRphree
### Marco De Lucia, delucia@gfz-potsdam.de, 2009-2021 ### Marco De Lucia, delucia@gfz-potsdam.de, 2009-2021
### Time-stamp: "Last modified 2021-04-28 17:06:47 delucia" ### Time-stamp: "Last modified 2021-04-29 17:36:29 delucia"
##' Replicates an input buffer containing only one SOLUTION, taking ##' Replicates an input buffer containing only one SOLUTION, taking
##' care of SOLUTION/KINETICS/PURE identifiers. Eventually insert a ##' care of SOLUTION/KINETICS/PURE identifiers. Eventually insert a
...@@ -31,7 +31,7 @@ RepSol <- function(sol, n, first=NULL) ...@@ -31,7 +31,7 @@ RepSol <- function(sol, n, first=NULL)
if (length(linesol <- grep("^SOLUTION",newsol)) != n) if (length(linesol <- grep("^SOLUTION",newsol)) != n)
{ {
stop("too many or no SOLUTION defined\n") stopmsg("too many or no SOLUTION defined")
} else { } else {
newsol[linesol] <- paste("SOLUTION",1:n) newsol[linesol] <- paste("SOLUTION",1:n)
} }
...@@ -41,7 +41,7 @@ RepSol <- function(sol, n, first=NULL) ...@@ -41,7 +41,7 @@ RepSol <- function(sol, n, first=NULL)
{ {
if (length(linepure) != n) if (length(linepure) != n)
{ {
stop("too many or no PURE defined\n") stopmsg("too many or no PURE defined")
} else { } else {
newsol[linepure] <- paste("PURE",1:n) newsol[linepure] <- paste("PURE",1:n)
} }
...@@ -52,7 +52,7 @@ RepSol <- function(sol, n, first=NULL) ...@@ -52,7 +52,7 @@ RepSol <- function(sol, n, first=NULL)
{ {
if (length(linekin) != n) if (length(linekin) != n)
{ {
stop("too many or no KINET defined\n") stopmsg("too many or no KINET defined")
} else { } else {
newsol[linekin] <- paste("KINETICS",1:n) newsol[linekin] <- paste("KINETICS",1:n)
} }
...@@ -85,56 +85,67 @@ AddProp <- function(input, name, values, cat, kinpar=NULL, first=NULL) ...@@ -85,56 +85,67 @@ AddProp <- function(input, name, values, cat, kinpar=NULL, first=NULL)
reg <- gsub("\\)","\\\\)",reg) reg <- gsub("\\)","\\\\)",reg)
## coerce values to character and find lengths ## coerce values to character and find lengths
n <- length(val <- as.character(values)) val <- as.character(values)
nsim <- length(grep("^SOLUTION",input)) nval <- length(val)
nsim <- length(marksol <- grep("^SOLUTION",input))
if (n != nsim && nsim != 1)
stop("AddProp :: Lengths of simulation and values to add do not agree!\n")
if (cat == "kin") {
if (nsim != 1)
stop(":: AddProp with KINETICS is able to handle only one simul at a time!")
markkin <- max(grep("^KINETIC|step",input))
## add the lines if (nval != nsim && nsim != 1)
tmp <- c(input[1:markkin],name,paste("-m0", val), paste("-parms", kinpar), input[(markkin+1):length(input)]) stopmsg("Lengths of simulation and values to add do not agree!")
if (n!=1)
## use Distribute to create the new input
newinp <- Distribute(tmp, reg, val, first)
else
newinp <- tmp
} else { ## from here pphases and tot
## for now, use "PURE" as delimiter
markpure <- grep("PURE",input)
## one line before if is a "tot" component, one line after if is
## a "pphases"
if (cat == "tot")
markpure <- markpure - 1
if (cat == "tot") {
if (nsim == 1) { if (nsim == 1) {
## if input is just 1 simulation, then first add the line and then ## if input is just 1 simulation, then just insert the line after "SOLUTION"
## repeat it n times (adding "first") tmp <- c(input[1:marksol],paste(name,val),input[(marksol+1):length(input)])
## add the line
tmp <- c(input[1:markpure],paste(name,val),input[(markpure+1):length(input)]) if (nval>1)
if (n!=1)
## use Distribute to create the new input ## use Distribute to create the new input
newinp <- Distribute(tmp, reg, val, first) newinp <- Distribute(tmp, reg, val, first)
else else
newinp <- tmp newinp <- tmp
} else { } else {
## beautiful indexes arithmetic :) marksol <- marksol + seq_along(marksol) ## the line after "SOLUTION"
markpure <- markpure+seq_along(markpure) - ifelse(cat=="tot",1,0) tmp <- character(length(input)+nval)
tmp <- character(length(input)+n) tmp[marksol] <- paste(reg,val)
tmp[markpure] <- paste(reg,val) rest <- seq_along(tmp)[-marksol]
rest <- seq_along(tmp)[-markpure]
tmp[rest] <- input tmp[rest] <- input
## use Distribute to create the new input ## use Distribute to create the new input
newinp <- Distribute(tmp, reg, values, first) newinp <- Distribute(tmp, reg, values, first)
} }
} }
return(newinp)
if (cat == "pphases") {
markpure <- grep("PURE", input)
if (nsim == 1) {
tmp <- c(input[1:markpure], paste(name, val[1]), input[(markpure + 1):length(input)])
if (nval != 1)
newinp <- Distribute(tmp, reg, val, first)
else newinp <- tmp
} else {
markpure <- markpure + seq_along(markpure)
tmp <- character(length(input) + nval)
tmp[markpure] <- paste(reg, val)
rest <- seq_along(tmp)[-markpure]
tmp[rest] <- input
newinp <- Distribute(tmp, reg, values, first)
}
}
if (cat == "kin") {
if (nsim != 1)
stopmsg(" with KINETICS is able to handle only one simul at a time!")
markkin <- max(grep("^KINETIC|step",input))
## add the lines
tmp <- c(input[1:markkin],name,paste("-m0", val), paste("-parms", kinpar), input[(markkin+1):length(input)])
if (nval != 1)
## use Distribute to create the new input
newinp <- Distribute(tmp, reg, val, first)
else
newinp <- tmp
}
return(newinp)
} }
##' Function to distribute different values of one property ##' Function to distribute different values of one property
...@@ -170,25 +181,24 @@ Distribute <- function(input, prop, values, newname=NULL, first=NULL, wholeline= ...@@ -170,25 +181,24 @@ Distribute <- function(input, prop, values, newname=NULL, first=NULL, wholeline=
## coerce values to character ## coerce values to character
n <- length(val <- as.character(values)) n <- length(val <- as.character(values))
nsim <- length(proplines <- grep(paste("^", reg," ", sep=""),input)) nsim <- length(proplines <- grep(paste0("^", reg),input))
if (n != nsim && nsim != 1) { if (n != nsim<