R function 'Voronoi.mosaic' to S

[John Walter <John.F.Walter@noaa.gov>]

I am trying to use convert the function voronoi.mosaic from the R 
Tripack package to S and am encountering some problems that appear to be 
related to calling the Fortran. I am using SPLUS 7.0 on Windows XP 
professional Service pack 2 and R 2.3.0.
When I try to run this in SPLUS:
vm.test<-voronoi.mosaic(x=runif(20), y=runif(20))

I get the following error message:

Problem in .Fortran("trmesh",: "trmesh_" is not a symbol in the load 
table, while calling subroutine trmesh
Use traceback() to see the call stack


If anyone can help diagnose this problem I would greatly appreciate it.

Thanks.

John


For reference the function 'voronoi.mosaic' is as follows:

voronoi.mosaic<-
function (x, y = NULL, duplicate = "error")
{
   dummy.node <- function(x0, y0, x1, y1, x2, y2, d) {
       dx <- x2 - x1
       dy <- y2 - y1
       nx <- -dy
       ny <- dx
       rx <- (x1 + x2)/2 - x0
       ry <- (y1 + y2)/2 - y0
       lr <- sqrt(rx^2 + ry^2)
       ln <- sqrt(nx^2 + ny^2)
       if (lr > ln) {
           vx <- rx/lr
           vy <- ry/lr
           if (in.convex.hull(ret$tri, x0, y0))
               d <- d
           else d <- -d
       }
       else {
           vx <- nx/ln
           vy <- ny/ln
           eps <- 1e-07
           if (in.convex.hull(ret$tri, (x1 + x2)/2 + eps * vx,
               (y1 + y2)/2 + eps * vy))
               d <- -d
           else d <- d
       }
       list(x = x0 + d * vx, y = y0 + d * vy)
   }
   tri.obj <- tri.mesh(x = x, y = y, duplicate = duplicate)
   nt <- summary(tri.obj)$nt
   tmptri <- matrix(0, 9, 2 * nt)
   lccc <- matrix(0, 4, nt)
   storage.mode(lccc) <- "double"
   iccc <- matrix(0, 6, nt)
   storage.mode(iccc) <- "integer"
   ans <- .Fortran("voronoi", as.integer(tri.obj$nc), 
as.integer(tri.obj$lc),
       as.integer(tri.obj$n), as.double(tri.obj$x), as.double(tri.obj$y),
       as.integer(tri.obj$tlist), as.integer(tri.obj$tlptr),
       as.integer(tri.obj$tlend), as.integer(nt), lccc = as.double(lccc),
       iccc = as.integer(iccc), lct = integer(tri.obj$nc), 
as.integer(tmptri),
       ier = as.integer(0), PACKAGE = "tripack")
   lccc <- matrix(ans$lccc, nt, 4, byrow = TRUE)
   iccc <- matrix(ans$iccc, nt, 6, byrow = TRUE)
   ret <- list(x = lccc[, 1], y = lccc[, 2], node = (lccc[,
       3] > 0), area = lccc[, 3], ratio = lccc[, 4], n1 = iccc[,
       1], n2 = iccc[, 2], n3 = iccc[, 3], p1 = iccc[, 4], p2 = iccc[,
       5], p3 = iccc[, 6], tri = tri.obj)
   ret$dummy.x <- integer(0)
   ret$dummy.y <- integer(0)
   dummy.cnt <- 0
   dmax <- max(diff(range(ret$x)), diff(range(ret$y)))
   n <- length(ret$x)
   for (i in 1:n) {
       if (ret$node[i]) {
           tns <- sort(c(ret$n1[i], ret$n2[i], ret$n3[i]))
           tn1 <- tns[1]
           tn2 <- tns[2]
           tn3 <- tns[3]
           if (any(tns == 0)) {
               if (tns[2] != 0) {
                 tr <- c(ret$p1[i], ret$p2[i], ret$p3[i])
                 ns <- tr[on.convex.hull(ret$tri, ret$tri$x[tr],
                   ret$tri$y[tr])]
                 if (length(ns) == 2) {
                   i1 <- ns[1]
                   i2 <- ns[2]
                   pn <- dummy.node(ret$x[i], ret$y[i], ret$tri$x[i1],
                     ret$tri$y[i1], ret$tri$x[i2], ret$tri$y[i2],
                     dmax)
                   dummy.cnt <- dummy.cnt + 1
                   ret$dummy.x[dummy.cnt] <- pn$x
                   ret$dummy.y[dummy.cnt] <- pn$y
                   if (ret$n1[i] == 0)
                     ret$n1[i] <- -dummy.cnt
                   if (ret$n2[i] == 0)
                     ret$n2[i] <- -dummy.cnt
                   if (ret$n3[i] == 0)
                     ret$n3[i] <- -dummy.cnt
                 }
               }
               else {
                 tr <- c(ret$p1[i], ret$p2[i], ret$p3[i])
                 edge <- list(from = tr[c(1, 2, 3)], to = tr[c(2,
                   3, 1)])
                 mx <- ret$tri$x[edge$from] - ret$tri$x[edge$to]/2
                 my <- ret$tri$y[edge$from] - ret$tri$y[edge$to]/2
                 eonb <- on.convex.hull(ret$tri, mx, my)
                 for (id in 1:3) {
                   if (eonb[id]) {
                     pn <- dummy.node(ret$x[i], ret$y[i], 
ret$tri$x[edge$from[id]],
                       ret$tri$y[edge$from[id]], ret$tri$x[edge$to[id]],
                       ret$tri$y[edge$to[id]], dmax)
                     dummy.cnt <- dummy.cnt + 1
                     ret$dummy.x[dummy.cnt] <- pn$x
                     ret$dummy.y[dummy.cnt] <- pn$y
                     if (ret$n1[i] == 0)
                       ret$n1[i] <- -dummy.cnt
                     if (ret$n2[i] == 0)
                       ret$n2[i] <- -dummy.cnt
                     if (ret$n3[i] == 0)
                       ret$n3[i] <- -dummy.cnt
                   }
                 }
               }
           }
       }
       else {
           tmp <- 0
       }
   }
   ret$call <- match.call()
   class(ret) <- "voronoi"
   ret
}




--
John F. Walter III, Ph.D.
Rosenstiel School of Marine and
Atmospheric Sciences
4600 Rickenbacker Causeway
Miami, Florida  33149
Phone: 305-365-4114
Fax: 305-365-4104
Cell: 804-815-0881
email: john.f.walter@noaa.gov