

# Chapter 4 Complements

# 4.7

horner.c:

static double horner(double x, double *b, int n)
{
    int i;
    double p = b[n];
    for(i = n-1; i >= 0; i--)
        p = b[i] + x * p;
    return p;
}

void
poly(long int *m, double *p, double *x, long int *n, double *b)
{
    long i;
    for (i = 0; i < *m; i++)
        p[i] = horner(x[i], b, (int)*n);
}

polynom <- function(x, b)
{
  m <- as.integer(length(x))
  n <- as.integer(length(b)-1)
  storage.mode(x) <- "double"
  p <- x
  storage.mode(b) <- "double"
  .C("poly", m, val = p, x, n, b)$val
}
mat <- matrix(1:9,3,3)
polynom(mat, -1:1)


test.f:

      subroutine test(x, ifail)
      real x
      if(ifail .ge. 0) write(*, 1000) x
      return
1000  format(" X is ",f6.3)
      end


testf <- function(x, ifail) 
     invisible(.Fortran("test", as.single(x), as.integer(ifail)))
dyn.load("test.o",1)

dummy.c:

#include <stdio.h>
s_wsFe() {fprintf(stderr, "called dummy Fortran I/O\n");}
do_f_out() {fprintf(stderr, "called dummy Fortran I/O\n");}
e_wsfe() {fprintf(stderr, "called dummy Fortran I/O\n");}


dyn.load2(c("test.o", "dummy.o"))
testf(13.7, -1)

ourdist <- function(x)
{
   n <- nrow(x)
   res <- .C("ourdist",  as.double(x), as.integer(n),
              as.integer(ncol(x)),  res = double(n*(n-1)/2),
              NAOK = T)$res
   attr(res, "Size") <- n
   res
}

C code: 

/* R VERSION follows
#include <S.h>
#include <math.h>

void  ourdist(double *x, long *nin, long *pin, double *res)
{
   int     i, j, k, den, n = *nin, p = *pin;
   double  item, tmp;

   for (i = 0; i < n-1; i++)
      for (j = i+1; j < n; j++) {
         den = 0; tmp = 0.0;
         for (k = 0; k < p; k++) {
            if (!is_na(x + i + n * k, DOUBLE) &&
                !is_na(x + j + n * k, DOUBLE)) {
               den++;
               item = x[i + n * k] - x[j + n * k];
               tmp += item * item;
            }
         }
         if (!den) na_set3(&tmp, DOUBLE, Is_NaN);
         else tmp = sqrt(tmp * p / den);
         *res++ = tmp;
      }
}*/ 

#include <Arith.h>
#include <math.h>

void  ourdist(double *x, long *nin, long *pin, double *res)
{
   int     i, j, k, den, n = *nin, p = *pin;
   double  item, tmp;

   for (i = 0; i < n-1; i++)
      for (j = i+1; j < n; j++) {
         den = 0; tmp = 0.0;
         for (k = 0; k < p; k++)
            if (!ISNA(x[i + n * k]) && !ISNAN(x[i + n * k])
                !ISNA(x[j + n * k]) && !ISNAN(x[j + n * k]))
            {
               den++;
               item = x[i + n * k] - x[j + n * k];
               tmp += item * item;
            }
         if (!den) tmp = NA_REAL;
         else tmp = sqrt(tmp * p / den);
         *res++ = tmp;
      }
}

# End of ch04c
