From noreply at r-forge.r-project.org Sat Feb 2 07:30:41 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 2 Feb 2013 07:30:41 +0100 (CET) Subject: [CHNOSZ-commits] r40 - in pkg/CHNOSZ: . R inst Message-ID: <20130202063041.A2A6B184287@r-forge.r-project.org> Author: jedick Date: 2013-02-02 07:30:41 +0100 (Sat, 02 Feb 2013) New Revision: 40 Modified: pkg/CHNOSZ/DESCRIPTION pkg/CHNOSZ/R/findit.R pkg/CHNOSZ/R/revisit.R pkg/CHNOSZ/inst/NEWS Log: enable DGtr objective in findit(), 1-D DGtr plot in revisit() Modified: pkg/CHNOSZ/DESCRIPTION =================================================================== --- pkg/CHNOSZ/DESCRIPTION 2013-01-26 05:26:34 UTC (rev 39) +++ pkg/CHNOSZ/DESCRIPTION 2013-02-02 06:30:41 UTC (rev 40) @@ -1,6 +1,6 @@ -Date: 2013-01-26 +Date: 2013-02-02 Package: CHNOSZ -Version: 0.9-9.2 +Version: 0.9-9.3 Title: Chemical Thermodynamics and Activity Diagrams Author: Jeffrey M. Dick Maintainer: Jeffrey M. Dick Modified: pkg/CHNOSZ/R/findit.R =================================================================== --- pkg/CHNOSZ/R/findit.R 2013-01-26 05:26:34 UTC (rev 39) +++ pkg/CHNOSZ/R/findit.R 2013-02-02 06:30:41 UTC (rev 40) @@ -119,7 +119,7 @@ a <- do.call(affinity,aargs) # then calculate the values of the objective function e <- equilibrate(a, balance=balance, loga.balance=loga.balance, normalize=normalize) - dd <- revisit(e$loga.equil, objective, loga2=loga2)$H + dd <- revisit(e, objective, loga2=loga2, plot.it=FALSE)$H # coordinates of the extreme value (take only the first set of coords) iopt <- optimal.index(dd, objective)[1,, drop=FALSE] # the extreme value Modified: pkg/CHNOSZ/R/revisit.R =================================================================== --- pkg/CHNOSZ/R/revisit.R 2013-01-26 05:26:34 UTC (rev 39) +++ pkg/CHNOSZ/R/revisit.R 2013-02-02 06:30:41 UTC (rev 40) @@ -120,11 +120,15 @@ # construct array of values: Astar (for DGtr) if(any(grepl("Astar", objargs))) { Astar <- eout$Astar[ispecies] +eout <<- eout + # one row for each condition Astar <- sapply(Astar, as.vector) + # for 0-D case we want a 1-row matrix (sapply simplifies to vector) + if(nd==0) Astar <- t(Astar) } # calculation of the objective function - # "H" is a remnant of the first target, shannon entropy + # the symbol "H" is reminiscent of the first implemented target, shannon entropy if(length(objargs) == 1) H <- objfun(a1) else if(length(objargs) == 2) H <- objfun(a1, a2) else if(length(objargs) == 3) H <- objfun(a1, a2, Astar) @@ -161,7 +165,7 @@ # add a 1:1 line lines(range(loga2), range(loga2), col="grey") # add a lowess line - ls <- loess.smooth(loga2, loga1) + ls <- loess.smooth(loga2, loga1, family="gaussian") lines(ls$x, ls$y, col="red") } else plot.it <- FALSE # add a title Modified: pkg/CHNOSZ/inst/NEWS =================================================================== --- pkg/CHNOSZ/inst/NEWS 2013-01-26 05:26:34 UTC (rev 39) +++ pkg/CHNOSZ/inst/NEWS 2013-02-02 06:30:41 UTC (rev 40) @@ -12,6 +12,8 @@ - Add example for LYSC_CHICK to protein.info.Rd. +- Enable DGtr in findit(), 1-D DGtr plot in revisit(). + CHANGES IN CHNOSZ 0.9-9 (2013-01-01) ------------------------------------ From noreply at r-forge.r-project.org Wed Feb 6 16:17:21 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 6 Feb 2013 16:17:21 +0100 (CET) Subject: [CHNOSZ-commits] r41 - in pkg/CHNOSZ: . R data inst inst/tests man src Message-ID: <20130206151721.76CF6183B50@r-forge.r-project.org> Author: jedick Date: 2013-02-06 16:17:21 +0100 (Wed, 06 Feb 2013) New Revision: 41 Added: pkg/CHNOSZ/R/IAPWS95.R pkg/CHNOSZ/inst/tests/test-IAPWS95.R pkg/CHNOSZ/inst/tests/test-util.seq.R pkg/CHNOSZ/man/IAPWS95.Rd Removed: pkg/CHNOSZ/inst/tests/test-water.IAPWS95.R Modified: pkg/CHNOSZ/DESCRIPTION pkg/CHNOSZ/R/iprotein.R pkg/CHNOSZ/R/subcrt.R pkg/CHNOSZ/R/util.args.R pkg/CHNOSZ/R/util.data.R pkg/CHNOSZ/R/util.expression.R pkg/CHNOSZ/R/util.fasta.R pkg/CHNOSZ/R/util.seq.R pkg/CHNOSZ/R/water.R pkg/CHNOSZ/data/xxx.R pkg/CHNOSZ/data/yyy.R pkg/CHNOSZ/inst/NEWS pkg/CHNOSZ/inst/tests/test-iprotein.R pkg/CHNOSZ/inst/tests/test-subcrt.R pkg/CHNOSZ/inst/tests/test-util.R pkg/CHNOSZ/man/eos.Rd pkg/CHNOSZ/man/iprotein.Rd pkg/CHNOSZ/man/protein.Rd pkg/CHNOSZ/man/protein.info.Rd pkg/CHNOSZ/man/revisit.Rd pkg/CHNOSZ/man/subcrt.Rd pkg/CHNOSZ/man/util.fasta.Rd pkg/CHNOSZ/man/util.seq.Rd pkg/CHNOSZ/man/water.Rd pkg/CHNOSZ/src/H2O92D.f Log: allow subzero (to -20 degrees C) calculations in H2O92D.f Modified: pkg/CHNOSZ/DESCRIPTION =================================================================== --- pkg/CHNOSZ/DESCRIPTION 2013-02-02 06:30:41 UTC (rev 40) +++ pkg/CHNOSZ/DESCRIPTION 2013-02-06 15:17:21 UTC (rev 41) @@ -1,6 +1,6 @@ -Date: 2013-02-02 +Date: 2013-02-06 Package: CHNOSZ -Version: 0.9-9.3 +Version: 0.9-9.4 Title: Chemical Thermodynamics and Activity Diagrams Author: Jeffrey M. Dick Maintainer: Jeffrey M. Dick Added: pkg/CHNOSZ/R/IAPWS95.R =================================================================== --- pkg/CHNOSZ/R/IAPWS95.R (rev 0) +++ pkg/CHNOSZ/R/IAPWS95.R 2013-02-06 15:17:21 UTC (rev 41) @@ -0,0 +1,299 @@ +# functions for properties of water using +# the IAPWS-95 formulation (Wagner and Pruss, 2002) + +IAPWS95.idealgas <- function(p, delta, tau) { + ## the ideal gas part in the IAPWS-95 formulation + # from Table 6.1 of Wagner and Pruss, 2002 + n <- c( -8.32044648201, 6.6832105268, 3.00632, 0.012436, + 0.97315, 1.27950, 0.96956, 0.24873 ) + gamma <- c( NA, NA, NA, 1.28728967, + 3.53734222, 7.74073708, 9.24437796, 27.5075105 ) + # Equation 6.5 + phi <- function() log(delta) + n[1] + n[2]*tau + n[3]*log(tau) + + sum( n[4:8] * log(1-exp(-gamma[4:8]*tau)) ) + # derivatives from Table 6.4 + phi.delta <- function() 1/delta+0+0+0+0 + phi.delta.delta <- function() -1/delta^2+0+0+0+0 + phi.tau <- function() 0+0+n[2]+n[3]/tau+sum(n[4:8]*gamma[4:8]*((1-exp(-gamma[4:8]*tau))^-1-1)) + phi.tau.tau <- function() 0+0+0-n[3]/tau^2-sum(n[4:8]*gamma[4:8]^2 * + exp(-gamma[4:8]*tau)*(1-exp(-gamma[4:8]*tau))^-2) + phi.delta.tau <- function() 0+0+0+0+0 + return(get(p)()) +} + +IAPWS95.residual <- function(p, delta, tau) { + ## the residual part in the IAPWS-95 formulation + # from Table 6.2 of Wagner and Pruss, 2002 + c <- c(rep(NA,7),rep(1,15),rep(2,20),rep(3,4),4,rep(6,4),rep(NA,5)) + d <- c(1,1,1,2,2,3,4,1,1,1,2,2,3,4, + 4,5,7,9,10,11,13,15,1,2,2,2,3,4, + 4,4,5,6,6,7,9,9,9,9,9,10,10,12, + 3,4,4,5,14,3,6,6,6,3,3,3,NA,NA) + t <- c(-0.5,0.875,1,0.5,0.75,0.375,1,4,6,12,1,5,4,2, + 13,9,3,4,11,4,13,1,7,1,9,10,10,3, + 7,10,10,6,10,10,1,2,3,4,8,6,9,8, + 16,22,23,23,10,50,44,46,50,0,1,4,NA,NA) + n <- c( 0.12533547935523E-1, 0.78957634722828E1 ,-0.87803203303561E1 , + 0.31802509345418 ,-0.26145533859358 ,-0.78199751687981E-2, + 0.88089493102134E-2,-0.66856572307965 , 0.20433810950965 , + -0.66212605039687E-4,-0.19232721156002 ,-0.25709043003438 , + 0.16074868486251 ,-0.40092828925807E-1, 0.39343422603254E-6, + -0.75941377088144E-5, 0.56250979351888E-3,-0.15608652257135E-4, + 0.11537996422951E-8, 0.36582165144204E-6,-0.13251180074668E-11, + -0.62639586912454E-9,-0.10793600908932 , 0.17611491008752E-1, + 0.22132295167546 ,-0.40247669763528 , 0.58083399985759 , + 0.49969146990806E-2,-0.31358700712549E-1,-0.74315929710341 , + 0.47807329915480 , 0.20527940895948E-1,-0.13636435110343 , + 0.14180634400617E-1, 0.83326504880713E-2,-0.29052336009585E-1, + 0.38615085574206E-1,-0.20393486513704E-1,-0.16554050063734E-2, + 0.19955571979541E-2, 0.15870308324157E-3,-0.16388568342530E-4, + 0.43613615723811E-1, 0.34994005463765E-1,-0.76788197844621E-1, + 0.22446277332006E-1,-0.62689710414685E-4,-0.55711118565645E-9, + -0.19905718354408 , 0.31777497330738 ,-0.11841182425981 , + -0.31306260323435E2 , 0.31546140237781E2 ,-0.25213154341695E4 , + -0.14874640856724 , 0.31806110878444) + alpha <- c(rep(NA,51),20,20,20,NA,NA) + beta <- c(rep(NA,51),150,150,250,0.3,0.3) + gamma <- c(rep(NA,51),1.21,1.21,1.25,NA,NA) + epsilon <- c(rep(NA,51),1,1,1,NA,NA) + a <- c(rep(NA,54),3.5,3.5) + b <- c(rep(NA,54),0.85,0.95) + B <- c(rep(NA,54),0.2,0.2) + C <- c(rep(NA,54),28,32) + D <- c(rep(NA,54),700,800) + A <- c(rep(NA,54),0.32,0.32) + # from Table 6.5 + i1 <- 1:7 + i2 <- 8:51 + i3 <- 52:54 + i4 <- 55:56 + # deriviatives of distance function + Delta <- function(i) { Theta(i)^2 + B[i] * ((delta-1)^2)^a[i] } + Theta <- function(i) { (1-tau) + A[i] * ((delta-1)^2)^(1/(2*beta[i])) } + Psi <- function(i) { exp ( -C[i]*(delta-1)^2 - D[i]*(tau-1)^2 ) } + dDelta.bi.ddelta <- function(i) { b[i]*Delta(i)^(b[i]-1)*dDelta.ddelta(i) } + d2Delta.bi.ddelta2 <- function(i) { b[i]*( Delta(i)^(b[i]-1) * d2Delta.ddelta2(i) + + (b[i]-1)*Delta(i)^(b[i]-2)*dDelta.ddelta(i)^2 ) } + dDelta.bi.dtau <- function(i) { -2*Theta(i)*b[i]*Delta(i)^(b[i]-1) } + d2Delta.bi.dtau2 <- function(i) { 2*b[i]*Delta(i)^(b[i]-1) + 4*Theta(i)^2*b[i]*(b[i]-1)*Delta(i)^(b[i]-2) } + d2Delta.bi.ddelta.dtau <- function(i) { -A[i]*b[i]*2/beta[i]*Delta(i)^(b[i]-1)*(delta-1) * + ((delta-1)^2)^(1/(2*beta[i])-1) - 2*Theta(i)*b[i]*(b[i]-1)*Delta(i)^(b[i]-2)*dDelta.ddelta(i) } + dDelta.ddelta <- function(i) { (delta-1) * ( A[i]*Theta(i)*2/beta[i]*((delta-1)^2)^(1/(2*beta[i])-1) + + 2*B[i]*a[i]*((delta-1)^2)^(a[i]-1) ) } + d2Delta.ddelta2 <- function(i) { 1/(delta-1)*dDelta.ddelta(i) + (delta-1)^2 * ( + 4*B[i]*a[i]*(a[i]-1)*((delta-1)^2)^(a[i]-2) + 2*A[i]^2*(1/beta[i])^2 * + (((delta-1)^2)^(1/(2*B[i])-1))^2 + A[i]*Theta(i)*4/beta[i]*(1/(2*B[i])-1) * + ((delta-1)^2)^(1/(2*beta[i])-2) ) } + # derivatives of exponential function + dPsi.ddelta <- function(i) { -2*C[i]*(delta-1)*Psi(i) } + d2Psi.ddelta2 <- function(i) { ( 2*C[i]*(delta-1)^2 - 1 ) * 2*C[i]*Psi(i) } + dPsi.dtau <- function(i) { -2*D[i]*(tau-1)*Psi(i) } + d2Psi.dtau2 <- function(i) { (2*D[i]*(tau-1)^2 - 1) * 2*D[i]*Psi(i) } + d2Psi.ddelta.dtau <- function(i) { 4*C[i]*D[i]*(delta-1)*(tau-1)*Psi(i) } + # dimensionless Helmholtz free energy and derivatives + phi <- function() { + sum(n[i1]*delta^d[i1]*tau^t[i1]) + + sum(n[i2]*delta^d[i2]*tau^t[i2]*exp(-delta^c[i2])) + + sum(n[i3]*delta^d[i3]*tau^t[i3] * + exp( -alpha[i3]*(delta-epsilon[i3])^2 - beta[i3]*(tau-gamma[i3])^2 ) ) + + sum(n[i4]*Delta(i4)^b[i4]*delta*Psi(i4)) + } + phi.delta <- function() { + sum(n[i1]*d[i1]*delta^(d[i1]-1)*tau^t[i1]) + + sum(n[i2]*exp(-delta^c[i2])*(delta^(d[i2]-1)*tau^t[i2]*(d[i2]-c[i2]*delta^c[i2]))) + + sum(n[i3]*delta^d[i3]*tau^t[i3] * + exp( -alpha[i3]*(delta-epsilon[i3])^2 - beta[i3]*(tau-gamma[i3])^2 ) * + (d[i3]/delta - 2 * alpha[i3]*(delta-epsilon[i3])) ) + + sum(n[i4] * ( Delta(i4)^b[i4] * (Psi(i4)+delta*dPsi.ddelta(i4)) + dDelta.bi.ddelta(i4)*delta*Psi(i4) ) ) + } + phi.delta.delta <- function() { + sum(n[i1]*d[i1]*(d[i1]-1)*delta^(d[i1]-2)*tau^t[i1]) + + sum(n[i2]*exp(-delta^c[i2])*(delta^(d[i2]-2)*tau^t[i2]*((d[i2]-c[i2]*delta^c[i2]) * + (d[i2]-1-c[i2]*delta^c[i2])-c[i2]^2*delta^c[i2]))) + + sum(n[i3]*tau^t[i3]*exp(-alpha[i3]*(delta-epsilon[i3])^2 - beta[i3]*(tau-gamma[i3])^2) * ( + -2*alpha[i3]*delta^d[i3]+4*alpha[i3]^2*delta^d[i3]*(delta-epsilon[i3])^2 - + 4*d[i3]*alpha[i3]*delta^(d[i3]-1)*(delta-epsilon[i3])+d[i3]*(d[i3]-1)*delta^(d[i3]-2) ) ) + + sum(n[i4]*( Delta(i4)^b[i4]*(2*dPsi.ddelta(i4)+delta*d2Psi.ddelta2(i4)) + + 2*dDelta.bi.ddelta(i4)*(Psi(i4)+delta*dPsi.ddelta(i4)) + d2Delta.bi.ddelta2(i4)*delta*Psi(i4) ) ) + } + phi.tau <- function() { + sum(n[i1]*t[i1]*delta^d[i1]*tau^(t[i1]-1)) + + sum(n[i2]*t[i2]*delta^d[i2]*tau^(t[i2]-1)*exp(-delta^c[i2])) + + sum(n[i3]*delta^d[i3]*tau^t[i3]*exp(-alpha[i3]*(delta-epsilon[i3])^2-beta[i3]*(tau-gamma[i3])^2) * + (t[i3]/tau-2*beta[i3]*(tau-gamma[i3]))) + + sum(n[i4]*delta*(dDelta.bi.dtau(i4)*Psi(i4)+Delta(i4)^b[i4]*dPsi.dtau(i4))) + } + phi.tau.tau <- function() { + sum(n[i1]*t[i1]*(t[i1]-1)*delta^d[i1]*tau^(t[i1]-2)) + + sum(n[i2]*t[i2]*(t[i2]-1)*delta^d[i2]*tau^(t[i2]-2)*exp(-delta^c[i2])) + + sum(n[i3]*delta^d[i3]*tau^t[i3]*exp(-alpha[i3]*(delta-epsilon[i3])^2-beta[i3]*(tau-gamma[i3])^2) * + (((t[i3]/tau)-2*beta[i3]*(tau-gamma[i3]))^2-t[i3]/tau^2-2*beta[i3])) + + sum(n[i4]*delta*(d2Delta.bi.dtau2(i4)*Psi(i4)+2*dDelta.bi.dtau(i4)*dPsi.dtau(i4) + + Delta(i4)^b[i4]*d2Psi.dtau2(i4))) + } + phi.delta.tau <- function() { + sum(n[i1]*d[i1]*t[i1]*delta^(d[i1]-1)*tau^(t[i1]-1)) + + sum(n[i2]*t[i2]*delta^(d[i2]-1)*tau^(t[i2]-1)*(d[i2]-c[i2]*delta^c[i2])*exp(-delta^c[i2])) + + sum(n[i3]*delta^d[i3]*tau^t[i3]*exp(-alpha[i3]*(delta-epsilon[i3])^2-beta[i3]*(tau-gamma[i3])^2) * + ((d[i3]/delta)-2*alpha[i3]*(delta-epsilon[i3]))*(t[i3]/tau-2*beta[i3]*(tau-gamma[i3])) ) + + sum(n[i4]*(Delta(i4)^b[i4]*(dPsi.dtau(i4)+delta*d2Psi.ddelta.dtau(i4)) + + delta*dDelta.bi.ddelta(i4)*dPsi.dtau(i4)+dDelta.bi.dtau(i4) * (Psi(i4)+delta*dPsi.ddelta(i4)) + + d2Delta.bi.ddelta.dtau(i4)*delta*Psi(i4) )) + } + return(get(p)()) +} + +IAPWS95 <- function(property,T=298.15,rho=1000) { + ## the IAPWS-95 formulation for ordinary water substance + ## Wagner and Pruss, 2002 + property <- tolower(property) + # triple point + T.triple <- 273.16 # K + P.triple <- 611.657 # Pa + rho.triple.liquid <- 999.793 + rho.triple.vapor <- 0.00485458 + # normal boiling point + T.boiling <- 373.124 + P.boiling <- 0.101325 + rho.boiling.liquid <- 958.367 + rho.boiling.vapor <- 0.597657 + # critical point constants + T.critical <- 647.096 # K + rho.critical <- 322 # kg m-3 + # specific and molar gas constants + R <- 0.46151805 # kJ kg-1 K-1 + # R.M <- 8.314472 # J mol-1 K-1 + # molar mass + M <- 18.015268 # g mol-1 + ## define functions idealgas and residual, supplying arguments delta and tau + idealgas <- function(p) IAPWS95.idealgas(p, delta, tau) + residual <- function(p) IAPWS95.residual(p, delta, tau) + ## relation of thermodynamic properties to Helmholtz free energy + a <- function() { + x <- idealgas('phi')+residual('phi') + return(x*R*T) + } + # Table 6.3 + p <- function() { + x <- 1 + delta*residual('phi.delta') + return(x*rho*R*T/1000) # for MPa + } + s <- function() { + x <- tau * (idealgas('phi.tau')+residual('phi.tau'))-idealgas('phi')-residual('phi') + return(x*R) + } + u <- function() { + x <- tau * (idealgas('phi.tau')+residual('phi.tau')) + return(x*R*T) + } + h <- function() { + x <- 1 + tau * (idealgas('phi.tau')+residual('phi.tau')) + delta*residual('phi.delta') + return(x*R*T) + } + g <- function() { + x <- 1 + idealgas('phi') + residual('phi') + delta*residual('phi.delta') + return(x*R*T) + } + cv <- function() { + x <- -tau^2*(idealgas('phi.tau.tau')+residual('phi.tau.tau')) + return(x*R) + } + cp <- function() { + x <- -tau^2*(idealgas('phi.tau.tau')+residual('phi.tau.tau')) + + (1+delta*residual('phi.delta')-delta*tau*residual('phi.delta.tau'))^2 / + (1+2*delta*residual('phi.delta')+delta^2*residual('phi.delta.delta')) + return(x*R) + } +# 20090420 speed of sound calculation is incomplete +# (delta.liquid and drhos.dT not visible) +# cs <- function() { +# x <- -tau^2*(idealgas('phi.tau.tau')+residual('phi.tau.tau')) + +# (1+delta*residual('phi.delta')-delta*tau*residual('phi.delta.tau'))^2 / +# (1+2*delta*residual('phi.delta')+delta^2*residual('phi.delta.delta')) * +# ((1+delta.liquid*residual('phi.delta')-delta.liquid*tau*residual('phi.tau.tau'))-rho.critical/(R*delta.liquid)*drhos.dT) +# return(x*R) +# } + w <- function() { + x <- 1 + 2*delta*residual('phi.delta') + delta^2*residual('phi.delta.delta') - + (1+delta*residual('phi.delta')-delta*tau*residual('phi.delta.tau'))^2 / + tau^2*(idealgas('phi.tau.tau')+residual('phi.tau.tau')) + return(sqrt(x*R*T)) + } + mu <- function() { + x <- -(delta*residual('phi.delta')+delta^2*residual('phi.delta.delta')+delta*tau*residual('phi.delta.tau')) / + ( ( 1+delta*residual('phi.delta')-delta*tau*residual('phi.delta.tau')^2 ) - tau^2 * + (idealgas('phi.tau.tau')+residual('phi.tau.tau'))*(1+2*delta*residual('phi.delta')+delta^2*residual('phi.delta.delta')) ) + return(x/(R*rho)) + } + ## run the calculations + ww <- NULL + my.T <- T + my.rho <- rho + for(j in 1:length(property)) { + t <- numeric() + for(i in 1:length(my.T)) { + T <- my.T[i] + rho <- my.rho[i] + # Equation 6.4 + delta <- rho / rho.critical + tau <- T.critical / T + t <- c(t,get(property[j])()) + } + t <- data.frame(t) + if(j==1) ww <- t else ww <- cbind(ww,t) + } + colnames(ww) <- property + return(ww) +} + +WP02.auxiliary <- function(property='rho.liquid',T=298.15) { + # auxiliary equations for liquid-vapor phase boundary + # from Wagner and Pruss, 2002 + # critical point + T.critical <- 647.096 # K + P.critical <- 22.064 # MPa + rho.critical <- 322 # kg m-3 + + if(property %in% c("P.sigma","dP.sigma.dT")) { + # vapor pressure + V <- 1 - T / T.critical # theta (dimensionless) + a1 <- -7.85951783 + a2 <- 1.84408259 + a3 <- -11.7866497 + a4 <- 22.6807411 + a5 <- -15.9618719 + a6 <- 1.80122502 + ln.P.sigma.P.critical <- T.critical / T * + ( a1*V + a2*V^1.5 + a3*V^3 + a4*V^3.5 + a5*V^4 + a6*V^7.5 ) + P.sigma <- P.critical * exp(ln.P.sigma.P.critical) + if(property=="dP.sigma.dT") out <- - P.sigma / T * ( ln.P.sigma.P.critical + + a1 + 1.5*a2*V^0.5 + 3*a3*V^2 + 3.5*a4*V^2.5 + 4*a5*V^3 + 7.5*a6*V^6.5 ) + else out <- P.sigma + } else if(property=="rho.liquid") { + # saturated liquid density + V <- 1 - T / T.critical + b1 <- 1.99274064 + b2 <- 1.09965342 + b3 <- -0.510839303 + b4 <- -1.75493479 + b5 <- -45.5170352 + b6 <- -6.74694450E5 + rho.liquid <- rho.critical * ( + 1 + b1*V^(1/3) + b2*V^(2/3) + b3*V^(5/3) + b4*V^(16/3) + b5*V^(43/3) + b6*V^(110/3) ) + out <- rho.liquid + } else if(property=="rho.vapor") { + # saturated vapor density + V <- 1 - T / T.critical + c1 <- -2.03150240 + c2 <- -2.68302940 + c3 <- -5.38626492 + c4 <- -17.2991605 + c5 <- -44.7586581 + c6 <- -63.9201063 + rho.vapor <- rho.critical * exp ( + c1*V^(2/6) + c2*V^(4/6) + c3*V^(8/6) + c4*V^(18/6) + c5*V^(37/6) + c6*V^(71/6) ) + out <- rho.vapor + } else stop(paste('i can not calculate',property)) + return(out) +} + Modified: pkg/CHNOSZ/R/iprotein.R =================================================================== --- pkg/CHNOSZ/R/iprotein.R 2013-02-02 06:30:41 UTC (rev 40) +++ pkg/CHNOSZ/R/iprotein.R 2013-02-06 15:17:21 UTC (rev 41) @@ -6,7 +6,6 @@ # ip2aa - select amino acid counts (data frame) from thermo$protein # aa2eos - perform group additivity calculations # seq2aa - calculate amino acid counts from a sequence -# dl.aa - get amino acid counts from SWISS-PROT # aasum - combine amino acid counts (sum, average, or weighted sum by abundance) # read.aa - read amino acid counts from a file # add.protein - add amino acid counts to thermo$protein (returns iprotein) @@ -116,48 +115,6 @@ return(aa) } -dl.aa <- function(protein) { - # download protein sequence information from SWISS-PROT - iprotein <- numeric() - # construct the initial URL - proteinURL <- paste("http://www.uniprot.org/uniprot/", protein, sep="") - msgout("dl.aa: trying ", proteinURL, " ...") - # try loading the URL, hiding any warnings - oldopt <- options(warn=-1) - URLstuff <- try(readLines(proteinURL),TRUE) - options(oldopt) - if(class(URLstuff)=="try-error") { - msgout(" failed\n") - return(NA) - } - # 20091102: look for a link to a fasta file - linkline <- URLstuff[[grep("/uniprot/.*fasta", URLstuff)[1]]] - # extract accession number from the link - linkhead <- strsplit(linkline, ".fasta", fixed=TRUE)[[1]][1] - accession.number <- tail(strsplit(linkhead, "/uniprot/", fixed=TRUE)[[1]], 1) - msgout(" accession ", accession.number, " ...\n") - # now download the fasta file - fastaURL <- paste("http://www.uniprot.org/uniprot/", accession.number, ".fasta", sep="") - URLstuff <- readLines(fastaURL) - # show the name of the protein to the user - header <- URLstuff[[1]] - header2 <- strsplit(header, paste(protein, ""))[[1]][2] - header3 <- strsplit(header2, " OS=")[[1]] - protein.name <- header3[1] - header4 <- strsplit(header3[2], " GN=")[[1]][1] - header5 <- strsplit(header4[1], " PE=")[[1]] - organism.name <- header5[1] - msgout("dl.aa: ", protein.name, " from ", organism.name) - # get rid of the header before counting amino acid letters - URLstuff[[1]] <- "" - aa <- count.aa(c2s(URLstuff, sep="")) - msgout(" (length ", sum(aa[1,]), ")\n", sep="") - colnames(aa) <- colnames(thermo$protein)[6:25] - po <- strsplit(protein, "_")[[1]] - out <- data.frame(protein=po[1], organism=po[2], ref=NA, abbrv=NA, chains=1, aa) - return(out) -} - aasum <- function(aa, abundance=1, average=FALSE, protein=NULL, organism=NULL) { # returns the sum of the amino acid counts in aa, # multiplied by the abundances of the proteins @@ -191,21 +148,14 @@ } read.aa <- function(file="protein.csv") { - # if its a fasta file, read the sequences - if(is.fasta(file)) { - aa <- read.fasta(file) - msgout("read.aa: first line in FASTA file is\n") - msgout(readLines(file, n=1), "\n") - } else { - # 20090428 added colClasses here - aa <- read.csv(file,colClasses=c(rep("character",4),rep("numeric",21))) - } + # 20090428 added colClasses here + aa <- read.csv(file,colClasses=c(rep("character",4),rep("numeric",21))) if(!identical(colnames(aa), colnames(thermo$protein))) - stop("format of", file, "is incompatible with thermo$protein") + stop(paste("format of", file, "is incompatible with thermo$protein")) return(aa) } -add.protein <- function(aa, print.existing=FALSE) { +add.protein <- function(aa) { # add a properly constructed data frame of # amino acid counts to thermo$protein if(!identical(colnames(aa), colnames(thermo$protein))) @@ -215,15 +165,13 @@ ip <- suppressMessages(iprotein(po)) ipdup <- !is.na(ip) # now we're ready to go - thermo$protein <<- rbind(thermo$protein, aa[!ipdup, ]) + if(!all(ipdup)) thermo$protein <<- rbind(thermo$protein, aa[!ipdup, ]) + if(any(ipdup)) thermo$protein[ip[ipdup], ] <<- aa[ipdup, ] rownames(thermo$protein) <<- NULL # return the new rownumbers ip <- iprotein(po) # make some noise - msgout("add.protein: added ", nrow(aa)-sum(ipdup), " of ", nrow(aa), " proteins\n") - if(!all(is.na(ipdup)) & print.existing) { - potext <- paste(aa$protein[ipdup], aa$organism[ipdup], sep="_", collapse=" ") - msgout("add.protein: skipped existing ", potext, "\n") - } + if(!all(ipdup)) msgout("add.protein: added ", nrow(aa)-sum(ipdup), " new protein(s) to thermo$protein\n") + if(any(ipdup)) msgout("add.protein: replaced ", sum(ipdup), " existing protein(s) in thermo$protein\n") return(ip) } Modified: pkg/CHNOSZ/R/subcrt.R =================================================================== --- pkg/CHNOSZ/R/subcrt.R 2013-02-02 06:30:41 UTC (rev 40) +++ pkg/CHNOSZ/R/subcrt.R 2013-02-06 15:17:21 UTC (rev 41) @@ -180,6 +180,7 @@ } if(length(P)==1) { if(can.be.numeric(P)) P.text <- paste(round(as.numeric(P),2),'bar') + else P.text <- "P" } else P.text <- 'P' #} else P.text <- paste(length(P),'values of P') if(identical(P[[1]],'Psat')) P.text <- P Modified: pkg/CHNOSZ/R/util.args.R =================================================================== --- pkg/CHNOSZ/R/util.args.R 2013-02-02 06:30:41 UTC (rev 40) +++ pkg/CHNOSZ/R/util.args.R 2013-02-06 15:17:21 UTC (rev 41) @@ -6,7 +6,6 @@ props <- c('G','H','S','Cp','V','kT','E') if(eos=='water') { # things we also get with water - #props <- c(colnames(thermo$water)[4:length(colnames(thermo$water))]) props <- c(props,'A','U','Cv','Psat','rho','Q','X','Y','epsilon','w') # they keep on coming: things we also get with SUPCRT92 if(length(agrep(tolower(thermo$opt$water),'supcrt9',max.distance=0.3))>0) Modified: pkg/CHNOSZ/R/util.data.R =================================================================== --- pkg/CHNOSZ/R/util.data.R 2013-02-02 06:30:41 UTC (rev 40) +++ pkg/CHNOSZ/R/util.data.R 2013-02-06 15:17:21 UTC (rev 41) @@ -318,7 +318,7 @@ # we use the value of X consistent with SUPCRT X <- -3.055586E-7 refval <- eos$Cp - calcval <- eos$c1 + eos$c2/(298.15-228)^2 + eos$omega*298.15*X + calcval <- eos$c1 + eos$c2/(298.15-thermo$opt$Theta)^2 + eos$omega*298.15*X tol <- thermo$opt$Cp.tol units <- "cal K-1 mol-1" } else if(prop=="V") { @@ -328,7 +328,7 @@ Q <- 0.00002775729 refval <- eos$V calcval <- 41.84*eos$a1 + 41.84*eos$a2/2601 + - (41.84*eos$a3 + 41.84*eos$a4/2601) / (298.15-228) - Q * eos$omega + (41.84*eos$a3 + 41.84*eos$a4/2601) / (298.15-thermo$opt$Theta) - Q * eos$omega tol <- thermo$opt$V.tol units <- "cm3 mol-1" } Modified: pkg/CHNOSZ/R/util.expression.R =================================================================== --- pkg/CHNOSZ/R/util.expression.R 2013-02-02 06:30:41 UTC (rev 40) +++ pkg/CHNOSZ/R/util.expression.R 2013-02-06 15:17:21 UTC (rev 41) @@ -36,7 +36,7 @@ # write a designation of physical state # use the state given in log if it's a gas or neutral aqueous species if(log %in% c("g", "gas")) state <- "g" - if(!"Z" %in% names(elements)) state <- log + else if(!"Z" %in% names(elements)) state <- log if(state != "") { # subscript it if we're not in a log expression if(log != "") expr <- substitute(a*group('(',italic(b),')'),list(a=expr, b=state)) @@ -54,8 +54,6 @@ expr <- substitute(a==b, list(a=expr, b=value)) } } - # turn the label into an expression, and we're done! - expr <- as.expression(expr) return(expr) } @@ -66,15 +64,15 @@ propchar <- s2c(property) expr <- "" # some special cases - if(property=="logK") return(expression(log~italic(K))) + if(property=="logK") return(quote(log~italic(K))) # grepl here b/c diagram() uses "loga.equil" and "loga.basis" - if(grepl("loga", property)) return(expression(log~italic(a))) - if(property=="alpha") return(expression(alpha)) - if(property=="Eh") return(expression(Eh)) - if(property=="pH") return(expression(pH)) - if(property=="pe") return(expression(pe)) - if(property=="IS") return(expression(IS)) - if(property=="ZC") return(expression(bar(italic(Z))[C])) + if(grepl("loga", property)) return(quote(log~italic(a))) + if(property=="alpha") return(quote(alpha)) + if(property=="Eh") return("Eh") + if(property=="pH") return("pH") + if(property=="pe") return("pe") + if(property=="IS") return("IS") + if(property=="ZC") return(quote(bar(italic(Z))[C])) # process each character in the property abbreviation prevchar <- character() for(i in 1:length(propchar)) { @@ -97,7 +95,7 @@ # put it together expr <- substitute(a*b, list(a=expr, b=thisexpr)) } - return(as.expression(expr)) + return(expr) } expr.units <- function(property, prefix="", per="mol") { @@ -135,7 +133,7 @@ if(!any(sapply(c("P", "T", "Eh", "IS"), function(x) grepl(x, property)))) expr <- substitute(a~b^-1, list(a=expr, b=per)) } - return(as.expression(expr)) + return(expr) } axis.label <- function(label, units=NULL, basis=thermo$basis, prefix="") { @@ -154,14 +152,14 @@ } else { # the label is for a chemical property or condition # make the label by putting a comma between the property and the units - property <- expr.property(label)[[1]] - if(is.null(units)) units <- expr.units(label, prefix=prefix)[[1]] + property <- expr.property(label) + if(is.null(units)) units <- expr.units(label, prefix=prefix) # no comma needed if there are no units if(units=="") desc <- substitute(a, list(a=property)) else desc <- substitute(list(a, b), list(a=property, b=units)) } # done! - return(as.expression(desc)) + return(desc) } describe.basis <- function(basis=thermo$basis, ibasis=1:nrow(basis), digits=1, oneline=FALSE) { @@ -194,7 +192,7 @@ for(i in 1:length(property)) { propexpr <- c(propexpr, expr.property(property[i])) thisvalue <- format(round(value[i], digits), nsmall=digits) - thisunits <- expr.units(property[i])[[1]] + thisunits <- expr.units(property[i]) thisvalexpr <- substitute(a~b, list(a=thisvalue, b=thisunits)) valexpr <- c(valexpr, as.expression(thisvalexpr)) } @@ -223,8 +221,8 @@ if(i %in% iname) species <- reaction$name[i] else { # should the chemical formula have a state? - if(identical(states,"all")) species <- expr.species(reaction$formula[i], state=reaction$state[i])[[1]] - else species <- expr.species(reaction$formula[i])[[1]] + if(identical(states,"all")) species <- expr.species(reaction$formula[i], state=reaction$state[i]) + else species <- expr.species(reaction$formula[i]) } # get the absolute value of the reaction coefficient abscoeff <- abs(reaction$coeff[i]) Modified: pkg/CHNOSZ/R/util.fasta.R =================================================================== --- pkg/CHNOSZ/R/util.fasta.R 2013-02-02 06:30:41 UTC (rev 40) +++ pkg/CHNOSZ/R/util.fasta.R 2013-02-06 15:17:21 UTC (rev 41) @@ -1,13 +1,6 @@ # CHNOSZ/util.fasta.R # read and manipulate FASTA sequence files -is.fasta <- function(file) { - # check if the file is in FASTA format - # read two lines in case the first one is blank - l <- readLines(file,n=2) - if(length(grep("^>",l)) == 0) return(FALSE) else return(TRUE) -} - grep.file <- function(file,pattern="",y=NULL,ignore.case=TRUE,startswith=">",lines=NULL,grep="grep") { # return the line numbers of the file that contain # the search term x and optionally don't contain y @@ -51,7 +44,8 @@ return(as.numeric(out)) } -read.fasta <- function(file,i=NULL,ret="count",lines=NULL,ihead=NULL,pnff=FALSE) { +read.fasta <- function(file, i=NULL, ret="count", lines=NULL, ihead=NULL, + pnff=FALSE, start=NULL, stop=NULL) { # read sequences from a fasta file if(file != "") msgout("read.fasta: reading ",basename(file),"\n") # all of them or only those indicated by i @@ -83,13 +77,14 @@ if(is.null(ihead)) ihead <- which(substr(lines,1,1)==">") linefun <- function(i1,i2) lines[i1:i2] } + # identify the lines that begin and end each sequence if(is.null(i)) { i <- ihead - start <- i + 1 + begin <- i + 1 end <- i - 1 end <- c(end[-1], nlines) } else { - start <- i + 1 + begin <- i + 1 iend <- match(i,ihead) # we have to be careful about the last record iend[iend==ihead[length(ihead)]] <- NA @@ -99,11 +94,12 @@ # just return the lines from the file if(ret=="fas") { iline <- numeric() - for(i in 1:length(start)) iline <- c(iline,(start[i]-1):end[i]) + for(i in 1:length(begin)) iline <- c(iline,(begin[i]-1):end[i]) return(lines[iline]) } - seqfun <- function(i) paste(linefun(start[i],end[i]),collapse="") - sequences <- palply(1:length(i), seqfun) + # get each sequences from the begin to end lines + seqfun <- function(i) paste(linefun(begin[i],end[i]),collapse="") + sequences <- lapply(1:length(i), seqfun) # process the header line for each entry # (strip the ">" and go to the first space or underscore) nomfun <- function(befund) { @@ -140,7 +136,7 @@ organism <- bnf } if(ret=="count") { - aa <- count.aa(sequences) + aa <- count.aa(sequences, start, stop) colnames(aa) <- aminoacids(3) ref <- abbrv <- NA chains <- 1 @@ -150,33 +146,79 @@ } else return(sequences) } -splitline <- function(line,length) { - # to split a line into multiple lines with a specified length - out <- character() - count <- 0 - n <- nchar(line) - while(count < n) { - split <- substr(line,count+1,count+length) - out <- c(out,split) - count <- count + length +uniprot.aa <- function(protein, start=NULL, stop=NULL) { + # download protein sequence information from UniProt + iprotein <- numeric() + # construct the initial URL + proteinURL <- paste("http://www.uniprot.org/uniprot/", protein, sep="") + msgout("uniprot.aa: trying ", proteinURL, " ...") + # try loading the URL, hiding any warnings + oldopt <- options(warn=-1) + URLstuff <- try(readLines(proteinURL),TRUE) + options(oldopt) + if(class(URLstuff)=="try-error") { + msgout(" failed\n") + return(NA) } - return(out) + # 20091102: look for a link to a fasta file + linkline <- URLstuff[[grep("/uniprot/.*fasta", URLstuff)[1]]] + # extract accession number from the link + linkhead <- strsplit(linkline, ".fasta", fixed=TRUE)[[1]][1] + accession.number <- tail(strsplit(linkhead, "/uniprot/", fixed=TRUE)[[1]], 1) + msgout(" accession ", accession.number, " ...\n") + # now download the fasta file + fastaURL <- paste("http://www.uniprot.org/uniprot/", accession.number, ".fasta", sep="") + URLstuff <- readLines(fastaURL) + # show the name of the protein to the user + header <- URLstuff[[1]] + header2 <- strsplit(header, paste(protein, ""))[[1]][2] + header3 <- strsplit(header2, " OS=")[[1]] + protein.name <- header3[1] + header4 <- strsplit(header3[2], " GN=")[[1]][1] + header5 <- strsplit(header4[1], " PE=")[[1]] + organism.name <- header5[1] + msgout("uniprot.aa: ", protein.name, " from ", organism.name) + # 20130206 use read.fasta with lines, start, stop arguments + aa <- read.fasta(file="", lines=URLstuff, start=start, stop=stop) + msgout(" (length ", sum(aa[1, 6:25]), ")\n", sep="") + po <- strsplit(protein, "_")[[1]] + aa$protein <- po[1] + aa$organism <- po[2] + return(aa) } -trimfas <- function(file,start,stop) { - # to extract certain positions from an (aligned) fasta file - lines <- readLines(file) - fas <- read.fasta(file="",lines=lines,ret="seq") - # the length of lines to use - ll <- nchar(lines[2]) - ihead <- grep("^>",lines) - head <- lines[ihead] - out <- character() - for(i in 1:length(head)) { - extract <- substr(fas[i],start,stop) - out <- c(out,head[i],splitline(extract,ll),"") +count.aa <- function(seq, start=NULL, stop=NULL) { + # count amino acids in one or more sequences + # sequences are given as elements of the list seq + aa <- aminoacids(1) + # to count the letters in each sequence + countfun <- function(seq, start, stop) { + count <- numeric(20) + # get a substring if one or both of start or stop are given + # if only one of start or stop is given, get a default value for the other + if(!is.null(start)) { + if(is.null(stop)) stop <- nchar(seq) + seq <- substr(seq, start, stop) + } else if(!is.null(stop)) { + seq <- substr(seq, 1, stop) + } + # the actual counting + naa <- table(strsplit(toupper(seq), "")[[1]]) + # put them in the same order as in aa (i.e. thermo$protein) + iaa <- match(names(naa), aa) + # in case any letters don't match some amino acid + ina <- is.na(iaa) + count[iaa[!ina]] <- naa[!ina] + if(any(ina)) msgout("count.aa: unrecognized amino acid code(s): ", + paste(names(naa)[ina], collapse=" "), "\n") + return(count) } - #write.table(out,paste(file,"trim",sep="."),row.names=FALSE,col.names=FALSE,quote=FALSE) - return(out) + # count amino acids in each sequence + a <- palply(seq, countfun, start, stop) + a <- t(as.data.frame(a, optional=TRUE)) + # clean up row/column names + colnames(a) <- aa + rownames(a) <- 1:nrow(a) + return(a) } Modified: pkg/CHNOSZ/R/util.seq.R =================================================================== --- pkg/CHNOSZ/R/util.seq.R 2013-02-02 06:30:41 UTC (rev 40) +++ pkg/CHNOSZ/R/util.seq.R 2013-02-06 15:17:21 UTC (rev 41) @@ -31,32 +31,6 @@ else if(nchar=="Z") return(aacharged[iaa]) } -count.aa <- function(seq) { - # count amino acids in one or more sequences - # sequences are given as elements of the list seq - aa <- aminoacids(1) - countfun <- function(seq) { - # count the letters in each sequence, putting them in the same order as aa - count <- numeric(20) - # the actual counting - naa <- table(strsplit(toupper(seq), "")[[1]]) - iaa <- match(names(naa), aa) - # in case any letters don't match some amino acid - ina <- is.na(iaa) - count[iaa[!ina]] <- naa[!ina] - if(any(ina)) msgout("count.aa: unrecognized amino acid code(s): ", - paste(names(naa)[ina], collapse=" "), "\n") - return(count) - } - # count amino acids in each sequence - a <- palply(seq, countfun) - a <- t(as.data.frame(a, optional=TRUE)) - # clean up row/column names - colnames(a) <- aa - rownames(a) <- 1:nrow(a) - return(a) -} - nucleicacids <- function(seq=NULL,type="DNA",comp=NULL,comp2=NULL) { # count bases or compute the formula, e.g. # n <- nucleicacids(list("AGCT","TTTT")) # a dataframe of counts Modified: pkg/CHNOSZ/R/water.R =================================================================== --- pkg/CHNOSZ/R/water.R 2013-02-02 06:30:41 UTC (rev 40) +++ pkg/CHNOSZ/R/water.R 2013-02-06 15:17:21 UTC (rev 41) @@ -51,302 +51,6 @@ return(t) } -idealgas.IAPWS95 <- function(p, delta, tau) { - ## the ideal gas part in the IAPWS-95 formulation - # from Table 6.1 of Wagner and Pruss, 2002 - n <- c( -8.32044648201, 6.6832105268, 3.00632, 0.012436, - 0.97315, 1.27950, 0.96956, 0.24873 ) - gamma <- c( NA, NA, NA, 1.28728967, - 3.53734222, 7.74073708, 9.24437796, 27.5075105 ) - # Equation 6.5 - phi <- function() log(delta) + n[1] + n[2]*tau + n[3]*log(tau) + - sum( n[4:8] * log(1-exp(-gamma[4:8]*tau)) ) - # derivatives from Table 6.4 [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/chnosz -r 41 From noreply at r-forge.r-project.org Tue Feb 12 23:35:25 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 12 Feb 2013 23:35:25 +0100 (CET) Subject: [CHNOSZ-commits] r42 - in pkg/CHNOSZ: . R data demo inst inst/tests man Message-ID: <20130212223525.8E3201847E6@r-forge.r-project.org> Author: jedick Date: 2013-02-12 23:35:25 +0100 (Tue, 12 Feb 2013) New Revision: 42 Added: pkg/CHNOSZ/inst/tests/test-EOSregress.R pkg/CHNOSZ/inst/tests/test-water.R Modified: pkg/CHNOSZ/DESCRIPTION pkg/CHNOSZ/R/EOSregress.R pkg/CHNOSZ/R/hkf.R pkg/CHNOSZ/R/subcrt.R pkg/CHNOSZ/R/util.args.R pkg/CHNOSZ/R/water.R pkg/CHNOSZ/data/opt.csv pkg/CHNOSZ/demo/CO2Ac.R pkg/CHNOSZ/demo/nonideal.R pkg/CHNOSZ/inst/NEWS pkg/CHNOSZ/man/EOSregress.Rd pkg/CHNOSZ/man/subcrt.Rd pkg/CHNOSZ/man/water.Rd Log: use consistent names for properties of water Modified: pkg/CHNOSZ/DESCRIPTION =================================================================== --- pkg/CHNOSZ/DESCRIPTION 2013-02-06 15:17:21 UTC (rev 41) +++ pkg/CHNOSZ/DESCRIPTION 2013-02-12 22:35:25 UTC (rev 42) @@ -1,6 +1,6 @@ -Date: 2013-02-06 +Date: 2013-02-13 Package: CHNOSZ -Version: 0.9-9.4 +Version: 0.9-9.5 Title: Chemical Thermodynamics and Activity Diagrams Author: Jeffrey M. Dick Maintainer: Jeffrey M. Dick Modified: pkg/CHNOSZ/R/EOSregress.R =================================================================== --- pkg/CHNOSZ/R/EOSregress.R 2013-02-06 15:17:21 UTC (rev 41) +++ pkg/CHNOSZ/R/EOSregress.R 2013-02-12 22:35:25 UTC (rev 42) @@ -3,11 +3,11 @@ # 20091105 first version # 20110429 revise and merge with CHNOSZ package -EOSvar <- function(var,T,P) { +EOSvar <- function(var, T, P) { # get the variables of a term in a regression equation # T (K), P (bar) out <- switch(EXPR = var, - "(Intercept)" = rep(1,length(T)), + "(Intercept)" = rep(1, length(T)), "T" = T, "P" = P, "TTheta" = T-thermo$opt$Theta, # T-Theta @@ -16,17 +16,12 @@ "invTTheta2" = (T-thermo$opt$Theta)^-2, # 1/(T-Theta)^2 "invPPsi" = (P+thermo$opt$Psi)^-1, # 1/(P-Psi) "invPPsiTTheta" = (P+thermo$opt$Psi)^-1 * (T-thermo$opt$Theta)^-1, # 1/[(P-Psi)(T-Theta)] - "V" = water(var,T=T,P=P)[,1], - "E" = water(var,T=T,P=P)[,1], - "kT" = water(var,T=T,P=P)[,1], - "alpha" = water(var,T=T,P=P)[,1], - "beta" = water(var,T=T,P=P)[,1], - "X" = water(var,T=T,P=P)[,1], - "Q" = water(var,T=T,P=P)[,1], - "TX" = T*water("X",T=T,P=P)[,1], - "drho.dT" = -water("rho",T=T,P=P)[,1]*water("E",T=T,P=P)[,1], - "V.kT" = water("V",T=T,P=P)[,1]*water("kT",T=T,P=P)[,1], - NA + "TXBorn" = T*water("XBorn", T=T, P=P)[, 1], + "drho.dT" = -water("rho", T=T, P=P)[, 1]*water("E", T=T, P=P)[, 1], + "V.kT" = water("V", T=T, P=P)[, 1]*water("kT", T=T, P=P)[, 1], + # the "default": get a variable that is a property of water + (if(var %in% water.props()) water(var, T, P)[, 1] + else stop(paste("can't find a variable named", var))) ) return(out) } @@ -43,9 +38,9 @@ "P" = substitute(YYY%*%italic(XXX),list(XXX=var,YYY=coeff)), "V" = substitute(YYY%*%italic(XXX),list(XXX=var,YYY=coeff)), "E" = substitute(YYY%*%italic(XXX),list(XXX=var,YYY=coeff)), - "X" = substitute(YYY%*%italic(XXX),list(XXX=var,YYY=coeff)), - "Q" = substitute(YYY%*%italic(XXX),list(XXX=var,YYY=coeff)), - "TX" = substitute(YYY%*%italic(XXX),list(XXX=var,YYY=coeff)), + "XBorn" = substitute(YYY%*%italic(XXX),list(XXX=var,YYY=coeff)), + "QBorn" = substitute(YYY%*%italic(XXX),list(XXX=var,YYY=coeff)), + "TXBorn" = substitute(YYY%*%italic(XXX),list(XXX=var,YYY=coeff)), "kT" = substitute(YYY%*%kappa[italic(T)],list(YYY=coeff)), "alpha" = substitute(YYY%*%alpha,list(YYY=coeff)), "beta" = substitute(YYY%*%beta,list(YYY=coeff)), @@ -95,8 +90,8 @@ prop <- colnames(exptdata)[3] # if var is NULL use HKF equations if(is.null(var)) { - if(prop=="Cp") var <- c("invTTheta2","TX") - if(prop=="V") var <- c("invTTheta","Q") + if(prop=="Cp") var <- c("invTTheta2","TXBorn") + if(prop=="V") var <- c("invTTheta","QBorn") } expt <- exptdata # perform the regression, only using temperatures up to T.max @@ -165,19 +160,19 @@ return(invisible(list(xlim=range(expt$T[iexpt])))) } -EOScoeffs <- function(species,property) { +EOScoeffs <- function(species, property) { # get the HKF coefficients for species in the database - iis <- info(info(species,"aq")) + iis <- info(info(species, "aq")) if(property=="Cp") { - out <- iis[,c("c1","c2","omega")] - names(out) <- c("(Intercept)","invTTheta2","TX") + out <- iis[,c("c1", "c2", "omega")] + names(out) <- c("(Intercept)", "invTTheta2", "TXBorn") } else if(property=="V") { - iis <- iis[,c("a1","a2","a3","a4","omega")] + iis <- iis[,c("a1", "a2", "a3", "a4", "omega")] sigma <- ( iis$a1 + iis$a2 / (2600 + 1) ) * 41.84 xi <- ( iis$a3 + iis$a4 / (2600 + 1) ) * 41.84 # watch for the negative sign on omega here! - out <- data.frame(sigma,xi,-iis$omega) - names(out) <- c("(Intercept)","invTTheta","Q") + out <- data.frame(sigma, xi, -iis$omega) + names(out) <- c("(Intercept)", "invTTheta", "QBorn") } return(out) } Modified: pkg/CHNOSZ/R/hkf.R =================================================================== --- pkg/CHNOSZ/R/hkf.R 2013-02-06 15:17:21 UTC (rev 41) +++ pkg/CHNOSZ/R/hkf.R 2013-02-12 22:35:25 UTC (rev 42) @@ -24,20 +24,20 @@ stop(paste('argument',c2s(contrib[notcontrib]),'not in',c2s(contribs),'n')) # get water properties, if they weren't supplied in arguments (and we want solvation props) if('s' %in% contrib) { - H2O.props <- c('Q','X','Y','epsilon') + H2O.props <- c("QBorn", "XBorn", "YBorn", "diel") # only take these ones if we're in SUPCRT92 compatibility mode - dosupcrt <- length(agrep(tolower(thermo$opt$water),'supcrt9',max.distance=0.3))!=0 + dosupcrt <- thermo$opt$water != "IAPWS95" if(dosupcrt) { # (E, daldT, V - for partial derivatives of omega (g function)) - H2O.props <- c(H2O.props,'E','daldT','kT','Z') + H2O.props <- c(H2O.props,'E','daldT','kT','ZBorn') } else { - # (N, UBorn - for compressibility, expansibility) - H2O.props <- c(H2O.props,'N','UBorn') + # (NBorn, UBorn - for compressibility, expansibility) + H2O.props <- c(H2O.props,'NBorn','UBorn') } if(is.null(H2O.PT)) H2O.PT <- water(H2O.props,T=T,P=P) if(is.null(H2O.PrTr)) H2O.PrTr <- water(H2O.props,T=thermo$opt$Tr,P=thermo$opt$Pr) - ZBorn <- -1/H2O.PT$epsilon - ZBorn.PrTr <- -1/H2O.PrTr$epsilon + ZBorn <- -1/H2O.PT$diel + ZBorn.PrTr <- -1/H2O.PrTr$diel } # a list to store the result x <- list() @@ -125,20 +125,20 @@ if( icontrib=="s") { # solvation ghs equations if(prop=="g") { - p <- -omega.PT*(ZBorn+1) + omega*(ZBorn.PrTr+1) + omega*H2O.PrTr$Y*(T-Tr) + p <- -omega.PT*(ZBorn+1) + omega*(ZBorn.PrTr+1) + omega*H2O.PrTr$YBorn*(T-Tr) # at Tr,Pr, if the origination contribution is not NA, ensure the solvation contribution is 0, not NA if(!is.na(GHS$G)) p[T==Tr & P==Pr] <- 0 } if(prop=="h") - p <- -omega.PT*(ZBorn+1) + omega.PT*T*H2O.PT$Y + T*(ZBorn+1)*dwdT + - omega*(ZBorn.PrTr+1) - omega*Tr*H2O.PrTr$Y + p <- -omega.PT*(ZBorn+1) + omega.PT*T*H2O.PT$YBorn + T*(ZBorn+1)*dwdT + + omega*(ZBorn.PrTr+1) - omega*Tr*H2O.PrTr$YBorn if(prop=="s") - p <- omega.PT*H2O.PT$Y + (ZBorn+1)*dwdT - omega*H2O.PrTr$Y + p <- omega.PT*H2O.PT$YBorn + (ZBorn+1)*dwdT - omega*H2O.PrTr$YBorn # solvation cp v kt e equations - if(prop=='cp') p <- omega.PT*T*H2O.PT$X + 2*T*H2O.PT$Y*dwdT + + if(prop=='cp') p <- omega.PT*T*H2O.PT$XBorn + 2*T*H2O.PT$YBorn*dwdT + T*(ZBorn+1)*d2wdT2 if(prop=='v') p <- -convert(omega.PT,'cm3bar') * - H2O.PT$Q + convert(dwdP,'cm3bar') * (-ZBorn - 1) + H2O.PT$QBorn + convert(dwdP,'cm3bar') * (-ZBorn - 1) # WARNING: the partial derivatives of omega are not included here here for kt and e # (to do it, see p. 820 of SOJ+92 ... but kt requires d2wdP2 which we don't have yet) if(prop=='kt') p <- convert(omega,'cm3bar') * H2O.PT$N Modified: pkg/CHNOSZ/R/subcrt.R =================================================================== --- pkg/CHNOSZ/R/subcrt.R 2013-02-06 15:17:21 UTC (rev 41) +++ pkg/CHNOSZ/R/subcrt.R 2013-02-12 22:35:25 UTC (rev 42) @@ -267,16 +267,16 @@ # than possible many times in hkf()). wprop.PT <- character() wprop.PrTr <- 'rho' - dosupcrt <- length(agrep(tolower(thermo$opt$water),'supcrt9',max.distance=0.3))!=0 - if(TRUE %in% (prop %in% c('logk','g','h','s'))) wprop.PrTr <- c(wprop.PrTr,'Y') - if(dosupcrt | TRUE %in% (prop %in% c('logk','g','h'))) wprop.PrTr <- c(wprop.PrTr,'epsilon') + dosupcrt <- thermo$opt$water != "IAPWS95" + if(TRUE %in% (prop %in% c('logk','g','h','s'))) wprop.PrTr <- c(wprop.PrTr,'YBorn') + if(dosupcrt | TRUE %in% (prop %in% c('logk','g','h'))) wprop.PrTr <- c(wprop.PrTr,'diel') H2O.PrTr <- water(wprop.PrTr,T=thermo$opt$Tr,P=thermo$opt$Pr) - if(TRUE %in% (prop %in% c('cp'))) {wprop.PT <- c(wprop.PT,'X','Y')} - if(TRUE %in% (prop %in% c('v'))) {wprop.PT <- c(wprop.PT,'Q')} - if(TRUE %in% (prop %in% c('kt'))) {wprop.PT <- c(wprop.PT,'N')} + if(TRUE %in% (prop %in% c('cp'))) {wprop.PT <- c(wprop.PT,'XBorn','YBorn')} + if(TRUE %in% (prop %in% c('v'))) {wprop.PT <- c(wprop.PT,'QBorn')} + if(TRUE %in% (prop %in% c('kt'))) {wprop.PT <- c(wprop.PT,'NBorn')} if(TRUE %in% (prop %in% c('e'))) {wprop.PT <- c(wprop.PT,'UBorn')} # get additional properties required for omega derivatives - if(dosupcrt) wprop.PT <- c(wprop.PT,'alpha','daldT','beta','epsilon') + if(dosupcrt) wprop.PT <- c(wprop.PT,'alpha','daldT','beta','diel') H2O.PT <- water(c(wprop.PrTr,wprop.PT),T=T,P=P) if(TRUE %in% isaq) { # now the species stuff Modified: pkg/CHNOSZ/R/util.args.R =================================================================== --- pkg/CHNOSZ/R/util.args.R 2013-02-06 15:17:21 UTC (rev 41) +++ pkg/CHNOSZ/R/util.args.R 2013-02-12 22:35:25 UTC (rev 42) @@ -31,23 +31,21 @@ return(list(props=props,prop=prop,Prop=Prop)) } -TP.args <- function(T=NULL,P=NULL) { - if(!is.null(P)) { - if(identical(P[1],'Psat')) { - P <- water('Psat',T,P=NULL) - P <- P[,1] - # water.SUPCRT92 issues its own warnings about - # exceeding Psat's temperature limit - if(length(agrep(tolower(thermo$opt$water),'supcrt9',max.distance=0.3))==0) - if(length(which(is.na(P)))>0) - warning('TP.args: NAs in Psat (likely T > Tc where Tc = 647.096 K)',call.=FALSE) - } +TP.args <- function(T=NULL, P=NULL) { + # keep the [1] here because some functions (e.g. subcrt) will repeat "Psat" + if(identical(P[1], "Psat")) { + P <- water("Psat", T, P="Psat")[, 1] + # water.SUPCRT92 issues its own warnings about + # exceeding Psat's temperature limit + if(thermo$opt$water == "IAPWS95") + if(length(which(is.na(P)))>0) + warning('TP.args: NAs in Psat (likely T > Tc where Tc = 647.096 K)',call.=FALSE) } if(length(P) < length(T) & !is.null(P)) P <- rep(P, length.out=length(T)) else if(length(T) < length(P) & !is.null(T)) T <- rep(T, length.out=length(P)) # something we do here so the SUPCRT water calculations work T[T==273.15] <- 273.16 - return(list(T=T,P=P)) + return(list(T=T, P=P)) } state.args <- function(state=NULL) { Modified: pkg/CHNOSZ/R/water.R =================================================================== --- pkg/CHNOSZ/R/water.R 2013-02-06 15:17:21 UTC (rev 41) +++ pkg/CHNOSZ/R/water.R 2013-02-12 22:35:25 UTC (rev 42) @@ -51,207 +51,183 @@ return(t) } -water <- function(property = NULL,T = thermo$opt$Tr, P = 'Psat') { +water <- function(property = NULL, T = thermo$opt$Tr, P = "Psat") { # calculate the properties of liquid H2O as a function of T and P # T in Kelvin, P in bar if(is.null(property)) stop('property was NULL') - # this tells us to do the calculations using code taken from SUPCRT - do.supcrt <- length(agrep(tolower(thermo$opt$water),'supcrt9',max.distance=0.3)) > 0 - eargs <- eos.args('water',property=property,T=T,P=P) - property <- eargs$prop; Property <- eargs$Prop - # working out the arguments - tpargs <- TP.args(T=T,P=P) - P <- tpargs$P - T <- tpargs$T - # Psat stuff - psat <- function() { - p <- numeric() - if(do.supcrt) { - p <- water.SUPCRT92('',T=T,rep(0,length(T)),isat=1) - p[p==0] <- NaN - return(p) - } else { - for(i in 1:length(T)) { - if(T[i] < 373.124) p <- c(p,0.1) - else p <- c(p,WP02.auxiliary('P.sigma',T[i])) - } - return(convert(p,'bar')) - } + # make T and P equal length + if(!identical(P, "Psat")) { + if(length(P) < length(T)) P <- rep(P, length.out = length(T)) + else if(length(T) < length(P)) T <- rep(T, length.out = length(P)) } - # a quick return if property = 'Psat', for use by the TP.args() function - if(length(property)==1 & property[1]=='psat') return(data.frame(Psat=psat())) - ### maybe we are using the SUPCRT calculations ### + # turn 273.15 K to 273.16 K (needed for water.SUPCRT92 at Psat) + T[T == 273.15] <- 273.16 + # this tells us to do the calculations using code taken from SUPCRT + do.supcrt <- thermo$opt$water != "IAPWS95" if(do.supcrt) { - names.SUPCRT <- c('Speed','alpha','beta','alpha','beta','diel','ZBorn','YBorn','QBorn','XBorn') - names.CHNOSZ <- c('w','alpha','beta','E','kT','epsilon','Z','Y','Q','X') - Property.new <- character() - # convert names to SUPCRT - for(i in 1:length(Property)) if(Property[i] %in% names.CHNOSZ) - Property.new[i] <- names.SUPCRT[match(Property[i],names.CHNOSZ)] - else Property.new[i] <- Property[i] - # deal with compressibility and expansivity 20091203 - iE <- which(Property=="E") - ikT <- which(Property=="kT") - iV <- numeric() - if("kT" %in% Property | "E" %in% Property) iV <- length(Property.new <- c(Property.new,"V")) - # get the value of the property - w.out <- water.SUPCRT92(Property.new,T=T,P=P) - # finish dealing with compressibility and expansivity - if("E" %in% Property) w.out[,iE] <- w.out$V*w.out$alpha - if("kT" %in% Property) w.out[,ikT] <- w.out$V*w.out$beta - if(length(iV) > 0) w.out <- w.out[,-iV,drop=FALSE] - colnames(w.out) <- Property + # get the values of the properties using SUPCRT92 + w.out <- water.SUPCRT92(property, T, P) return(w.out) } else { # here we get properties using IAPWS-95 w.out <- water.IAPWS95(property, T, P) - colnames(w.out) <- Property + colnames(w.out) <- property return(w.out) } } +water.props <- function(formulation=thermo$opt$water) { + # return the names of properties that are available in SUPCRT92 or IAPWS95 + # added 20130212 jmd + if(formulation=="SUPCRT92") + props <- c("A", "G", "S", "U", "H", "Cv", "Cp", + "Speed", "alpha", "beta", "diel", "visc", + "tcond", "surten", "tdiff", "Prndtl", "visck", "albe", + "ZBorn", "YBorn", "QBorn", "daldT", "XBorn", + "V", "rho", "Psat", "E", "kT") + else if(formulation=="IAPWS95") + props <- c("A", "G", "S", "U", "H", "Cv", "Cp", + "YBorn", "QBorn", "XBorn", "NBorn", "UBorn", + "V", "rho", "Psat", "de.dT", "de.dP", "P") + return(props) +} -water.SUPCRT92 <- function(property,T=298.15,P=1,isat=0) { +water.SUPCRT92 <- function(property, T=298.15, P=1) { ### interface to H2O92D.f : FORTRAN subroutine taken from ### SUPCRT92 for calculating the thermodynamic and ### electrostatic properties of H2O. ## we restrict the calculations to liquid water ## except for getting Psat (vapor-liquid saturation ## pressure as a function of T>100 C). 20071213 jmd - # H2O92 doesn't output Born functions N or U - if('n' %in% tolower(property) | 'uborn' %in% tolower(property)) - stop('I can\'t tell you the Born functions N or U (used in calculating compressibilities and expansibilities of aqueous species).') - # pressure setting - if(is.null(P)) P <- rep(0,length(T)) - # values to use here gleaned from H2O92D.f and SUP92D.f + # check for availability of properties + iprop <- match(tolower(property), tolower(water.props("SUPCRT92"))) + if(any(is.na(iprop))) stop(paste("property(s) not available:", paste(property[is.na(iprop)], collapse=" "))) + # make sure Psat in properties comes with isat=1 + if("psat" %in% tolower(property) & !identical(P, "Psat")) stop("please set P='Psat' to calculate the property Psat") + # for Psat(T) (1) or T-P (2) + if(identical(P, "Psat")) iopt <- 1 else iopt <- 2 + if(identical(P, "Psat")) isat <- 1 else isat <- 0 + # input values, gleaned from H2O92D.f and SUP92D.f # it, id, ip, ih, itripl, isat, iopt, useLVS, epseqn, icrit - if(isat) iopt <- 1 else iopt <- 2 # for Psat(T) (1) or T-P (2) - specs <- c(2,2,2,5,1,isat,iopt,1,4,0) - states <- rep(0,4) - # match up properties with the output - props <- c('a','g','s','u','h','cv','cp','Speed','alpha', - 'beta','diel','visc','tcond','surten','tdiff','Prndtl', - 'visck','albe','ZBorn','YBorn','QBorn','daldT','XBorn') - iprop <- seq(1,45,length.out=23) - # now to the actual calculations - Tc <- convert(T,'C') + specs <- c(2, 2, 2, 5, 1, isat, iopt, 1, 4, 0) + states <- rep(0, 4) # initialize the output matrix - w.out <- matrix(NA,nrow=length(T),ncol=23,byrow=TRUE) + w.out <- matrix(NA, nrow=length(T), ncol=23, byrow=TRUE) err.out <- numeric(length(T)) rho.out <- numeric(length(T)) - p.out <- numeric(length(T)) + P.out <- numeric(length(T)) # 20091022 TODO: parallelize this + Tc <- convert(T, "C") for(i in 1:length(T)) { states[1] <- Tc[i] - states[2] <- P[i] - if(any(is.na(c(Tc[i],P[i])))) { + if(identical(P, "Psat")) states[2] <- 0 + else states[2] <- P[i] + if(is.na(Tc[i]) | is.na(P[i]) & !identical(P, "Psat")) { # if T or P is NA, all properties are NA - w <- matrix(rep(NA,23),nrow=1) - w.out[i,] <- w - p.out[i] <- NA + # (NA's are already in w.out) + P.out[i] <- NA rho.out[i] <- NA } else { - inc <- 0 - h2o <- .Fortran('H2O92',as.integer(specs),as.double(states), - as.double(rep(0,46)),as.integer(0),PACKAGE='CHNOSZ') + # now to the actual calculations + H2O <- .Fortran("H2O92", as.integer(specs), as.double(states), + as.double(rep(0, 46)), as.integer(0), PACKAGE="CHNOSZ") # errors - err <- h2o[[4]] - err.out[i] <- err - # density - rho <- h2o[[2]][3] - rho2 <- h2o[[2]][4] + err.out[i] <- H2O[[4]] + # density of two states + rho <- H2O[[2]][3] + rho2 <- H2O[[2]][4] if(rho2 > rho) { # liquid is denser than vapor rho <- rho2 - # for selecting the liquid properties later - inc <- 1 - } + inc <- 1 # second state is liquid + } else inc <- 0 # first state is liquid rho.out[i] <- rho - # most of the properties we're interested in - w <- t(h2o[[3]][iprop+inc]) - if(err==1) w[1,] <- NA + # 23 properties of the phase in the liquid state + w <- t(H2O[[3]][seq(1, 45, length.out=23)+inc]) + if(err.out[i]==1) w[1, ] <- NA # update the ith row of the output matrix w.out[i,] <- w # Psat - if(isat | 'psat' %in% tolower(property)) { - p <- h2o[[2]][2] - p[p==0] <- NA + if(identical(P, "Psat")) { + w.P <- H2O[[2]][2] + w.P[w.P==0] <- NA # Psat specifies P=1 below 100 degC - p[p < 1] <- 1 - p.out[i] <- p - } else { - p.out[i] <- P[i] + w.P[w.P < 1] <- 1 + P.out[i] <- w.P } } } # convert output to dataframe w.out <- as.data.frame(w.out) - names(w.out) <- props - # assemble the properties - mwH2O <- 18.0152 # SUP92.f - w.out <- cbind(w.out,V=mwH2O/rho.out,rho=rho.out*1000) - if(isat | 'psat' %in% tolower(property)) w.out <- cbind(w.out,Psat=p.out) + # add names of properties to the output + names(w.out) <- water.props("SUPCRT92")[1:23] + # assemble additional properties: V, rho, Psat, E, kT + if(any(iprop > 23)) { + mwH2O <- 18.0152 # SUP92.f + V=mwH2O/rho.out + rho=rho.out*1000 + Psat=P.out + E <- V*w.out$alpha + kT <- V*w.out$beta + w.out <- cbind(w.out, data.frame(V=V, rho=rho, Psat=Psat, E=E, kT=kT)) + } # tell the user about any problems if(any(err.out==1)) { if(length(T) > 1) plural <- "s" else plural <- "" nerr <- length(which(err.out==1)) if(nerr > 1) plural2 <- "s" else plural2 <- "" - if(isat) msgout(paste("water.SUPCRT92: error",plural2," calculating ", - nerr," of ",length(T)," point",plural,"; for Psat we need 273.16 < T < 647.067 K\n",sep="")) - else msgout(paste("water.SUPCRT92: error",plural2," calculating ",nerr, - " of ",length(T)," point",plural, - "; T < Tfusion at P, T > 2250 degC, or P > 30kb.\n",sep="")) - # that last bit is taken from SUP92D.f in the SUPCRT92 distribution + if(identical(P, "Psat")) msgout(paste("water.SUPCRT92: error", plural2, " calculating ", + nerr, " of ", length(T), " point", plural, "; for Psat we need 273.16 < T < 647.067 K\n", sep="")) + else msgout(paste("water.SUPCRT92: error", plural2, " calculating ", nerr, + " of ", length(T), " point", plural, + "; T < Tfusion at P, T > 2250 degC, or P > 30kb.\n", sep="")) + # that last bit is taken from SUP92D.f in SUPCRT92 } - # if isat is 1, just return the calculated pressures - if(isat) return(w.out$Psat) # return only the selected properties - icol <- match(tolower(property),tolower(colnames(w.out))) - return(w.out[,icol,drop=FALSE]) + return(w.out[, iprop, drop=FALSE]) } -water.IAPWS95 <- function(property, T=298.15, P=1, quiet=FALSE) { - # to get the properties of water via IAPWS-95 - if(!quiet) msgout(paste("water.IAPWS95: calculating", length(T), "values for")) - M <- 18.015268 # g mol-1 - rho <- function() { - # return a density in kg m-3 - # corresponding to the given pressure (MPa) and temperature (K) - pfun <- function(rho,T,P) { - P <- convert(P,'MPa') - t <- IAPWS95('p',rho=rho,T=T)[,1] - P - return(t) +rho.IAPWS95 <- function(T=298.15, P=1) { + # return a density in kg m-3 + # corresponding to the given pressure (bar) and temperature (K) + if(identical(P, "Psat")) stop("this function doesn't take P='Psat'") + dP <- function(rho, T, P) { + dP <- IAPWS95("P", rho=rho, T=T)[, 1] - convert(P, "MPa") + return(dP) + } + rho <- numeric() + for(i in 1:length(T)) { + if(T[i] < 647.096) { + rho.lower <- WP02.auxiliary("rho.liquid", T=T[i]) - 2 + rho.upper <- rho.lower + 400 + if(P[i] < 5000) rho.upper <- rho.lower + 300 + if(P[i] < 1000) rho.upper <- rho.lower + 200 + if(P[i] < 300) rho.upper <- rho.lower + 30 + } else { + rho.lower <- 0.01 + rho.upper <- 1200 } - t <- numeric() - for(i in 1:length(T)) { - if(T[i] < 647.096) { - rho.lower <- WP02.auxiliary('rho.liquid',T=T[i])-2 - rho.upper <- rho.lower + 400 - if(P[i] < 5000) rho.upper <- rho.lower + 300 - if(P[i] < 1000) rho.upper <- rho.lower + 200 - if(P[i] < 300) rho.upper <- rho.lower + 30 - } - else { rho.lower <- 0.01; rho.upper <- 1200} - tu <- try(uniroot(pfun,c(rho.lower,rho.upper),T=T[i],P=P[i])$root,TRUE) - if(!is.numeric(tu)) { - warning('water: no root for density between ',round(rho.lower,1), - ' and ',round(rho.upper,1),' kg m-3 at ',T[i],' K and ',P[i],' bar.',call.=FALSE,immediate.=TRUE) - tu <- NA - } - t <- c(t,tu) + this.rho <- try(uniroot(dP, c(rho.lower, rho.upper), T=T[i], P=P[i])$root, TRUE) + if(!is.numeric(this.rho)) { + warning("rho.IAPWS95: no root for density between ", round(rho.lower, 1), + " and ", round(rho.upper, 1), " kg m-3 at ", T[i], " K and ", P[i], " bar", call.=FALSE) + this.rho <- NA } - return(t) + rho <- c(rho, this.rho) } + return(rho) +} + +water.IAPWS95 <- function(property, T=298.15, P=1) { + # to get the properties of water via IAPWS-95 + msgout(paste("water.IAPWS95: calculating", length(T), "values for")) + M <- 18.015268 # g mol-1 v <- function() return(M*1000/my.rho) - p <- function() return(P) # Psat stuff psat <- function() { - p <- numeric() - for(i in 1:length(T)) { - if(T[i] < 373.124) p <- c(p,0.1) - else p <- c(p,WP02.auxiliary('P.sigma',T[i])) - } - return(convert(p,'bar')) + p <- WP02.auxiliary("P.sigma", T) + p[T < 373.124] <- 0.1 + return(convert(p, "bar")) } ## thermodynamic properties # convert to SUPCRT reference state @@ -263,6 +239,8 @@ # does the reference state used for GHS also go here? dU <- -67434.5 - 451.3229 dA <- -55814.06 + 20.07376 - dS * (T - thermo$opt$Tr) + # calculate pressure from the given T and estimated rho + p <- function() return(convert(IAPWS95("p", T=T, rho=my.rho), "bar")) # convert IAPWS95() (specific, joule) to (molar, cal) s <- function() return(convert(IAPWS95('s',T=T,rho=my.rho)$s*M,'cal')+dS) @@ -292,7 +270,7 @@ this.P <- P[i] this.rho <- my.rho[i] dt <- 0.001; t1 <- this.T-dt; t2 <- this.T+dt - rho <- water.IAPWS95("rho", T=c(t1, t2), P=this.P, quiet=TRUE)[, 1] + rho <- rho.IAPWS95(T=c(t1, t2), P=rep(this.P, 2)) e <- water.AW90(T=c(t1,t2),rho=rho,rep(this.P,2)) p <- c(p,(e[2]-e[1])/(2*dt)) } @@ -305,54 +283,54 @@ this.P <- P[i] this.rho <- my.rho[i] dp <- 0.001; p1 <- this.P-dp; p2 <- this.P+dp - rho <- water.IAPWS95("rho", T=this.T, P=c(p1, p2), quiet=TRUE)[, 1] + rho <- rho.IAPWS95(T=rep(this.T, 2), P=c(p1, p2)) e <- water.AW90(P=c(p1,p2),rho=rho,T=rep(this.T,2)) p <- c(p,(e[2]-e[1])/(2*dp)) } return(p) } ## Born functions - q <- function() { + qborn <- function() { p <- numeric() for(i in 1:length(T)) { this.T <- T[i]; this.P <- P[i]; this.rho <- my.rho[i] dp <- 0.01; p1 <- this.P-dp; p2 <- this.P+dp - rho <- water.IAPWS95("rho", T=rep(this.T, 2), P=c(p1, p2), quiet=TRUE)[, 1] + rho <- rho.IAPWS95(T=rep(this.T, 2), P=c(p1, p2)) e <- water.AW90(T=rep(this.T,2),rho=rho,P=convert(c(p1,p2),'MPa')) #p <- c(p,convert(-(1/e[2]-1/e[1])/(2*dp),'cm3bar')) p <- c(p,-(1/e[2]-1/e[1])/(2*dp)) } return(p) } - n <- function() { + nborn <- function() { p <- numeric() for(i in 1:length(T)) { this.T <- T[i]; this.P <- P[i]; this.rho <- my.rho[i] dp <- 0.01; p1 <- this.P-dp; p2 <- this.P+dp - rho <- water.IAPWS95("rho", T=rep(this.T, 3), P=c(p1, this.P, p2), quiet=TRUE)[, 1] + rho <- rho.IAPWS95(T=rep(this.T, 3), P=c(p1, this.P, p2)) e <- water.AW90(T=rep(this.T,3),rho=rho,P=convert(c(p1,this.P,p2),'MPa')) #p <- c(p,convert(convert((-(1/e[3]-1/e[2])/dp+(1/e[2]-1/e[1])/dp)/dp,'cm3bar'),'cm3bar')) p <- c(p,(-(1/e[3]-1/e[2])/dp+(1/e[2]-1/e[1])/dp)/dp) } return(p) } - y <- function() { + yborn <- function() { p <- numeric() for(i in 1:length(T)) { this.T <- T[i]; this.P <- P[i]; this.rho <- my.rho[i] dt <- 0.001; t1 <- this.T-dt; t2 <- this.T+dt - rho <- water.IAPWS95("rho", T=c(t1, t2), P=rep(this.P, 2), quiet=TRUE)[, 1] + rho <- rho.IAPWS95(T=c(t1, t2), P=rep(this.P, 2)) e <- water.AW90(T=c(t1,t2),rho=rho,P=convert(rep(this.P,2),'MPa')) p <- c(p,-(1/e[2]-1/e[1])/(2*dt)) } return(p) } - x <- function() { + xborn <- function() { p <- numeric() for(i in 1:length(T)) { this.T <- T[i]; this.P <- P[i]; this.rho <- my.rho[i] dt <- 0.001; t1 <- this.T-dt; t2 <- this.T+dt - rho <- water.IAPWS95("rho", T=c(t1, this.T, t2), P=rep(this.P, 3), quiet=TRUE)[, 1] + rho <- rho.IAPWS95(T=c(t1, this.T, t2), P=rep(this.P, 3)) e <- water.AW90(T=c(t1,this.T,t2),rho=rho,P=convert(rep(this.P,3),'MPa')) p <- c(p,(-(1/e[3]-1/e[2])/dt+(1/e[2]-1/e[1])/dt)/dt) } @@ -364,8 +342,8 @@ this.T <- T[i]; this.P <- P[i]; this.rho <- my.rho[i] dt <- 0.001; this.T1 <- this.T - dt; this.T2 <- this.T + dt dp <- 0.001; p1 <- this.P-dp; p2 <- this.P+dp - rho1 <- water.IAPWS95("rho", T=rep(this.T1, 2), P=c(p1, p2), quiet=TRUE)[, 1] - rho2 <- water.IAPWS95("rho", T=rep(this.T2, 2), P=c(p1, p2), quiet=TRUE)[, 1] + rho1 <- rho.IAPWS95(T=rep(this.T1, 2), P=c(p1, p2)) + rho2 <- rho.IAPWS95(T=rep(this.T2, 2), P=c(p1, p2)) e1 <- water.AW90(T=rep(this.T1,2),rho=rho1,P=convert(c(p1,p2),'MPa')) e2 <- water.AW90(T=rep(this.T2,2),rho=rho2,P=convert(c(p1,p2),'MPa')) #p1 <- convert(-(1/e1[2]-1/e1[1])/(2*dp),'cm3bar') @@ -379,22 +357,27 @@ ### main loop; init dataframe output and density holders w.out <- NULL my.rho <- NULL - # get densities and tell about it - if(!quiet) msgout(" rho") - my.rho <- rho() + # get densities unless only Psat is requested + if(!identical(tolower(property), "psat")) { + # calculate values of P for Psat + if(identical(P, "Psat")) P <- psat() + msgout(" rho") + my.rho <- rho.IAPWS95(T, P) + rho <- function() my.rho + } for(i in 1:length(property)) { - if(property[i] %in% c('e','kt')) { - # expansivity isn't in the table yet... set it to zero - warning('water: values of ',property[i],' are NA\n',call.=FALSE) - inew <- rep(NA,length(T)) + if(tolower(property[i]) %in% c("e", "kt")) { + # E and kT aren't here yet... set them to NA + warning("water.IAPWS95: values of ", property[i], " are NA\n", call.=FALSE) + inew <- rep(NA, length(T)) } else { - if(!quiet) msgout(paste(" ", property[i], sep="")) - inew <- get(property[i])() + msgout(paste(" ", property[i], sep="")) + inew <- get(tolower(property[i]))() } - #if(NA %in% inew) na.h2o <- TRUE wnew <- data.frame(inew) - if(i > 1) w.out <- cbind(w.out,wnew) else w.out <- wnew + if(i > 1) w.out <- cbind(w.out, wnew) else w.out <- wnew } - if(!quiet) msgout("\n") + msgout("\n") + names(w.out) <- property return(w.out) } Modified: pkg/CHNOSZ/data/opt.csv =================================================================== --- pkg/CHNOSZ/data/opt.csv 2013-02-06 15:17:21 UTC (rev 41) +++ pkg/CHNOSZ/data/opt.csv 2013-02-12 22:35:25 UTC (rev 42) @@ -1,2 +1,2 @@ Tr,Pr,Theta,Psi,R,cutoff,E.units,T.units,P.units,state,water,G.tol,Cp.tol,V.tol -298.15,1,228,2600,1.9872,1e-10,cal,C,bar,aq,SUPCRT,100,1,1 +298.15,1,228,2600,1.9872,1e-10,cal,C,bar,aq,SUPCRT92,100,1,1 Modified: pkg/CHNOSZ/demo/CO2Ac.R =================================================================== --- pkg/CHNOSZ/demo/CO2Ac.R 2013-02-06 15:17:21 UTC (rev 41) +++ pkg/CHNOSZ/demo/CO2Ac.R 2013-02-12 22:35:25 UTC (rev 42) @@ -5,7 +5,7 @@ species("acetic acid", -3) a <- affinity(O2=c(-85, -70, 4), T=c(25, 100, 4)) # hacking to write a title with formulas and subscripts -lCO2 <- axis.label("CO2")[[1]] +lCO2 <- axis.label("CO2") main <- substitute(a~~b~~c,list(a=lCO2, b="buffered by", c="acetic acid")) d <- diagram(a, what="CO2", main=main) @@ -14,7 +14,7 @@ d <- diagram(a, what="CO2", add=TRUE, lty=2) # add a legend lAC <- expr.species("CH3COOH", log="aq") -ltext <- c(lAC, -3, -10) +ltext <- c(as.expression(lAC), -3, -10) lty <- c(NA, 1, 2) legend("topright", legend=ltext, lty=lty, bg="white") # do return.buffer and diagram(what) give the same results? Modified: pkg/CHNOSZ/demo/nonideal.R =================================================================== --- pkg/CHNOSZ/demo/nonideal.R 2013-02-06 15:17:21 UTC (rev 41) +++ pkg/CHNOSZ/demo/nonideal.R 2013-02-12 22:35:25 UTC (rev 42) @@ -37,4 +37,4 @@ "charged species at 0, 25, 40 deg C, after Alberty, 2003", sep="\n"),cex.main=0.95) legend("topright", lty=c(NA, 1, 1, 1), col=c(NA, "blue", "black", "red"), - legend=c(axis.label("T"), 0, 25, 40)) + legend=c(as.expression(axis.label("T")), 0, 25, 40)) Modified: pkg/CHNOSZ/inst/NEWS =================================================================== --- pkg/CHNOSZ/inst/NEWS 2013-02-06 15:17:21 UTC (rev 41) +++ pkg/CHNOSZ/inst/NEWS 2013-02-12 22:35:25 UTC (rev 42) @@ -1,4 +1,4 @@ -CHANGES IN CHNOSZ 0.9-9.4 (2013-02-06) +CHANGES IN CHNOSZ 0.9-9.5 (2013-02-13) -------------------------------------- - Fix calculation of free energy derivative in wjd(). @@ -36,6 +36,18 @@ - Examples of calculation of affinity of formation of CSG_METVO (following Dick and Shock, 2011) added to protein.info.Rd. +- Use consistent names for water properties (Speed, diel, QBorn, ...). + +- Add water.props() to get names of properties of water. + +- Remove 'isat' argument from water.SUPCRT92(); function now accepts + 'Psat' as value for 'P' argument. + +- Separate rho.IAPWS95() from water.IAPWS95(). + +- Any property of water can be used as a variable in EOSvar(). + + CHANGES IN CHNOSZ 0.9-9 (2013-01-01) ------------------------------------ Added: pkg/CHNOSZ/inst/tests/test-EOSregress.R =================================================================== --- pkg/CHNOSZ/inst/tests/test-EOSregress.R (rev 0) +++ pkg/CHNOSZ/inst/tests/test-EOSregress.R 2013-02-12 22:35:25 UTC (rev 42) @@ -0,0 +1,6 @@ +context("EOSregress") + +test_that("EOSvar stops with unknown variables", { + expect_error(EOSvar("TX", T=25, P=1), "can't find a variable named TX") +}) + Added: pkg/CHNOSZ/inst/tests/test-water.R =================================================================== --- pkg/CHNOSZ/inst/tests/test-water.R (rev 0) +++ pkg/CHNOSZ/inst/tests/test-water.R 2013-02-12 22:35:25 UTC (rev 42) @@ -0,0 +1,23 @@ +context("water") + +test_that("water.SUPCRT92() gives expected erros and warnings", { + expect_error(water.SUPCRT92("X"), "not available: X") + expect_error(water.SUPCRT92("Psat"), "please set P='Psat'") +}) + +test_that("water.SUPCRT92() gives expected values for E and kT", { + # E = V * alpha, kT = V * beta [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/chnosz -r 42 From noreply at r-forge.r-project.org Wed Feb 13 15:28:35 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 13 Feb 2013 15:28:35 +0100 (CET) Subject: [CHNOSZ-commits] r43 - in pkg/CHNOSZ: . R inst inst/doc inst/tests man vignettes Message-ID: <20130213142835.79291183912@r-forge.r-project.org> Author: jedick Date: 2013-02-13 15:28:35 +0100 (Wed, 13 Feb 2013) New Revision: 43 Modified: pkg/CHNOSZ/DESCRIPTION pkg/CHNOSZ/R/EOSregress.R pkg/CHNOSZ/inst/NEWS pkg/CHNOSZ/inst/doc/wjd.pdf pkg/CHNOSZ/inst/tests/test-EOSregress.R pkg/CHNOSZ/man/EOSregress.Rd pkg/CHNOSZ/vignettes/wjd.Rnw pkg/CHNOSZ/vignettes/wjd.lyx Log: EOSvar() finds user-defined variables Modified: pkg/CHNOSZ/DESCRIPTION =================================================================== --- pkg/CHNOSZ/DESCRIPTION 2013-02-12 22:35:25 UTC (rev 42) +++ pkg/CHNOSZ/DESCRIPTION 2013-02-13 14:28:35 UTC (rev 43) @@ -1,6 +1,6 @@ Date: 2013-02-13 Package: CHNOSZ -Version: 0.9-9.5 +Version: 0.9-9.6 Title: Chemical Thermodynamics and Activity Diagrams Author: Jeffrey M. Dick Maintainer: Jeffrey M. Dick Modified: pkg/CHNOSZ/R/EOSregress.R =================================================================== --- pkg/CHNOSZ/R/EOSregress.R 2013-02-12 22:35:25 UTC (rev 42) +++ pkg/CHNOSZ/R/EOSregress.R 2013-02-13 14:28:35 UTC (rev 43) @@ -19,9 +19,18 @@ "TXBorn" = T*water("XBorn", T=T, P=P)[, 1], "drho.dT" = -water("rho", T=T, P=P)[, 1]*water("E", T=T, P=P)[, 1], "V.kT" = water("V", T=T, P=P)[, 1]*water("kT", T=T, P=P)[, 1], - # the "default": get a variable that is a property of water - (if(var %in% water.props()) water(var, T, P)[, 1] - else stop(paste("can't find a variable named", var))) + # fallback: get a variable that is a property of water, or + # is any other function by name (possibly a user-defined function) + ( if(var %in% water.props()) water(var, T, P)[, 1] + else if(exists(var)) { + if(is.function(get(var))) { + if(identical(names(formals(get(var))), c("T", "P"))) get(var)(T, P) + else stop(paste("the arguments of ", var, "() are not T, P", sep="")) + } + else stop(paste("an object named", var, "is not a function")) + } + else stop(paste("can't find a variable named", var)) + ) ) return(out) } @@ -29,24 +38,27 @@ EOSlab <- function(var,coeff="") { # make pretty labels for the variables lab <- switch(EXPR = var, - "(Intercept)" = substitute(YYY*" ",list(YYY=coeff)), - "TTheta" = substitute(YYY%*%(italic(T)-Theta),list(YYY=coeff)), - "invTTheta" = substitute(YYY/(italic(T)-Theta),list(YYY=coeff)), - "TTheta2" = substitute(YYY%*%(italic(T)-Theta)^2,list(YYY=coeff)), - "invTTheta2" = substitute(YYY/(italic(T)-Theta)^2,list(YYY=coeff)), - "T" = substitute(YYY%*%italic(XXX),list(XXX=var,YYY=coeff)), - "P" = substitute(YYY%*%italic(XXX),list(XXX=var,YYY=coeff)), - "V" = substitute(YYY%*%italic(XXX),list(XXX=var,YYY=coeff)), - "E" = substitute(YYY%*%italic(XXX),list(XXX=var,YYY=coeff)), - "XBorn" = substitute(YYY%*%italic(XXX),list(XXX=var,YYY=coeff)), - "QBorn" = substitute(YYY%*%italic(XXX),list(XXX=var,YYY=coeff)), - "TXBorn" = substitute(YYY%*%italic(XXX),list(XXX=var,YYY=coeff)), - "kT" = substitute(YYY%*%kappa[italic(T)],list(YYY=coeff)), - "alpha" = substitute(YYY%*%alpha,list(YYY=coeff)), - "beta" = substitute(YYY%*%beta,list(YYY=coeff)), - "drho.dT" = substitute(YYY%*%(d~rho/dT),list(YYY=coeff)), - "V.kT" = substitute(YYY%*%V~kappa[italic(T)],list(YYY=coeff)), - NA + # these are regression variables listed in EOSregress.Rd + "(Intercept)" = substitute(YYY*" ", list(YYY=coeff)), + "T" = substitute(YYY%*%italic(T), list(YYY=coeff)), + "P" = substitute(YYY%*%italic(P), list(YYY=coeff)), + "TTheta" = substitute(YYY%*%(italic(T)-Theta), list(YYY=coeff)), + "invTTheta" = substitute(YYY/(italic(T)-Theta), list(YYY=coeff)), + "TTheta2" = substitute(YYY%*%(italic(T)-Theta)^2, list(YYY=coeff)), + "invTTheta2" = substitute(YYY/(italic(T)-Theta)^2, list(YYY=coeff)), + "TXBorn" = substitute(YYY%*%italic(TX), list(YYY=coeff)), + "drho.dT" = substitute(YYY%*%(d~rho/dT), list(YYY=coeff)), + "V.kT" = substitute(YYY%*%V~kappa[italic(T)], list(YYY=coeff)), + # the rest are properties of water listed in water.Rd + "V" = substitute(YYY%*%italic(V), list(YYY=coeff)), + "E" = substitute(YYY%*%italic(E), list(YYY=coeff)), + "kT" = substitute(YYY%*%kappa[italic(T)], list(YYY=coeff)), + "alpha" = substitute(YYY%*%alpha, list(YYY=coeff)), + "beta" = substitute(YYY%*%beta, list(YYY=coeff)), + "XBorn" = substitute(YYY%*%italic(X), list(YYY=coeff)), + "QBorn" = substitute(YYY%*%italic(Q), list(YYY=coeff)), + # fallback, use the name of the variable (may be the name of a user-defined function) + substitute(YYY%*%italic(XXX), list(YYY=coeff, XXX=var)) ) return(lab) } @@ -84,7 +96,7 @@ } EOSplot <- function(exptdata,var=NULL,T.max=9999,T.plot=NULL, - P=NULL,fun.legend="topleft",coefficients=NULL) { + fun.legend="topleft",coefficients=NULL) { # plot experimental and modelled volumes and heat capacities # first figure out the property (Cp or V) from the exptdata prop <- colnames(exptdata)[3] @@ -93,71 +105,52 @@ if(prop=="Cp") var <- c("invTTheta2","TXBorn") if(prop=="V") var <- c("invTTheta","QBorn") } - expt <- exptdata # perform the regression, only using temperatures up to T.max if(is.null(coefficients)) { - EOSlm <- EOSregress(expt,var,T.max) + EOSlm <- EOSregress(exptdata, var, T.max) coefficients <- EOSlm$coefficients } # only plot points below a certain temperature - iexpt <- 1:nrow(expt) - if(!is.null(T.plot)) iexpt <- which(expt$T < T.plot) - iX <- match(prop,colnames(expt)) - ylim <- extendrange(expt[iexpt,iX],f=0.1) - xlim <- extendrange(expt$T[iexpt],f=0.1) + iexpt <- 1:nrow(exptdata) + if(!is.null(T.plot)) iexpt <- which(exptdata$T < T.plot) + iX <- match(prop, colnames(exptdata)) + ylim <- extendrange(exptdata[iexpt, iX], f=0.1) + xlim <- extendrange(exptdata$T[iexpt], f=0.1) # start plot - thermo.plot.new(xlim=xlim,ylim=ylim,xlab=axis.label("T", units="K"), - ylab=axis.label(paste(prop,"0",sep="")),yline=2,mar=NULL) - # we group the data by pressure ranges; - # assume increasing temperatures are in the - # same pressure range but a decrease in temperature - # signals the next pressure range - idrop <- c(1,which(diff(expt$T)<0)+1,length(expt$T)+1) - Plab <- character() - pch.open <- c(1,0,2) - pch.filled <- c(16,15,17) - for(i in 1:(length(idrop)-1)) { - ip <- idrop[i]:(idrop[i+1]-1) - # find the calculated values at these conditions - myT <- expt$T[ip] - myP <- expt$P[ip] - calc.X <- EOScalc(coefficients,myT,myP) - expt.X <- expt[ip,iX] - # are we within 10% of the values - in10 <- which(abs((calc.X-expt.X)/expt.X) < 0.1) - pch <- rep(pch.open[i],length(myT)) - pch[in10] <- pch.filled[i] - points(myT,expt[ip,iX],pch=pch) - # if we calculate lines at a constant P, do that - xs <- seq(xlim[1],xlim[2],length.out=200) - if(!is.null(P)) { - myT <- xs - myP <- P - calc.X <- EOScalc(coefficients,myT,myP) - } - # take out NAs and Infinite values - iNA <- is.na(calc.X) | is.infinite(calc.X) - xs <- xs[!iNA] - calc.X <- calc.X[!iNA] - myT <- myT[!iNA] - # plot regression line - lines(xs,splinefun(myT,calc.X,method="monoH.FC")(xs)) - Plim <- range(expt$P[ip]) - Plab <- c(Plab,paste(Plim[1],"-",Plim[2],"bar")) - } + thermo.plot.new(xlim=xlim, ylim=ylim, xlab=axis.label("T", units="K"), + ylab=axis.label(paste(prop, "0", sep="")), yline=2, mar=NULL) + # different plot symbols to represent size of residuals + pch.open <- 1 + pch.filled <- 16 + # find the calculated values at these conditions + calc.X <- EOScalc(coefficients, exptdata$T, exptdata$P) + expt.X <- exptdata[, iX] + # are we within 10% of the values + in10 <- which(abs((calc.X-expt.X)/expt.X) < 0.1) + pch <- rep(pch.open, length(exptdata$T)) + pch[in10] <- pch.filled + points(exptdata$T, exptdata[, iX], pch=pch) + # take out NAs and Infinite values + iNA <- is.na(calc.X) | is.infinite(calc.X) + # plot regression line at a single P + P <- mean(exptdata$P) + msgout("EOSplot: plotting line for P=", P, " bar\n") + xs <- seq(xlim[1], xlim[2], length.out=200) + calc.X <- EOScalc(coefficients, xs, P) + lines(xs, calc.X) # make legend if(!is.null(fun.legend)) { - coeffs <- as.character(round(as.numeric(coefficients),4)) + coeffs <- as.character(round(as.numeric(coefficients), 4)) # so that positive ones appear with a plus sign ipos <- which(coeffs >= 0) - coeffs[ipos] <- paste("+",coeffs[ipos],sep="") + coeffs[ipos] <- paste("+", coeffs[ipos], sep="") # make labels for the functions fun.lab <- as.expression(lapply(1:length(coeffs), function(x) {EOSlab(names(coefficients)[x],coeffs[x])} )) #fun.lab <- paste(names(coeffs),round(as.numeric(coeffs),4)) - legend(fun.legend,legend=fun.lab,pt.cex=0.1) + legend(fun.legend, legend=fun.lab, pt.cex=0.1) } - return(invisible(list(xlim=range(expt$T[iexpt])))) + return(invisible(list(xlim=range(exptdata$T[iexpt])))) } EOScoeffs <- function(species, property) { Modified: pkg/CHNOSZ/inst/NEWS =================================================================== --- pkg/CHNOSZ/inst/NEWS 2013-02-12 22:35:25 UTC (rev 42) +++ pkg/CHNOSZ/inst/NEWS 2013-02-13 14:28:35 UTC (rev 43) @@ -1,4 +1,4 @@ -CHANGES IN CHNOSZ 0.9-9.5 (2013-02-13) +CHANGES IN CHNOSZ 0.9-9.6 (2013-02-13) -------------------------------------- - Fix calculation of free energy derivative in wjd(). @@ -45,9 +45,16 @@ - Separate rho.IAPWS95() from water.IAPWS95(). -- Any property of water can be used as a variable in EOSvar(). +- In addition to the original regression variables, EOSvar() recognizes + names for available properties in water(), or can use the name to + get a user-defined function of temperature and pressure. +- Simplify EOSplot() somewhat (don't group data by pressure ranges). +- [temporary] Deactivate code using 'central' method in guess() + (wjd.Rnw) as limSolve package on not available on R-Forge for windows. + + CHANGES IN CHNOSZ 0.9-9 (2013-01-01) ------------------------------------ Modified: pkg/CHNOSZ/inst/doc/wjd.pdf =================================================================== (Binary files differ) Modified: pkg/CHNOSZ/inst/tests/test-EOSregress.R =================================================================== --- pkg/CHNOSZ/inst/tests/test-EOSregress.R 2013-02-12 22:35:25 UTC (rev 42) +++ pkg/CHNOSZ/inst/tests/test-EOSregress.R 2013-02-13 14:28:35 UTC (rev 43) @@ -2,5 +2,43 @@ test_that("EOSvar stops with unknown variables", { expect_error(EOSvar("TX", T=25, P=1), "can't find a variable named TX") + # why can't the test find these? + #TX <- 2 + #expect_error(EOSvar("TX", T=25, P=1), "an object named TX is not a function") + #TX <- function(T) 2 + #expect_error(EOSvar("TX", T=25, P=1), "the arguments of TX\\(\\) are not T, P") }) +test_that("regressions return known HKF parameters", { + # regress computed values of heat capacity and volume of CH4(aq) + # calculated from HKF parameters on a T-P grid + T <- convert(seq(0, 350, 25), "K") + P <- seq(200, 1000, 100) + # convert=FALSE means that temperature has units of K + CH4.prop <- subcrt("CH4", T=T, P=P, grid="T", convert=FALSE)$out[[1]] + # terms in the HKF equations for Cp + Cp.var <- c("invTTheta2", "TXBorn") + # get coefficients in Cp regression + Cp.lm <- EOSregress(CH4.prop[, c("T", "P", "Cp")], Cp.var) + Cp.coeff <- Cp.lm$coefficients + # terms in the HKF equations for V + V.var <- c("invPPsi", "invTTheta", "invPPsiTTheta", "QBorn") + # get coefficients in V regression + V.lm <- EOSregress(CH4.prop[, c("T", "P", "V")], V.var) + # use same units as HKF: convert from cm3.bar to calories (divide by 41.84) + V.coeff <- convert(V.lm$coefficients, "calories") + ## the tests: did we get the HKF parameters that are in the database? + CH4.par <- info(info("CH4")) + # c1 and c2 + expect_equal(Cp.coeff[1], CH4.par$c1, check.attr=FALSE) + expect_equal(Cp.coeff[2], CH4.par$c2, check.attr=FALSE) + # omega (from Cp) + expect_equal(Cp.coeff[3], CH4.par$omega, check.attr=FALSE) + # a1, a2, a3 and a4 + expect_equal(V.coeff[1], CH4.par$a1, check.attr=FALSE) + expect_equal(V.coeff[2], CH4.par$a2, check.attr=FALSE) + expect_equal(V.coeff[3], CH4.par$a3, check.attr=FALSE) + expect_equal(V.coeff[4], CH4.par$a4, check.attr=FALSE) + # omega (from V) - note negative sign + expect_equal(-V.coeff[5], CH4.par$omega, check.attr=FALSE) +}) Modified: pkg/CHNOSZ/man/EOSregress.Rd =================================================================== --- pkg/CHNOSZ/man/EOSregress.Rd 2013-02-12 22:35:25 UTC (rev 42) +++ pkg/CHNOSZ/man/EOSregress.Rd 2013-02-13 14:28:35 UTC (rev 43) @@ -8,7 +8,8 @@ \alias{EOScoeffs} \title{Regress Equations-of-State Parameters for Aqueous Species} \description{ - Functions for fitting experimental volume and heat capacities using regression equations. Possible models include the Helgeson-Kirkham-Flowers (HKF) equations of state and other equations defined using any combination of terms derived from the temperature, pressure and thermodynamic and electrostatic properties of water. +Fit experimental volumes and heat capacities using regression equations. +Possible models include the Helgeson-Kirkham-Flowers (HKF) equations of state, or other equations defined using any combination of terms derived from the temperature, pressure and thermodynamic and electrostatic properties of water and/or user-defined functions of temperature and pressure. } \usage{ @@ -16,7 +17,7 @@ EOSvar(var, T, P) EOScalc(coefficients, T, P) EOSplot(exptdata, var = NULL, T.max = 9999, T.plot = NULL, - P = NULL, fun.legend = "topleft", coefficients = NULL) + fun.legend = "topleft", coefficients = NULL) EOSlab(var, coeff = "") EOScoeffs(species, property) } @@ -36,7 +37,10 @@ } \details{ - \code{EOSregress} uses \code{\link{lm}} to regress the experimental heat capacity or volume data in \code{exptdata}, which is a data.frame with columns \samp{T} (temperature in degrees Kelvin), \samp{P} (pressure in bars), and \samp{Cp} or \samp{V} (heat capacity in cal/mol.K or volume in cm3/mol). Only data below the temperature of \code{T.max} are included in the regression. The regression formula is specified by a vector of names in \code{var}; these names correspond to variables identified below: +\code{EOSregress} uses \code{\link{lm}} to regress the experimental heat capacity or volume data in \code{exptdata}, which is a data frame with columns \samp{T} (temperature in degrees Kelvin), \samp{P} (pressure in bars), and \samp{Cp} or \samp{V} (heat capacity in cal/mol.K or volume in cm3/mol). +Only data below the temperature of \code{T.max} are included in the regression. +The regression formula is specified by a vector of names in \code{var}. +The names of the variables can be any combination of the following (listed in the order of search): variables listed in the following table, any available property of \code{\link{water}} (e.g. \samp{V}, \samp{alpha}, \samp{QBorn}), or the name of a function that can be found using \code{\link{get}} in the default environment (e.g. a function defined by the user in the global environment; the arguments of the function should be \code{T} and \code{P}; see example). \tabular{ll}{ \code{T} \tab \eqn{T}{T} (temperature) \cr @@ -45,32 +49,33 @@ \code{invTTheta} \tab \eqn{1/(T-\Theta)}{1/(T-Theta)} \cr \code{TTheta2} \tab \eqn{(T-\Theta)^2}{(T-Theta)^2} \cr \code{invTTheta2} \tab \eqn{1/(T-\Theta)^2}{1/(T-Theta)^2} \cr - \code{invPPsi} \tab \eqn{1/(P+\Psi)}{1/(P+Psi)} \cr + \code{invPPsi} \tab \eqn{1/(P+\Psi)}{1/(P+Psi)} (\eqn{\Psi}{Psi} = 2600 bar) \cr \code{invPPsiTTheta} \tab \eqn{1/((P+\Psi)(T-\Theta))}{1/((P+Psi)(T-Theta))} \cr - \code{V} \tab \eqn{V}{V} (volume of water) \cr - \code{E} \tab \eqn{E}{E} (isobaric expansivity of water) \cr - \code{kT} \tab \eqn{\kappa_T}{kT} (isothermal compressibility of water) \cr - \code{alpha} \tab \eqn{\alpha}{alpha} (coefficient of isobaric expansivity of water) \cr - \code{beta} \tab \eqn{\beta}{beta} (coefficients of isothermal compressibility of water) \cr - \code{X} \tab \eqn{X}{X} (Born function \eqn{X}{X}) \cr - \code{Q} \tab \eqn{Q}{Q} (Born function \eqn{Q}{Q}) \cr - \code{TX} \tab \eqn{TX}{TX} (temperature times \eqn{X}{X}) \cr + \code{TXBorn} \tab \eqn{TX}{TX} (temperature times \eqn{X}{X} Born function) \cr \code{drho.dT} \tab \eqn{d\rho/dT}{drho/dT} (temperature derivative of density of water) \cr \code{V.kT} \tab \eqn{V\kappa_T}{V.kT} (volume times isothermal compressibility of water) } - \code{EOSvar} takes as input \code{var} (one of the names of the variables listed above), and \code{T} (temperature in degrees Kelvin), \code{P} (pressure in bars). It returns the value of the variable at the specified temperature-pressure condition(s). This function is used by \code{EOSregress} to get the values of the variables used in the regression. - \code{EOScalc} calculates the predicted heat capacities or volumes using coefficients provided by the result of \code{EOSregress}, at the temperatures and pressures specified by \code{T} and \code{P}. +\code{EOSvar} calculates the value of the variable named \code{var} (defined as described above) at the specified \code{T} (temperature in degrees Kelvin) and \code{P} (pressure in bars). +This function is used by \code{EOSregress} to get the values of the variables used in the regression. - \code{EOSplot} takes a table of data in \code{exptdata}, runs \code{EOSregress} and \code{EOSpred} and plots the results. The experimental data are plotted as points, and the calculated values as a smooth line. The point symbols are filled circles where the calculated value is within 10\% of the experimental value; open circles otherwise. +\code{EOScalc} calculates the predicted heat capacities or volumes using coefficients provided by the result of \code{EOSregress}, at the temperatures and pressures specified by \code{T} and \code{P}. - \code{EOSlab} produces labels for the variables listed above that can be used \code{\link{as.expression}}s in plots. The value of \code{coeff} is prefixed (using \code{\link{substitute}}) to the name of the variable. +\code{EOSplot} takes a table of data in \code{exptdata}, runs \code{EOSregress} and \code{EOScalc} and plots the results. +The experimental data are plotted as points, and the calculated values as a smooth line. +The point symbols are filled circles where the calculated value is within 10\% of the experimental value; open circles otherwise. - \code{EOScoeffs} retrieves coefficients in the Helgeson-Kirkham-Flowers equations from the thermodynamic database (\code{\link{thermo}$obigt}) for the given aqueous \code{species}. If the \code{property} is \samp{Cp}, the resulting dataframe has column names of \samp{(Intercept)}, \samp{invTTheta2} and \samp{TX}, respectively holding the coefficients \eqn{c_1}{c1}, \eqn{c_2}{c2} and \eqn{\omega}{omega} in equation \eqn{Cp^\circ = c_1 + c_2/(T-\Theta)^2 + {\omega}TX}{Cp = c1 + c2/(T-Theta)^2 + omega*TX}. If the \code{property} is \samp{V}, the data frame has column names of \samp{(Intercept)}, \samp{invTTheta} and \samp{Q}, respectively holding the coefficients \eqn{\sigma}{sigma}, \eqn{\xi}{xi} and \eqn{-\omega}{-omega} in \eqn{V^\circ = \sigma + \xi/(T-\Theta) - {\omega}Q}{V = sigma + xi/(T-Theta) - omega*Q}. +\code{EOSlab} produces labels for the variables listed above that can be used \code{\link{as.expression}}s in plots. +The value of \code{coeff} is prefixed (using \code{\link{substitute}}) to the name of the variable. - The motivation for writing these functions is to explore alternatives or possible modifications to the revised Helgeson-Kirkham-Flowers equations applied to aqueous nonelectrolytes. As pointed out by Schulte et al., 2001, the functional forms of the equations do not permit retrieving values of the solvation parameter (\eqn{\omega}{omega}) that closely represent the observed trends in both heat capacity and volume at high temperatures (above ca. 200 \eqn{^{\circ}}{?}C). +\code{EOScoeffs} retrieves coefficients in the Helgeson-Kirkham-Flowers equations from the thermodynamic database (\code{\link{thermo}$obigt}) for the given aqueous \code{species}. +If the \code{property} is \samp{Cp}, the resulting data frame has column names of \samp{(Intercept)}, \samp{invTTheta2} and \samp{TX}, respectively holding the coefficients \eqn{c_1}{c1}, \eqn{c_2}{c2} and \eqn{\omega}{omega} in the equation \eqn{Cp^\circ = c_1 + c_2/(T-\Theta)^2 + {\omega}TX}{Cp = c1 + c2/(T-Theta)^2 + omega*TX}. +If the \code{property} is \samp{V}, the data frame has column names of \samp{(Intercept)}, \samp{invTTheta} and \samp{Q}, respectively holding the coefficients \eqn{\sigma}{sigma}, \eqn{\xi}{xi} and \eqn{-\omega}{-omega} in \eqn{V^\circ = \sigma + \xi/(T-\Theta) - {\omega}Q}{V = sigma + xi/(T-Theta) - omega*Q}. +The motivation for writing these functions is to explore alternatives or possible modifications to the revised Helgeson-Kirkham-Flowers equations applied to aqueous nonelectrolytes. +As pointed out by Schulte et al., 2001, the functional forms of the equations do not permit retrieving values of the solvation parameter (\eqn{\omega}{omega}) that closely represent the observed trends in both heat capacity and volume at high temperatures (above ca. 200 \eqn{^{\circ}}{?}C). + } \value{ @@ -88,40 +93,7 @@ \examples{ \dontshow{data(thermo)} -## regress calculated heat capacities and volumes of CH4(aq) -## to test that regressions return known HKF parameters -# calculate the properties of CH4 on a T-P grid -T <- convert(seq(0, 350, 25), "K") -P <- seq(200, 1000, 100) -# convert=FALSE means that temperature has units of K -CH4.prop <- subcrt("CH4", T=T, P=P, grid="T", convert=FALSE)$out[[1]] -# terms in the HKF equations for Cp -Cp.var <- c("invTTheta2", "TXBorn") -# get coefficients in Cp regression -Cp.lm <- EOSregress(CH4.prop[, c("T", "P", "Cp")], Cp.var) -Cp.coeff <- Cp.lm$coefficients -# terms in the HKF equations for V -V.var <- c("invPPsi", "invTTheta", "invPPsiTTheta", "QBorn") -# get coefficients in V regression -V.lm <- EOSregress(CH4.prop[, c("T", "P", "V")], V.var) -# use same units as HKF: convert from cm3.bar to calories (divide by 41.84) -V.coeff <- convert(V.lm$coefficients, "calories") -## the tests: did we get the HKF parameters that are in the database? -CH4.par <- info(info("CH4")) -# c1 and c2 -stopifnot(all.equal(Cp.coeff[1], CH4.par$c1, check.attr=FALSE)) -stopifnot(all.equal(Cp.coeff[2], CH4.par$c2, check.attr=FALSE)) -# omega (from Cp) -stopifnot(all.equal(Cp.coeff[3], CH4.par$omega, check.attr=FALSE)) -# a1, a2, a3 and a4 -stopifnot(all.equal(V.coeff[1], CH4.par$a1, check.attr=FALSE)) -stopifnot(all.equal(V.coeff[2], CH4.par$a2, check.attr=FALSE)) -stopifnot(all.equal(V.coeff[3], CH4.par$a3, check.attr=FALSE)) -stopifnot(all.equal(V.coeff[4], CH4.par$a4, check.attr=FALSE)) -# omega (from V) - note negative sign -stopifnot(all.equal(-V.coeff[5], CH4.par$omega, check.attr=FALSE)) - -## regress experimental heat capacities of CH4 +## fit experimental heat capacities of CH4 ## using revised Helgeson-Kirkham-Flowers equations # read the data from Hnedkovsky and Wood, 1997 f <- system.file("extdata/cpetc/Cp.CH4.HW97.csv", package="CHNOSZ") @@ -151,6 +123,16 @@ EOSplot(d, coefficients=CH4coeffs, T.plot=600) title("Cp from EOS parameters in database") +# following from above, with user-defined variables +invTTTheta3 <- function(T, P) (2*T)/(T-T*thermo$opt$Theta)^3 +invTX <- function(T, P) 1/T*water("XBorn", T=T, P=P)[,1] +EOSvar("invTTTheta3", d$T, d$P) +var <- c("invTTTheta3", "invTX") +EOSregress(d, var) +# the plot is commented for this toy example +#EOSplot(d, var) + + ## model experimental volumes of CH4 ## using HKF equation and an exploratory one f <- system.file("extdata/cpetc/V.CH4.HWM96.csv", package="CHNOSZ") Modified: pkg/CHNOSZ/vignettes/wjd.Rnw =================================================================== --- pkg/CHNOSZ/vignettes/wjd.Rnw 2013-02-12 22:35:25 UTC (rev 42) +++ pkg/CHNOSZ/vignettes/wjd.Rnw 2013-02-13 14:28:35 UTC (rev 43) @@ -265,8 +265,8 @@ as.list(args(wjd))$Y Y1 <- guess(method="stoich") Y1 -Y2 <- guess(method="central") -Y2 +#Y2 <- guess(method="central") +#Y2 @ @@ -285,30 +285,15 @@ were \Sexpr{niterY1-niter} more iterations than using the default initial solution in \texttt{wjd()}. -\setkeys{Gin}{width=0.6\textwidth} -<>= -wY2 <- wjd(Y=Y2) -niterY2 <- length(wY2$lambda) -niterY2 -is.near.equil(wY2, tol=0.0001) -@ -\setkeys{Gin}{width=0.6\textwidth} -The initial guess generated using the ``central'' method lead to -\Sexpr{niterY2-niter} more iterations than encountered using the -argument defaults in \texttt{wjd()}, and the algorithm converged to -an even lower variability in chemical potentials of the elements than -using the ``stoich'' method. The differences in convergence could -be coincidental, and the ``stoich'' method might be preferable for -general usage because it allows multiple guesses to be tested automatically -(see below). + Do the different initial guesses actually give similar results? \setkeys{Gin}{width=0.6\textwidth} <>= plot(1:10, w$X, xlab="species", ylab="mole fraction") points(1:10, wY1$X, pch=0) -points(1:10, wY2$X, pch=2) +#points(1:10, wY2$X, pch=2) @ \setkeys{Gin}{width=0.6\textwidth} Modified: pkg/CHNOSZ/vignettes/wjd.lyx =================================================================== --- pkg/CHNOSZ/vignettes/wjd.lyx 2013-02-12 22:35:25 UTC (rev 42) +++ pkg/CHNOSZ/vignettes/wjd.lyx 2013-02-13 14:28:35 UTC (rev 43) @@ -79,6 +79,11 @@ \filename_suffix 0 \color #000000 \end_branch +\branch inactive +\selected 0 +\filename_suffix 0 +\color #000000 +\end_branch \index Index \shortcut idx \color #008000 @@ -1063,12 +1068,12 @@ \begin_layout Chunk -Y2 <- guess(method="central") +#Y2 <- guess(method="central") \end_layout \begin_layout Chunk -Y2 +#Y2 \end_layout \begin_layout Chunk @@ -1169,6 +1174,10 @@ \end_layout \begin_layout Standard +\begin_inset Branch inactive +status collapsed + +\begin_layout Standard \begin_inset Branch short status open @@ -1269,13 +1278,18 @@ guesses to be tested automatically (see below). \end_layout +\end_inset + + +\end_layout + \begin_layout Standard Do the different initial guesses actually give similar results? \end_layout \begin_layout Standard \begin_inset Branch short -status open +status collapsed \begin_layout Chunk @@ -1303,7 +1317,7 @@ \begin_layout Chunk -points(1:10, wY2$X, pch=2) +#points(1:10, wY2$X, pch=2) \end_layout \begin_layout Chunk