inst/docs/mathnb/exprPrep.R

In copula: Multivariate Dependence with Copulas

expr2R <- function(fname) {
  myexpr <- readLines(fname)
  myexpr <- gsub("Log", "log", myexpr)
#### The following are no longer needed after changes in archmDer.m
#### to write expressions in separate lines.
#  myexpr <- sub("List\\(", "", myexpr)
#  myexpr <- sub("\\)$", "", myexpr)
#  myexpr <- strsplit(myexpr, ",")[[1]]

  ## return
  parse(text=myexpr, keep.source=FALSE)
}

getDExpr <- function(expr, name) {
  ## expr is a vector of expression
#### I was using sapply(expr, D, "u1), but somehow it returns a matrix
  val <- rep(NA, length(expr))
  for (i in 1:length(expr)) val[i] <- as.expression(D(expr[i], name))
  val
}


## Note:
## 1) deriv(x, "s"): in fact pdf.expr doesn't contain "s"; just a trick to
##    get the algorithmic expression for pdf, not its derivative
## 2) pdfDerWrtPar expression for frank cannot be obtained from Mathematica
##    even for dim = 5. Recall the max dim for pdf expression for frank is 6.
##    So I basically use D on pdf expressions and use deriv. Having something
##    slow is better than having nothing.
expr2algr2dump <- function(cname) {
  cdf.expr.name <- paste(cname, "Copula.cdf.expr", sep="")
  cdfDerWrtArg <- paste(cname, "Copula.cdfDerWrtArg.expr", sep="")
  cdfDerWrtPar <- paste(cname, "Copula.cdfDerWrtPar.expr", sep="")
  cdf.algr.name <- sub("expr", "algr", cdf.expr.name)
  cdfDerWrtArg.algr <- sub("expr", "algr", cdfDerWrtArg)
  cdfDerWrtPar.algr <- sub("expr", "algr", cdfDerWrtPar)
  
  pdf.expr.name <- paste(cname, "Copula.pdf.expr", sep="")
  pdfDerWrtArg <- paste(cname, "Copula.pdfDerWrtArg.expr", sep="")
  pdfDerWrtPar <- paste(cname, "Copula.pdfDerWrtPar.expr", sep="")
  pdf.algr.name <- sub("expr", "algr", pdf.expr.name)
  pdfDerWrtArg.algr <- sub("expr", "algr", pdfDerWrtArg)
  pdfDerWrtPar.algr <- sub("expr", "algr", pdfDerWrtPar)

  genfunDer.expr.name <- paste(cname, "Copula.genfunDer.expr", sep="")
  genfunDer.algr.name <- sub("expr", "algr", genfunDer.expr.name)

  assign(cdf.expr.name, cdf.expr <- expr2R(cdf.expr.name))
  assign(cdf.algr.name, sapply(cdf.expr, function(x) deriv(x, "s")))
  ## assign(cdfDerWrtArg, myExpr <- expr2R(cdfDerWrtArg))
  ## assign(cdfDerWrtArg, myExpr <- as.expression(sapply(cdf.expr, D, "u1")))
  assign(cdfDerWrtArg, myExpr <- getDExpr(cdf.expr, "u1"))
  assign(cdfDerWrtArg.algr, sapply(myExpr, function(x) deriv(x, "s")))
  ## assign(cdfDerWrtPar, myExpr <- expr2R(cdfDerWrtPar))
  ## assign(cdfDerWrtPar, myExpr <- as.expression(sapply(cdf.expr, D, "alpha")))
  assign(cdfDerWrtPar, myExpr <- getDExpr(cdf.expr, "alpha"))
  assign(cdfDerWrtPar.algr, sapply(myExpr, function(x) deriv(x, "s")))
  
  assign(pdf.expr.name, pdf.expr <- expr2R(pdf.expr.name))
  assign(pdf.algr.name, sapply(pdf.expr, function(x) deriv(x, "s")))
  ## assign(pdfDerWrtArg, myExpr <- expr2R(pdfDerWrtArg))
  ## assign(pdfDerWrtArg, myExpr <- as.expression(sapply(pdf.expr, D, "u1")))
  assign(pdfDerWrtArg, myExpr <- getDExpr(pdf.expr, "u1"))
  assign(pdfDerWrtArg.algr, sapply(myExpr, function(x) deriv(x, "s")))
  ## assign(pdfDerWrtPar, myExpr <- expr2R(pdfDerWrtPar))
  ## assign(pdfDerWrtPar, myExpr <- as.expression(sapply(pdf.expr, D, "alpha")))
  assign(pdfDerWrtPar, myExpr <- getDExpr(pdf.expr, "alpha"))
  assign(pdfDerWrtPar.algr, sapply(myExpr, function(x) deriv(x, "s")))
 
  assign(genfunDer.expr.name, genfunDer.expr <- expr2R(genfunDer.expr.name))
  assign(genfunDer.algr.name, sapply(genfunDer.expr, function(x) deriv(x, "s")))
  ## dname <- paste("../../../R/", cname, "Expr.R", sep="")
  dname <- paste("./", cname, "Expr.R", sep="")
  cat("## This file is not to be edited. It is generated by ../inst/docs/mathnb/exprPrep.R\n", file = dname)
  dump(c(cdf.expr.name, cdf.algr.name,
         cdfDerWrtArg, cdfDerWrtArg.algr,
         cdfDerWrtPar, cdfDerWrtPar.algr,
         pdf.expr.name, pdf.algr.name,
         pdfDerWrtArg, pdfDerWrtArg.algr,
         pdfDerWrtPar, pdfDerWrtPar.algr,         
         genfunDer.expr.name, genfunDer.algr.name),
       file = dname, append = TRUE)
}

## this is not working as expected:
##   assign(pdf.algr.name, sapply(as.name(pdf.expr.name), function(x) deriv(x, "s")))

expr2algr2dump("clayton")
expr2algr2dump("gumbel")
expr2algr2dump("frank")
expr2algr2dump("amh")

#### Old code used before the change of archmDer.m
## galambosCopula.expr <- expr2R("galambos.expr")
## galambosCopula.algr <- sapply(galambosCopula.expr,
##                               function(x) deriv(x, "s"))
## names(galambosCopula.expr) <- names(galambosCopula.algr) <- c("cdf", "pdf", "deriv1cdf")
## dump(c("galambosCopula.expr", "galambosCopula.algr"),
##      file="../../R/galambosExpr.R")

###################################################################
## For explicit copula, say, plackett
## Note: expressions are prefixed with 0 to cover nuissance dim = 1
###################################################################
algr2dump <- function(copula) {
  cname <- class(copula)[1]
  cname <- gsub("Copula", "", cname)
  cdf.expr.name <- paste(cname, "Copula.cdf.expr", sep="")
  cdfDerWrtArg <- paste(cname, "Copula.cdfDerWrtArg.expr", sep="")
  cdfDerWrtPar <- paste(cname, "Copula.cdfDerWrtPar.expr", sep="")
  cdf.algr.name <- sub("expr", "algr", cdf.expr.name)
  cdfDerWrtArg.algr <- sub("expr", "algr", cdfDerWrtArg)
  cdfDerWrtPar.algr <- sub("expr", "algr", cdfDerWrtPar)
  
  pdf.expr.name <- paste(cname, "Copula.pdf.expr", sep="")
  pdfDerWrtArg <- paste(cname, "Copula.pdfDerWrtArg.expr", sep="")
  pdfDerWrtPar <- paste(cname, "Copula.pdfDerWrtPar.expr", sep="")
  pdf.algr.name <- sub("expr", "algr", pdf.expr.name)
  pdfDerWrtArg.algr <- sub("expr", "algr", pdfDerWrtArg)
  pdfDerWrtPar.algr <- sub("expr", "algr", pdfDerWrtPar)
  
  assign(cdf.expr.name, cdf.expr <- as.expression(c(0, copula@exprdist$cdf)))
  assign(cdf.algr.name, sapply(cdf.expr, function(x) deriv(x, "s")))
  ## assign(cdfDerWrtArg, myExpr <- as.expression(sapply(cdf.expr, D, "u1")))
  assign(cdfDerWrtArg, myExpr <- getDExpr(cdf.expr, "u1"))
  assign(cdfDerWrtArg.algr, sapply(myExpr, function(x) deriv(x, "s")))
  ## assign(cdfDerWrtPar, myExpr <- as.expression(sapply(cdf.expr, D, "alpha")))
  assign(cdfDerWrtPar, myExpr <- getDExpr(cdf.expr, "alpha"))
  assign(cdfDerWrtPar.algr, sapply(myExpr, function(x) deriv(x, "s")))
  
  assign(pdf.expr.name, pdf.expr <- as.expression(c(0, copula@exprdist$pdf)))
  assign(pdf.algr.name, sapply(pdf.expr, function(x) deriv(x, "s")))
  ## assign(pdfDerWrtArg, myExpr <- as.expression(sapply(pdf.expr, D, "u1")))
  assign(pdfDerWrtArg, myExpr <- getDExpr(pdf.expr, "u1"))
  assign(pdfDerWrtArg.algr, sapply(myExpr, function(x) deriv(x, "s")))
  ## assign(pdfDerWrtPar, myExpr <- as.expression(sapply(pdf.expr, D, "alpha")))
  assign(pdfDerWrtPar, myExpr <- getDExpr(pdf.expr, "alpha"))
  assign(pdfDerWrtPar.algr, sapply(myExpr, function(x) deriv(x, "s")))

  ## dname <- paste("../../../R/", cname, "Expr.R", sep="")
  dname <- paste("./", cname, "Expr.R", sep="")
  cat("## This file is not to be edited. It is generated by ../inst/docs/mathnb/exprPrep.R\n", file = dname)
  dump(c(cdf.expr.name, cdf.algr.name,
         cdfDerWrtArg, cdfDerWrtArg.algr,
         cdfDerWrtPar, cdfDerWrtPar.algr,
         pdf.expr.name, pdf.algr.name,
         pdfDerWrtArg, pdfDerWrtArg.algr,
         pdfDerWrtPar, pdfDerWrtPar.algr        
         ## genfunDer.expr.name, genfunDer.algr.name
         ),
       file = dname, append = TRUE)
}

library(copula)
algr2dump(plackettCopula(1))      ## generates ../../../R/plackettExpr.R
algr2dump(galambosCopula(1))      ## generates ../../../R/galambosExpr.R
algr2dump(huslerReissCopula(1))   ## generates ../../../R/huslerReissExpr.R
algr2dump(tawnCopula(0))          ## generates ../../../R/tawnExpr.R