R/header_tool.R

In TMB: Template Model Builder: A General Random Effect Tool Inspired by 'ADMB'

## Header extraction (keep declaration - remove definition)
declExtract <- function(x, level=2){ ## level of matching curly brackets to exclude
    x <- paste(x, "\n")
    x <- paste(x, collapse="")
    x <- strsplit(x,"")[[1]]
    y <- cumsum( (x=="{") - (x=="}") )
    mark.left <- (y == level) & (x=="{")      ## Begin {
    mark.right <- (y == level - 1) & (x=="}") ## End   }
    x[y >= level] <- "" ## Discard
    x[mark.right] <- ";"
    x <- paste(x, collapse="")
    x <- strsplit(x, "\n")[[1]]
    ## Change e.g. "matrix(T1 x):Base(x);" to "matrix(T1 x);"
    x <- sub(")[ ]*:.*;",");",x)
    x
}

## Template class extraction
tclassExtract <- function(x){
    from <- grep("^class|^struct", x) - 1
    to   <- grep("^};", x)
    from <- from[ findInterval(to, from) ]
    nm <- gsub("^[^ ]*[ ]*([^ ^{^:]*).*", "\\1", x[from+1])
    ans <- Map("[", list(x), Map(":", from, to) )
    names(ans) <- nm
    ans
}

## Template class specialization
tclassSpecialize <- function(y, type="double"){
    if(length(type) > 1){
        return( unlist(lapply(type, function(x)tclassSpecialize(y, x))) )
    }
    typename <- sub("^template[ ]*<class (.*)>.*","\\1",y[1])
    y[1] <- "template <>"
    nm <- gsub("^[^ ]*[ ]*([^ ^{^:]*).*", "\\1", y[2])
    y[2] <- sub(nm,paste0(nm,"<",type,">"),y[2])
    y <- gsub(typename, type, y)
    y
}

## template class precompilation (explicit instantiation)
tclassInstantiate <- function(y, type = "double"){
    nm <- gsub("(^[^ ]*[ ]*[^ ^{^:]*).*", "\\1", y[2])
    paste0("template ", nm, "<", type,">;")
}

## Macro extraction
macroExtract <- function(x){
    x <- paste(x, "\n")
    x <- paste(x, collapse="")
    x <- gsub("\\\\[ ]*\n","",x)
    x <- gsub("\t","",x)
    x <- strsplit(x, "\n")[[1]]
    x <- grep("^#define", x, value=TRUE)
    nm <- sub("#define ([^ ^(]*).*", "\\1", x)
    names(x) <- nm
    x
}

## Cleanup source
cleanup <- function(x){
    x <- .removeComments(x)    ## Remove comments
    x <- gsub("[ ]*$", "", x)  ## Remove trailing whitespace
    x <- x[x != ""]            ## Remove empty lines
    x
}

########################################################
## Example
precompSource <- function(
    filename  = "include/tmbutils/density.hpp",
    namespace = "density",
    classes   = "MVNORM_t",
    types     = c(
        "double ",
        ## "CppAD::AD<double> ",
        ## "CppAD::AD<CppAD::AD<double> > ",
        ## "CppAD::AD<CppAD::AD<CppAD::AD<double> > > ",
        "TMBad::ad_aug"),
    macros    = TRUE,
    append    = FALSE ## Modify input file in place
    ) {
    ## density namespace
    x <- readLines( system.file(filename, package="TMB") )
    tcl <- tclassExtract(x)
    dcl <- lapply(tcl, declExtract)
    spec <- lapply(dcl, tclassSpecialize, type = types)
    macro <- macroExtract(x)
    macros <- rep(macros, length.out = length(macro))
    ans <- c(
        ## Begin namespace
        paste("namespace", namespace, "{")[!is.null(namespace)],
        ## macro-defines
        paste("#undef", names(macro))[macros],
        macro[macros],
        ## Explicit instantiation
        "#ifdef WITH_LIBTMB",
        unlist( spec[classes] ),
        "#endif",
        ## Precompiled version
        "#ifdef TMB_PRECOMPILE_ATOMICS",
        unlist( lapply(classes, function(name)tclassInstantiate(tcl[[name]], types) ) ),
        "#endif",
        ## Undefs
        paste("#undef", names(macro))[macros],
        ## End namespace
        "}"[!is.null(namespace)] )
    names(ans) <- NULL
    ## Add header
    ans <- cleanup(ans)
    ans <- c("// Autogenerated - do not edit by hand",
             "//",
             "// -DWITH_LIBTMB    : Extracts header declarations only.",
             "// -DTMB_PRECOMPILE_ATOMICS : Instantiations for precompilation.",
             ans)
    if (append) {
        writeLines(c(x, ans), system.file(filename, package="TMB") )
        return(NULL)
    }
    ans
}

precompileSource <- function() {
    CppAD_types <- c(
        "double ",
        "CppAD::AD<double> ",
        "CppAD::AD<CppAD::AD<double> > ",
        "CppAD::AD<CppAD::AD<CppAD::AD<double> > > ")
    TMBad_types <- c(
        "double ",
        "TMBad::ad_aug "
    )
    ## TODO :
    ## ==============================================
    ## precompSource(
    ##     filename  = "include/tmbutils/vector.hpp",
    ##     namespace = NULL,
    ##     classes   = c("vector", "matrix"),
    ##     append    = TRUE )
    ## ,
    ## precompSource(
    ##     filename  = "include/tmbutils/array.hpp",
    ##     namespace = "tmbutils",
    ##     classes   = c("array"),
    ##     macros    = FALSE )
    ## ,
    ## ==============================================
    x <- c(
        ## Precompile using CppAD
        "#ifdef CPPAD_FRAMEWORK",
        precompSource(
            filename  = "include/tmbutils/density.hpp",
            namespace = "density",
            classes   = c("MVNORM_t", "GMRF_t"),
            types = CppAD_types
        ),
        "#endif",
        ## Precompile using TMBad
        "#ifdef TMBAD_FRAMEWORK",
        precompSource(
            filename  = "include/tmbutils/density.hpp",
            namespace = "density",
            classes   = c("MVNORM_t", "GMRF_t"),
            types = TMBad_types
        ),
        "#endif"
    )
    x
}