Merge pull request #1 from runehaubo/cran-submit-apr18

Cran submit apr18

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: ordinal
 Type: Package
 Title: Regression Models for Ordinal Data
-Version: 2015.6-28.9000
-Date: 2015-06-28
+Version: 2018.4-19
+Date: 2018-04-19
 Authors@R: person(given="Rune Haubo Bojesen", family="Christensen",
     email="[email protected]", role=c("aut", "cre"))
 LazyData: true

NAMESPACE

@@ -1,4 +1,4 @@
-useDynLib(ordinal, .registration = TRUE)
+useDynLib("ordinal", .registration = TRUE)
 
 importFrom(graphics,
            plot,

R/AO.R

@@ -11,7 +11,7 @@ pAOR <- function(q, lambda, lower.tail = TRUE) {
 }
 
 pAO <- function(q, lambda, lower.tail = TRUE)
-    .C("pAO",
+    .C("pAO_C",
        q = as.double(q),
        length(q),
        as.double(lambda[1]),
@@ -32,7 +32,7 @@ dAOR <- function(eta, lambda, log = FALSE) {
 dAO <- function(eta, lambda, log = FALSE) {
   stopifnot(length(lambda) == 1 &&
             length(log) == 1)
-  .C("dAO",
+  .C("dAO_C",
      eta = as.double(eta),
      length(eta),
      as.double(lambda),
@@ -48,7 +48,7 @@ gAOR <- function(eta, lambda) {
 
 gAO <- function(eta, lambda) {
   stopifnot(length(lambda) == 1)
-  .C("gAO",
+  .C("gAO_C",
      eta = as.double(eta),
      length(eta),
      as.double(lambda[1]),

R/clm2.R

@@ -1383,19 +1383,6 @@ grad.lambda <- function(rho, lambda, link, delta = 1e-6) {
     diff(f) /  diff(ll)
 }
 
-TraceC <- function(iter, stepFactor, val, maxGrad, par, first=FALSE) {
-    .C("trace",
-       as.integer(iter[1]),
-       as.double(stepFactor[1]),
-       as.double(val[1]),
-       as.double(maxGrad[1]),
-       as.double(par),
-       length(par),
-       as.integer(first[1]))
-
-    return(invisible())
-}
-
 TraceR <- function(iter, stepFactor, val, maxGrad, par, first=FALSE) {
     t1 <- sprintf(" %3d:     %.2e:   %.3f:   %1.3e:  ",
                   iter, stepFactor, val, maxGrad)

R/clmm.ssr.R

@@ -143,7 +143,7 @@ getNGHQ.ssr <- function(rho, par) {
     rho$neval <- rho$neval + 1L
   nllBase.uC(rho) ## Update tau, eta1Fix and eta2Fix
   with(rho, {
-    .C("getNGHQ",
+    .C("getNGHQ_C",
        nll = double(1),
        as.integer(grFac),
        as.double(tau),

R/clmm2.R

@@ -497,7 +497,7 @@ getNGHQinC <- function(rho, par) {
         rho$par <- par
     .negLogLikBase(rho) ## Update lambda, stDev, sigma and eta*Fix
     with(rho, {
-        .C("getNGHQ",
+        .C("getNGHQ_C",
            nll = double(1),
            as.integer(grFac),
            as.double(stDev),

R/clmm2.utils.R

@@ -78,7 +78,7 @@
 
 .gradC <- function(rho) {
     tmp <- with(rho, {
-        .C("grad",
+        .C("grad_C",
            as.double(stDev),
            p1 = double(length(pr)),
            p2 = double(length(pr)),
@@ -336,7 +336,7 @@ update.u2 <- function(rho)
 }
 
 grFacSumC <- function(x, grFac, u)
-    .C("grFacSum",
+    .C("grFacSum_C",
        as.double(x),
        as.integer(grFac),
        as.integer(length(x)),

R/gdist.R

@@ -8,21 +8,21 @@
 
 glogis <- function(x)
 ### gradient of dlogis
-    .C("glogis",
+    .C("glogis_C",
        x = as.double(x),
        length(x),
        NAOK = TRUE)$x
 
 gnorm <- function(x)
 ### gradient of dnorm(x) wrt. x
-    .C("gnorm",
+    .C("gnorm_C",
        x = as.double(x),
        length(x),
        NAOK = TRUE)$x
 
 gcauchy <- function(x)
 ### gradient of dcauchy(x) wrt. x
-    .C("gcauchy",
+    .C("gcauchy_C",
        x = as.double(x),
        length(x),
        NAOK = TRUE)$x

R/gumbel.R

@@ -8,15 +8,15 @@ pgumbel <-
 ### Currently only unit length location and scale are supported.
 {
   if(max)  ## right skew, loglog link
-    .C("pgumbel",
+    .C("pgumbel_C",
        q = as.double(q),
        length(q),
        as.double(location)[1],
        as.double(scale)[1],
        as.integer(lower.tail),
        NAOK = TRUE)$q
   else ## left skew, cloglog link
-    .C("pgumbel2",
+    .C("pgumbel2_C",
        q = as.double(q),
        length(q),
        as.double(location)[1],
@@ -45,15 +45,15 @@ dgumbel <-
 ### PDF for the Gumbel max and mon distributions
 {
   if(max)  ## right skew, loglog link
-    .C("dgumbel",
+    .C("dgumbel_C",
        x = as.double(x),
        length(x),
        as.double(location)[1],
        as.double(scale)[1],
        as.integer(log),
        NAOK = TRUE)$x
   else ## left skew, cloglog link
-    .C("dgumbel2",
+    .C("dgumbel2_C",
        x = as.double(x),
        length(x),
        as.double(location)[1],
@@ -80,12 +80,12 @@ dgumbel2R <- function(x, location = 0, scale = 1, log = FALSE)
 ggumbel <- function(x, max = TRUE) {
 ### gradient of dgumbel(x) wrt. x
   if(max) ## right skew, loglog link
-    .C("ggumbel",
+    .C("ggumbel_C",
        x = as.double(x),
        length(x),
        NAOK = TRUE)$x
   else ## left skew, cloglog link
-    .C("ggumbel2",
+    .C("ggumbel2_C",
        x = as.double(x),
        length(x),
        NAOK = TRUE)$x

R/lgamma.R

@@ -5,7 +5,7 @@
 ## used as a flexible link function in clm2() and clmm2().
 
 plgamma <- function(q, lambda, lower.tail = TRUE)
-    .C("plgamma",
+    .C("plgamma_C",
        q = as.double(q),
        length(q),
        as.double(lambda[1]),
@@ -27,7 +27,7 @@ plgammaR <- function(eta, lambda, lower.tail = TRUE) {
 dlgamma <- function(x, lambda, log = FALSE) {
   stopifnot(length(lambda) == 1 &&
             length(log) == 1)
-  .C("dlgamma",
+  .C("dlgamma_C",
      x = as.double(x),
      length(x),
      as.double(lambda),
@@ -46,7 +46,7 @@ dlgammaR <- function(x, lambda, log = FALSE) {
 
 glgamma <- function(x, lambda) {
   stopifnot(length(lambda) == 1)
-  .C("glgamma",
+  .C("glgamma_C",
      x = as.double(x),
      length(x),
      as.double(lambda[1]),

man/clmm.Rd

@@ -156,6 +156,13 @@ threshold = c("flexible", "symmetric", "symmetric2", "equidistant"), ...)
 }
 \examples{
 
+## Cumulative link model with one random term:
+fmm1 <- clmm(rating ~ temp + contact + (1|judge), data = wine)
+summary(fmm1)
+
+\dontrun{ 
+## May take a couple of seconds to run this.
+
 ## Cumulative link mixed model with two random terms:
 mm1 <- clmm(SURENESS ~ PROD + (1|RESP) + (1|RESP:PROD), data = soup,
             link = "probit", threshold = "equidistant")
@@ -166,6 +173,7 @@ summary(mm1)
 mm2 <- clmm(SURENESS ~ PROD + (1|RESP), data = soup,
             link = "probit", threshold = "equidistant")
 anova(mm1, mm2)
+}
 
 }
 % Add one or more standard keywords, see file 'KEYWORDS' in the

src/get_fitted.c

@@ -19,15 +19,15 @@ SEXP get_fitted(SEXP eta1p, SEXP eta2p, SEXP linkp, SEXP lambdap) {
      return: vector of fittec values of same length as eta1 and eta2. 
     */
   SEXP ans = PROTECT(duplicate(coerceVector(eta1p, REALSXP)));
-  eta2p = coerceVector(eta2p, REALSXP);
+  eta2p = PROTECT(coerceVector(eta2p, REALSXP));
   linkp = coerceVector(linkp, STRSXP);
   const char *linkc = CHAR(asChar(linkp));
   double *eta1 = REAL(ans), *eta2 = REAL(eta2p), 
     lambda = asReal(lambdap);
   int i, nans = LENGTH(ans);
 
   if(LENGTH(eta2p) != nans) {
-    UNPROTECT(1);
+    UNPROTECT(2);
     error("'eta1' and 'eta2' should have the same length");
   }
 
@@ -109,9 +109,9 @@ SEXP get_fitted(SEXP eta1p, SEXP eta2p, SEXP linkp, SEXP lambdap) {
     }
   } 
   else {
-    UNPROTECT(1); // unprotecting before exiting with an error
+    UNPROTECT(2); // unprotecting before exiting with an error
     error("link not recognized");
   }
-  UNPROTECT(1);
+  UNPROTECT(2);
   return ans;
 }

src/init.c

@@ -0,0 +1,74 @@
+#include <R.h>
+#include <Rinternals.h>
+#include <stdlib.h> // for NULL
+#include <R_ext/Rdynload.h>
+
+/* .C calls */
+extern void dAO_C(void *, void *, void *, void *);
+extern void dgumbel_C(void *, void *, void *, void *, void *);
+extern void dgumbel2_C(void *, void *, void *, void *, void *);
+extern void dlgamma_C(void *, void *, void *, void *);
+extern void gAO_C(void *, void *, void *);
+extern void gcauchy_C(void *, void *);
+extern void getNAGQ(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
+extern void getNGHQ_C(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
+extern void ggumbel_C(void *, void *);
+extern void ggumbel2_C(void *, void *);
+extern void glgamma_C(void *, void *, void *);
+extern void glogis_C(void *, void *);
+extern void gnorm_C(void *, void *);
+extern void grad_C(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
+extern void gradC(void *, void *, void *, void *, void *, void *, void *, void *);
+extern void grFacSum_C(void *, void *, void *, void *, void *);
+extern void hess(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
+extern void hessC(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
+extern void nll(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
+extern void NRalg(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
+extern void NRalgv3(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
+extern void pAO_C(void *, void *, void *, void *);
+extern void pgumbel_C(void *, void *, void *, void *, void *);
+extern void pgumbel2_C(void *, void *, void *, void *, void *);
+extern void plgamma_C(void *, void *, void *, void *);
+
+/* .Call calls */
+extern SEXP get_fitted(SEXP, SEXP, SEXP, SEXP);
+
+static const R_CMethodDef CEntries[] = {
+  {"dAO_C",      (DL_FUNC) &dAO_C,       4},
+  {"dgumbel_C",  (DL_FUNC) &dgumbel_C,   5},
+  {"dgumbel2_C", (DL_FUNC) &dgumbel2_C,  5},
+  {"dlgamma_C",  (DL_FUNC) &dlgamma_C,   4},
+  {"gAO_C",      (DL_FUNC) &gAO_C,       3},
+  {"gcauchy_C",  (DL_FUNC) &gcauchy_C,   2},
+  {"getNAGQ",    (DL_FUNC) &getNAGQ,    19},
+  {"getNGHQ_C",  (DL_FUNC) &getNGHQ_C,  17},
+  {"ggumbel_C",  (DL_FUNC) &ggumbel_C,   2},
+  {"ggumbel2_C", (DL_FUNC) &ggumbel2_C,  2},
+  {"glgamma_C",  (DL_FUNC) &glgamma_C,   3},
+  {"glogis_C",   (DL_FUNC) &glogis_C,    2},
+  {"gnorm_C",    (DL_FUNC) &gnorm_C,     2},
+  {"grad_C",     (DL_FUNC) &grad_C,     16},
+  {"gradC",      (DL_FUNC) &gradC,       8},
+  {"grFacSum_C", (DL_FUNC) &grFacSum_C,  5},
+  {"hess",       (DL_FUNC) &hess,       13},
+  {"hessC",      (DL_FUNC) &hessC,      11},
+  {"nll",        (DL_FUNC) &nll,        17},
+  {"NRalg",      (DL_FUNC) &NRalg,      29},
+  {"NRalgv3",    (DL_FUNC) &NRalgv3,    24},
+  {"pAO_C",      (DL_FUNC) &pAO_C,       4},
+  {"pgumbel_C",  (DL_FUNC) &pgumbel_C,   5},
+  {"pgumbel2_C", (DL_FUNC) &pgumbel2_C,  5},
+  {"plgamma_C",  (DL_FUNC) &plgamma_C,   4},
+  {NULL, NULL, 0}
+};
+
+static const R_CallMethodDef CallEntries[] = {
+  {"get_fitted", (DL_FUNC) &get_fitted, 4},
+  {NULL, NULL, 0}
+};
+
+void R_init_ordinal(DllInfo *dll)
+{
+  R_registerRoutines(dll, CEntries, CallEntries, NULL, NULL);
+  R_useDynamicSymbols(dll, FALSE);
+}