Hello.
The Delaporte package works properly on all R-core platforms except
Solaris SPARC, where it compiles properly but fails a number of its
tests [1]. Not having access to a SPARC testbed, I'm limited in what
kind of diagnostics I can do. One thing I have noticed is that a lot
of the failures occur when I am passing non-default logicals (like
lower tail or log). For example, the first failure at that link is
when "log = true" is supposed to be passed, but the SPARC answers are
the unlogged values. Of the 22 failed tests, 12 of them pass logicals.
I'll bring an example of how it is coded below, and if anyone
recognizes where SPARC specifically goes wrong, I'd appreciate. I
guess, if I absolutely had to, I could convert the logical to an
integer in C and pass the integer to Fortran which should work even
for SPARC, but I'd prefer not to if I could help it.
Thank you,
Avi
[1] https://cran.r-project.org/web/checks/check_results_Delaporte.html
*****Example Code*****
R code:
ddelap <- function(x, alpha, beta, lambda, log = FALSE){
if(!is.double(x)) {storage.mode(x) <- 'double'}
if(!is.double(alpha)) {storage.mode(alpha) <- 'double'}
if(!is.double(beta)) {storage.mode(beta) <- 'double'}
if(!is.double(lambda)) {storage.mode(lambda) <- 'double'}
if(any(x > floor(x))) {
warning("Non-integers passed to ddelap. These will have 0
probability.")
}
.Call(ddelap_C, x, alpha, beta, lambda, log)
}
C code:
void ddelap_f(double *x, int nx, double *a, int na, double *b, int nb,
double *l, int nl,
int *lg, double *ret);
extern SEXP ddelap_C(SEXP x, SEXP alpha, SEXP beta, SEXP lambda, SEXP
lg){
const int nx = LENGTH(x);
const int na = LENGTH(alpha);
const int nb = LENGTH(beta);
const int nl = LENGTH(lambda);
SEXP ret;
PROTECT(ret = allocVector(REALSXP, nx));
ddelap_f(REAL(x), nx, REAL(alpha), na, REAL(beta), nb, REAL(lambda),
nl, LOGICAL(lg), REAL(ret));
UNPROTECT(1);
return(ret);
}
Fortran: (not posting ddelap_f_s as that doesn't handle the logging)
subroutine ddelap_f(x, nx, a, na, b, nb, l, nl, lg, pmfv) bind(C,
name="ddelap_f")
integer(kind = c_int), intent(in), value :: nx, na, nb, nl
! Sizes
real(kind = c_double), intent(in), dimension(nx) :: x
! Observations
real(kind = c_double), intent(out), dimension(nx):: pmfv
! Result
real(kind = c_double), intent(in) :: a(na), b(nb),
l(nl)! Parameters
logical(kind = c_bool), intent(in) :: lg
! Log flag
integer :: i
! Integer
!$omp parallel do default(shared) private(i)
do i = 1, nx
if (x(i) > floor(x(i))) then
pmfv(i) = ZERO
else
pmfv(i) = ddelap_f_s(x(i), a(mod(i - 1, na) + 1), &
b(mod(i - 1, nb) + 1), l(mod(i -
1, nl) + 1))
end if
end do
!$omp end parallel do
if (lg) then
pmfv = log(pmfv)
end if
end subroutine ddelap_f
______________________________________________
R-package-devel@r-project.org mailing list
https://stat.ethz.ch/mailman/listinfo/r-package-devel
