doc/manual/R-exts.R

## debugging example

success <- c(13,12,11,14,14,11,13,11,12)
failure <- c(0,0,0,0,0,0,0,2,2)
resp <- cbind(success, failure)
predictor <- c(0, 5^(0:7))
### try would suppress a traceback
# glm(resp ~ 0+predictor, family = binomial(link="log"))
# traceback()


## R code to run the .Call/.External examples in
##    `Writing R extensions'

dyn.load(paste("R-exts", .Platform$dynlib.ext, sep=""))

## ----- outer products example -----

out <- function(x, y)
{
    storage.mode(x) <- storage.mode(y) <- "double"
    .Call("out", x, y)
}
out(1:3, 2:4)

x <- 1:3; names(x) <- letters[x]
out(x, 2:4)


## ----- convolution example -----

conv <- function(a, b) .Call("convolve2", a, b)
u <- rep(1, 5)
conv(u, u)

convE <- function(a, b) .External("convolveE", a, b)
convE(u, u)


## ----- Lists examples -----

showArgs <- function(...) invisible(.External("showArgs", ...))
showArgs(u = u, x = x, let = letters)

showArgs1 <- function(...) invisible(.Call("showArgs1", list(...)))
showArgs1(u = u, x = x, let = letters)

a <- list(a = 1:5, b = rnorm(10), test = runif(100))
.Call("lapply", a, quote(sum(x)), new.env())

.Call("lapply2", a, sum, new.env())


## ----- zero-finding -----

zero <- function(f, guesses, tol = 1e-7) {
    f.check <- function(x) {
        x <- f(x)
        if(!is.numeric(x)) stop("Need a numeric result")
        as.double(x)
    }
    .Call("zero", body(f.check), as.double(guesses), as.double(tol),
          new.env())
}

cube1 <- function(x) (x^2 + 1) * (x - 1.5)
zero(cube1, c(0, 5))

## ----- numerical derivatives -----

numeric.deriv <- function(expr, theta, rho = sys.frame(sys.parent()))
{
    eps <- sqrt(.Machine$double.eps)
    ans <- eval(substitute(expr), rho)
    grad <- matrix(, length(ans), length(theta),
                   dimnames = list(NULL, theta))
    for (i in seq_along(theta)) {
        old <- get(theta[i], envir=rho)
        delta <- eps * min(1, abs(old))
        assign(theta[i], old+delta, envir=rho)
        ans1 <- eval(substitute(expr), rho)
        assign(theta[i], old, envir=rho)
        grad[, i] <- (ans1 - ans)/delta
    }
    attr(ans, "gradient") <- grad
    ans
}
omega <- 1:5; x <- 1; y <- 2

numeric.deriv(sin(omega*x*y), c("x", "y"))

.External("numeric_deriv", quote(sin(omega*x*y)),
          c("x", "y"), .GlobalEnv)