From 1eaf5d55ba08cd87187d6191fe3dbc6d406452c2 Mon Sep 17 00:00:00 2001
From: stepan <stepan.sindelar@oracle.com>
Date: Thu, 30 Nov 2017 13:30:35 +0100
Subject: [PATCH] Use more externals from GNU R for the stats package
---
.../patch/src/library/stats/src/Srunmed.c | 3 +-
.../patch/src/library/stats/src/Trunmed.c | 2 +
.../src/library/stats/src/gnur_extracts.c | 23 -
.../gnur/patch/src/library/stats/src/nls.c | 353 ++++++++++-
.../gnur/patch/src/library/stats/src/port.c | 588 +++++++++++++++++-
.../src/library/stats/src/statsR_dummy.c | 33 -
.../gnur/patch/src/library/stats/src/ts.c | 52 +-
.../foreign/CallAndExternalFunctions.java | 90 +--
documentation/dev/build-process.md | 11 +-
mx.fastr/copyrights/overrides | 24 +
10 files changed, 982 insertions(+), 197 deletions(-)
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/Srunmed.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/Srunmed.c
index 0efdfe21df..a5c66bfbf4 100644
--- a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/Srunmed.c
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/Srunmed.c
@@ -20,7 +20,8 @@
*/
#include "modreg.h"
-
+#define R_xlen_t int
+#define XLENGTH LENGTH
#include "Trunmed.c"
static void Srunmed(double* y, double* smo, R_xlen_t n, int bw,
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/Trunmed.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/Trunmed.c
index efa326b2b5..54a6fba714 100644
--- a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/Trunmed.c
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/Trunmed.c
@@ -45,6 +45,8 @@
*/
#include <math.h>
+#define R_xlen_t int
+#define XLENGTH LENGTH
static void
swap(int l, int r, double *window, int *outlist, int *nrlist, int print_level)
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/gnur_extracts.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/gnur_extracts.c
index f4e26a2dab..2b66b5e2d5 100644
--- a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/gnur_extracts.c
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/gnur_extracts.c
@@ -31,29 +31,6 @@
// extracts from some GnuR stats C files
-// from ksmooth.c
-
-void F77_SUB(bdrsplerr)(void)
-{
- error(_("only 2500 rows are allowed for sm.method=\"spline\""));
-}
-
-void F77_SUB(splineprt)(double* df, double* gcvpen, int* ismethod,
- double* lambda, double *edf)
-{
- Rprintf("spline(df=%5.3g, g.pen=%11.6g, ismeth.=%+2d) -> (lambda, edf) = (%.7g, %5.2f)\n",
- *df, *gcvpen, *ismethod, *lambda, *edf);
- return;
-}
-
-// called only from smooth(..., trace=TRUE) in ./ppr.f :
-void F77_SUB(smoothprt)(double* span, int* iper, double* var, double* cvar)
-{
- Rprintf("smooth(span=%4g, iper=%+2d) -> (var, cvar) = (%g, %g)\n",
- *span, *iper, *var, *cvar);
- return;
-}
-
// from d1mach.c
#include <Rmath.h>
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/nls.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/nls.c
index 5a84c1f0b1..ad230bd4c7 100644
--- a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/nls.c
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/nls.c
@@ -1,26 +1,357 @@
/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 1997-2007 The R Core Team.
+ * Routines used in calculating least squares solutions in a
+ * nonlinear model in nls library for R.
+ *
+ * Copyright 1999-2001 Douglas M. Bates
+ * Saikat DebRoy
+ *
+ * Copyright 2005--2016 The R Core Team
+ * Copyright 2006 The R Foundation
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
+ * This program is distributed in the hope that it will be
+ * useful, but WITHOUT ANY WARRANTY; without even the implied
+ * warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+ * PURPOSE. See the GNU General Public License for more
+ * details.
*
- * You should have received a copy of the GNU General Public License
- * along with this program; if not, a copy is available at
- * http://www.r-project.org/Licenses/
+ * You should have received a copy of the GNU General Public
+ * License along with this program; if not, a copy is available at
+ * https://www.R-project.org/Licenses/
*/
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+#include <float.h>
+#include <R.h>
#include <Rinternals.h>
#include "nls.h"
-SEXP nls_iter(SEXP m, SEXP control, SEXP doTraceArg) { return NULL; }
-SEXP numeric_deriv(SEXP expr, SEXP theta, SEXP rho, SEXP dir) { return NULL; }
+#ifndef MIN
+#define MIN(a,b) (((a)<(b))?(a):(b))
+#endif
+
+/*
+ * get the list element named str. names is the name attribute of list
+ */
+
+static SEXP
+getListElement(SEXP list, SEXP names, const char *str)
+{
+ SEXP elmt = (SEXP) NULL;
+ const char *tempChar;
+ int i;
+
+ for (i = 0; i < length(list); i++) {
+ tempChar = CHAR(STRING_ELT(names, i)); /* ASCII only */
+ if( strcmp(tempChar,str) == 0) {
+ elmt = VECTOR_ELT(list, i);
+ break;
+ }
+ }
+ return elmt;
+}
+
+/*
+ * put some convergence-related information into list
+ */
+static SEXP
+ConvInfoMsg(char* msg, int iter, int whystop, double fac,
+ double minFac, int maxIter, double convNew)
+{
+ const char *nms[] = {"isConv", "finIter", "finTol",
+ "stopCode", "stopMessage", ""};
+ SEXP ans;
+ PROTECT(ans = mkNamed(VECSXP, nms));
+
+ SET_VECTOR_ELT(ans, 0, ScalarLogical(whystop == 0)); /* isConv */
+ SET_VECTOR_ELT(ans, 1, ScalarInteger(iter)); /* finIter */
+ SET_VECTOR_ELT(ans, 2, ScalarReal (convNew)); /* finTol */
+ SET_VECTOR_ELT(ans, 3, ScalarInteger(whystop)); /* stopCode */
+ SET_VECTOR_ELT(ans, 4, mkString(msg)); /* stopMessage */
+
+ UNPROTECT(1);
+ return ans;
+}
+
+
+/*
+ * call to nls_iter from R --- .Call("nls_iter", m, control, doTrace)
+ * where m and control are nlsModel and nlsControl objects
+ * doTrace is a logical value.
+ * m is modified; the return value is a "convergence-information" list.
+ */
+SEXP
+nls_iter(SEXP m, SEXP control, SEXP doTraceArg)
+{
+ double dev, fac, minFac, tolerance, newDev, convNew = -1./*-Wall*/;
+ int i, j, maxIter, hasConverged, nPars, doTrace, evaltotCnt = -1, warnOnly, printEval;
+ SEXP tmp, conv, incr, deviance, setPars, getPars, pars, newPars, trace;
+
+ doTrace = asLogical(doTraceArg);
+
+ if(!isNewList(control))
+ error(_("'control' must be a list"));
+ if(!isNewList(m))
+ error(_("'m' must be a list"));
+
+ PROTECT(tmp = getAttrib(control, R_NamesSymbol));
+
+ conv = getListElement(control, tmp, "maxiter");
+ if(conv == NULL || !isNumeric(conv))
+ error(_("'%s' absent"), "control$maxiter");
+ maxIter = asInteger(conv);
+
+ conv = getListElement(control, tmp, "tol");
+ if(conv == NULL || !isNumeric(conv))
+ error(_("'%s' absent"), "control$tol");
+ tolerance = asReal(conv);
+
+ conv = getListElement(control, tmp, "minFactor");
+ if(conv == NULL || !isNumeric(conv))
+ error(_("'%s' absent"), "control$minFactor");
+ minFac = asReal(conv);
+
+ conv = getListElement(control, tmp, "warnOnly");
+ if(conv == NULL || !isLogical(conv))
+ error(_("'%s' absent"), "control$warnOnly");
+ warnOnly = asLogical(conv);
+
+ conv = getListElement(control, tmp, "printEval");
+ if(conv == NULL || !isLogical(conv))
+ error(_("'%s' absent"), "control$printEval");
+ printEval = asLogical(conv);
+
+#define CONV_INFO_MSG(_STR_, _I_) \
+ ConvInfoMsg(_STR_, i, _I_, fac, minFac, maxIter, convNew)
+
+#define NON_CONV_FINIS(_ID_, _MSG_) \
+ if(warnOnly) { \
+ warning(_MSG_); \
+ return CONV_INFO_MSG(_MSG_, _ID_); \
+ } \
+ else \
+ error(_MSG_);
+
+#define NON_CONV_FINIS_1(_ID_, _MSG_, _A1_) \
+ if(warnOnly) { \
+ char msgbuf[1000]; \
+ warning(_MSG_, _A1_); \
+ snprintf(msgbuf, 1000, _MSG_, _A1_); \
+ return CONV_INFO_MSG(msgbuf, _ID_); \
+ } \
+ else \
+ error(_MSG_, _A1_);
+
+#define NON_CONV_FINIS_2(_ID_, _MSG_, _A1_, _A2_) \
+ if(warnOnly) { \
+ char msgbuf[1000]; \
+ warning(_MSG_, _A1_, _A2_); \
+ snprintf(msgbuf, 1000, _MSG_, _A1_, _A2_); \
+ return CONV_INFO_MSG(msgbuf, _ID_); \
+ } \
+ else \
+ error(_MSG_, _A1_, _A2_);
+
+
+
+ /* now get parts from 'm' */
+ tmp = getAttrib(m, R_NamesSymbol);
+
+ conv = getListElement(m, tmp, "conv");
+ if(conv == NULL || !isFunction(conv))
+ error(_("'%s' absent"), "m$conv()");
+ PROTECT(conv = lang1(conv));
+
+ incr = getListElement(m, tmp, "incr");
+ if(incr == NULL || !isFunction(incr))
+ error(_("'%s' absent"), "m$incr()");
+ PROTECT(incr = lang1(incr));
+
+ deviance = getListElement(m, tmp, "deviance");
+ if(deviance == NULL || !isFunction(deviance))
+ error(_("'%s' absent"), "m$deviance()");
+ PROTECT(deviance = lang1(deviance));
+
+ trace = getListElement(m, tmp, "trace");
+ if(trace == NULL || !isFunction(trace))
+ error(_("'%s' absent"), "m$trace()");
+ PROTECT(trace = lang1(trace));
+
+ setPars = getListElement(m, tmp, "setPars");
+ if(setPars == NULL || !isFunction(setPars))
+ error(_("'%s' absent"), "m$setPars()");
+ PROTECT(setPars);
+
+ getPars = getListElement(m, tmp, "getPars");
+ if(getPars == NULL || !isFunction(getPars))
+ error(_("'%s' absent"), "m$getPars()");
+ PROTECT(getPars = lang1(getPars));
+
+ PROTECT(pars = eval(getPars, R_GlobalEnv));
+ nPars = LENGTH(pars);
+
+ dev = asReal(eval(deviance, R_GlobalEnv));
+ if(doTrace) eval(trace,R_GlobalEnv);
+
+ fac = 1.0;
+ hasConverged = FALSE;
+
+ PROTECT(newPars = allocVector(REALSXP, nPars));
+ if(printEval)
+ evaltotCnt = 1;
+ for (i = 0; i < maxIter; i++) {
+ SEXP newIncr;
+ int evalCnt = -1;
+ if((convNew = asReal(eval(conv, R_GlobalEnv))) < tolerance) {
+ hasConverged = TRUE;
+ break;
+ }
+ PROTECT(newIncr = eval(incr, R_GlobalEnv));
+
+ if(printEval)
+ evalCnt = 1;
+
+ while(fac >= minFac) {
+ if(printEval) {
+ Rprintf(" It. %3d, fac= %11.6g, eval (no.,total): (%2d,%3d):",
+ i+1, fac, evalCnt, evaltotCnt);
+ evalCnt++;
+ evaltotCnt++;
+ }
+ for(j = 0; j < nPars; j++)
+ REAL(newPars)[j] = REAL(pars)[j] + fac * REAL(newIncr)[j];
+
+ PROTECT(tmp = lang2(setPars, newPars));
+ if (asLogical(eval(tmp, R_GlobalEnv))) { /* singular gradient */
+ UNPROTECT(11);
+
+ NON_CONV_FINIS(1, _("singular gradient"));
+ }
+ UNPROTECT(1);
+
+ newDev = asReal(eval(deviance, R_GlobalEnv));
+ if(printEval)
+ Rprintf(" new dev = %g\n", newDev);
+ if(newDev <= dev) {
+ dev = newDev;
+ fac = MIN(2*fac, 1);
+ tmp = newPars;
+ newPars = pars;
+ pars = tmp;
+ break;
+ }
+ fac /= 2.;
+ }
+ UNPROTECT(1);
+ if( fac < minFac ) {
+ UNPROTECT(9);
+ NON_CONV_FINIS_2(2,
+ _("step factor %g reduced below 'minFactor' of %g"),
+ fac, minFac);
+ }
+ if(doTrace) eval(trace, R_GlobalEnv);
+ }
+
+ UNPROTECT(9);
+ if(!hasConverged) {
+ NON_CONV_FINIS_1(3,
+ _("number of iterations exceeded maximum of %d"),
+ maxIter);
+ }
+ /* else */
+
+ return CONV_INFO_MSG(_("converged"), 0);
+}
+#undef CONV_INFO_MSG
+#undef NON_CONV_FINIS
+#undef NON_CONV_FINIS_1
+#undef NON_CONV_FINIS_2
+
+
+/*
+ * call to numeric_deriv from R -
+ * .Call("numeric_deriv", expr, theta, rho)
+ * Returns: ans
+ */
+SEXP
+numeric_deriv(SEXP expr, SEXP theta, SEXP rho, SEXP dir)
+{
+ SEXP ans, gradient, pars;
+ double eps = sqrt(DOUBLE_EPS), *rDir;
+ int start, i, j, k, lengthTheta = 0;
+
+ if(!isString(theta))
+ error(_("'theta' should be of type character"));
+ if (isNull(rho)) {
+ error(_("use of NULL environment is defunct"));
+ rho = R_BaseEnv;
+ } else
+ if(!isEnvironment(rho))
+ error(_("'rho' should be an environment"));
+ PROTECT(dir = coerceVector(dir, REALSXP));
+ if(TYPEOF(dir) != REALSXP || LENGTH(dir) != LENGTH(theta))
+ error(_("'dir' is not a numeric vector of the correct length"));
+ rDir = REAL(dir);
+
+ PROTECT(pars = allocVector(VECSXP, LENGTH(theta)));
+
+ PROTECT(ans = duplicate(eval(expr, rho)));
+
+ if(!isReal(ans)) {
+ SEXP temp = coerceVector(ans, REALSXP);
+ UNPROTECT(1);
+ PROTECT(ans = temp);
+ }
+ for(i = 0; i < LENGTH(ans); i++) {
+ if (!R_FINITE(REAL(ans)[i]))
+ error(_("Missing value or an infinity produced when evaluating the model"));
+ }
+ const void *vmax = vmaxget();
+ for(i = 0; i < LENGTH(theta); i++) {
+ const char *name = translateChar(STRING_ELT(theta, i));
+ SEXP s_name = install(name);
+ SEXP temp = findVar(s_name, rho);
+ if(isInteger(temp))
+ error(_("variable '%s' is integer, not numeric"), name);
+ if(!isReal(temp))
+ error(_("variable '%s' is not numeric"), name);
+ if (MAYBE_SHARED(temp)) /* We'll be modifying the variable, so need to make sure it's unique PR#15849 */
+ defineVar(s_name, temp = duplicate(temp), rho);
+ MARK_NOT_MUTABLE(temp);
+ SET_VECTOR_ELT(pars, i, temp);
+ lengthTheta += LENGTH(VECTOR_ELT(pars, i));
+ }
+ vmaxset(vmax);
+ PROTECT(gradient = allocMatrix(REALSXP, LENGTH(ans), lengthTheta));
+ for(i = 0, start = 0; i < LENGTH(theta); i++) {
+ for(j = 0; j < LENGTH(VECTOR_ELT(pars, i)); j++, start += LENGTH(ans)) {
+ SEXP ans_del;
+ double origPar, xx, delta;
+ origPar = REAL(VECTOR_ELT(pars, i))[j];
+ xx = fabs(origPar);
+ delta = (xx == 0) ? eps : xx*eps;
+ REAL(VECTOR_ELT(pars, i))[j] += rDir[i] * delta;
+ PROTECT(ans_del = eval(expr, rho));
+ if(!isReal(ans_del)) ans_del = coerceVector(ans_del, REALSXP);
+ UNPROTECT(1);
+ for(k = 0; k < LENGTH(ans); k++) {
+ if (!R_FINITE(REAL(ans_del)[k]))
+ error(_("Missing value or an infinity produced when evaluating the model"));
+ REAL(gradient)[start + k] =
+ rDir[i] * (REAL(ans_del)[k] - REAL(ans)[k])/delta;
+ }
+ REAL(VECTOR_ELT(pars, i))[j] = origPar;
+ }
+ }
+ setAttrib(ans, install("gradient"), gradient);
+ UNPROTECT(4);
+ return ans;
+}
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/port.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/port.c
index 28ae8bb071..afdbe68184 100644
--- a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/port.c
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/port.c
@@ -1,6 +1,6 @@
/*
* R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2005 The R Core Team.
+ * Copyright (C) 2005-2015 The R Core Team.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -14,26 +14,594 @@
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, a copy is available at
- * http://www.r-project.org/Licenses/
+ * https://www.R-project.org/Licenses/
*/
#include "port.h"
-SEXP port_ivset(SEXP kind, SEXP iv, SEXP v) { return NULL; }
+#include <R_ext/Constants.h>
+#include <R_ext/BLAS.h>
+#include <R_ext/Print.h>
-SEXP port_nlminb(SEXP fn, SEXP gr, SEXP hs, SEXP rho,
- SEXP lowerb, SEXP upperb, SEXP d, SEXP iv, SEXP v) { return NULL; }
+ /* names of 1-based indices into iv and v */
+#define AFCTOL 31
+#define ALGSAV 51
+#define COVPRT 14
+#define COVREQ 15
+#define DRADPR 101
+#define DTYPE 16
+#define F 10
+#define F0 13
+#define FDIF 11
+#define G 28
+#define HC 71
+#define IERR 75
+#define INITH 25
+#define INITS 25
+#define IPIVOT 76
+#define IVNEED 3
+#define LASTIV 44
+#define LASTV 45
+#define LMAT 42
+#define MXFCAL 17
+#define MXITER 18
+#define NEXTV 47
+#define NFCALL 6
+#define NFCOV 52
+#define NFGCAL 7
+#define NGCOV 53
+#define NITER 31
+#define NVDFLT 50
+#define NVSAVE 9
+#define OUTLEV 19
+#define PARPRT 20
+#define PARSAV 49
+#define PERM 58
+#define PRUNIT 21
+#define QRTYP 80
+#define RDREQ 57
+#define RMAT 78
+#define SOLPRT 22
+#define STATPR 23
+#define TOOBIG 2
+#define VNEED 4
+#define VSAVE 60
+#define X0PRT 24
-SEXP port_nlsb(SEXP m, SEXP d, SEXP gg, SEXP iv, SEXP v,
- SEXP lowerb, SEXP upperb) { return NULL; }
-void Rf_divset(int alg, int iv[], int liv, int lv, double v[]) { }
+/* C-language replacements for Fortran utilities in PORT sources */
+
+/* dd7tpr... returns inner product of two vectors. */
+double F77_NAME(dd7tpr)(int *p, const double x[], const double y[])
+{
+ int ione = 1;
+ return F77_CALL(ddot)(p, x, &ione, y, &ione);
+}
+
+/* ditsum... prints iteration summary, initial and final alf. */
+void F77_NAME(ditsum)(const double d[], const double g[],
+ int iv[], const int *liv, const int *lv,
+ const int *n, double v[], const double x[])
+{
+ int i, nn = *n;
+ int *ivm = iv - 1; double *vm = v - 1; /* offsets for 1-based indices */
+ if (!ivm[OUTLEV]) return; /* no iteration output */
+ if (!(ivm[NITER] % ivm[OUTLEV])) { /* output every ivm[OUTLEV] iterations */
+ Rprintf("%3d:%#14.8g:", ivm[NITER], vm[F]);
+ for (i = 0; i < nn; i++) Rprintf(" %#8g", x[i]);
+ Rprintf("\n");
+ }
+}
+
+ /* port sources */
+/* dv7dfl.... provides default values to v. */
+extern void F77_NAME(dv7dfl)(const int *Alg, const int *Lv, double v[]);
+
+/**
+ * Supply default values for elements of the iv and v arrays
+ *
+ * @param alg algorithm specification (1 <= alg <= 2) (was alg <= 4, but reduced to work around gcc bug; see PR#15914)
+ * @param iv integer working vector
+ * @param liv length of iv
+ * @param lv length of v
+ * @param v double precision working vector
+ */
+void Rf_divset(int alg, int iv[], int liv, int lv, double v[])
+{
+/* *** ALG = 1 MEANS REGRESSION CONSTANTS. */
+/* *** ALG = 2 MEANS GENERAL UNCONSTRAINED OPTIMIZATION CONSTANTS. */
+
+
+ /* Initialized data */
+
+ // alg[orithm] : 1 2 3 4
+ static int miniv[] = {0, 82, 59, 103, 103};
+ static int minv [] = {0, 98, 71, 101, 85};
+
+ int mv, miv, alg1;
+
+ /* Parameter adjustments - code will use 1-based indices*/
+ --iv;
+ --v;
+
+ /* Function Body */
+
+
+ if (PRUNIT <= liv) iv[PRUNIT] = 0; /* suppress all Fortran output */
+ if (ALGSAV <= liv) iv[ALGSAV] = alg;
+ if (alg < 1 || alg > 4)
+ error(_("Rf_divset: alg = %d must be 1, 2, 3, or 4"), alg);
+
+ miv = miniv[alg];
+ if (liv < miv) {
+ iv[1] = 15;
+ return;
+ }
+ mv = minv[alg];
+ if (lv < mv) {
+ iv[1] = 16;
+ return;
+ }
+ alg1 = (alg - 1) % 2 + 1;
+ F77_CALL(dv7dfl)(&alg1, &lv, &v[1]);
+ // ------
+ iv[1] = 12;
+ if (alg > 2) error(_("port algorithms 3 or higher are not supported"));
+ iv[IVNEED] = 0;
+ iv[LASTIV] = miv;
+ iv[LASTV] = mv;
+ iv[LMAT] = mv + 1;
+ iv[MXFCAL] = 200;
+ iv[MXITER] = 150;
+ iv[OUTLEV] = 0; /* default is no iteration output */
+ iv[PARPRT] = 1;
+ iv[PERM] = miv + 1;
+ iv[SOLPRT] = 0; /* was 1 but we suppress Fortran output */
+ iv[STATPR] = 0; /* was 1 but we suppress Fortran output */
+ iv[VNEED] = 0;
+ iv[X0PRT] = 1;
+
+ if (alg1 >= 2) { /* GENERAL OPTIMIZATION values: nlminb() */
+ iv[DTYPE] = 0;
+ iv[INITS] = 1;
+ iv[NFCOV] = 0;
+ iv[NGCOV] = 0;
+ iv[NVDFLT] = 25;
+ iv[PARSAV] = (alg > 2) ? 61 : 47;
+
+ v[AFCTOL] = 0.0; /* since R 2.12.0: Skip |f(x)| test */
+ }
+ else { /* REGRESSION values: nls() */
+ iv[COVPRT] = 3;
+ iv[COVREQ] = 1;
+ iv[DTYPE] = 1;
+ iv[HC] = 0;
+ iv[IERR] = 0;
+ iv[INITH] = 0;
+ iv[IPIVOT] = 0;
+ iv[NVDFLT] = 32;
+ iv[VSAVE] = (alg > 2) ? 61 : 58;
+ iv[PARSAV] = iv[60] + 9;
+ iv[QRTYP] = 1;
+ iv[RDREQ] = 3;
+ iv[RMAT] = 0;
+ }
+ return;
+}
+
+
+/* divset.... supply default values for elements of the iv and v arrays */
+void F77_NAME(divset)(const int *Alg, int iv[], const int *Liv,
+ const int *Lv, double v[])
+{
+ Rf_divset(*Alg, iv, *Liv, *Lv, v);
+}
+
+/* dn2cvp... prints covariance matrix. */
+void F77_NAME(dn2cvp)(const int iv[], int *liv, int *lv, int *p,
+ const double v[])
+{
+ /* Done elsewhere */
+}
+
+/* dn2rdp... prints regression diagnostics for mlpsl and nl2s1. */
+void F77_NAME(dn2rdp)(const int iv[], int *liv, int *lv, int *n,
+ const double rd[], const double v[])
+{
+ /* Done elsewhere */
+}
+
+/* ds7cpr... prints linear parameters at solution. */
+void F77_NAME(ds7cpr)(const double c[], const int iv[], int *l, int *liv)
+{
+ /* Done elsewhere */
+}
+
+/* dv2axy... computes scalar times one vector plus another */
+void F77_NAME(dv2axy)(int *n, double w[], const double *a,
+ const double x[], const double y[])
+{
+ int i, nn = *n; double aa = *a;
+ for (i = 0; i < nn; i++) w[i] = aa * x[i] + y[i];
+}
+
+/* dv2nrm... returns the 2-norm of a vector. */
+double F77_NAME(dv2nrm)(int *n, const double x[])
+{
+ int ione = 1;
+ return F77_CALL(dnrm2)(n, x, &ione);
+}
+
+/* dv7cpy.... copy src to dest */
+void F77_NAME(dv7cpy)(int *n, double dest[], const double src[])
+{
+ /* Was memcpy, but overlaps seen */
+ memmove(dest, src, *n * sizeof(double));
+}
+
+/* dv7ipr... applies forward permutation to vector. */
+void F77_NAME(dv7ipr)(int *n, const int ip[], double x[])
+{
+ /* permute x so that x[i] := x[ip[i]]. */
+ int i, nn = *n;
+ double *xcp = Calloc(nn, double);
+
+ for (i = 0; i < nn; i++) xcp[i] = x[ip[i] - 1]; /* ip contains 1-based indices */
+ Memcpy(x, xcp, nn);
+ Free(xcp);
+}
+
+/* dv7prm... applies reverse permutation to vector. */
+void F77_NAME(dv7prm)(int *n, const int ip[], double x[])
+{
+ /* permute x so that x[ip[i]] := x[i]. */
+ int i, nn = *n;
+ double *xcp = Calloc(nn, double);
+
+ for (i = 0; i < nn; i++) xcp[ip[i] - 1] = x[i]; /* ip contains 1-based indices */
+ Memcpy(x, xcp, nn);
+ Free(xcp);
+}
+
+/* dv7scl... scale src by *scal to dest */
+void F77_NAME(dv7scl)(int *n, double dest[],
+ const double *scal, const double src[])
+{
+ int nn = *n; double sc = *scal;
+ while (nn-- > 0) *dest++ = sc * *src++;
+}
+
+/* dv7scp... set values of an array to a constant */
+void F77_NAME(dv7scp)(int *n, double dest[], double *c)
+{
+ int nn = *n; double cc = *c;
+ while (nn-- > 0) *dest++ = cc;
+}
+
+/* dv7swp... interchange n-vectors x and y. */
+void F77_NAME(dv7swp)(int *n, double x[], double y[])
+{
+ int ione = 1;
+ F77_CALL(dswap)(n, x, &ione, y, &ione);
+}
+
+/* i7copy... copies one integer vector to another. */
+void F77_NAME(i7copy)(int *n, int dest[], const int src[])
+{
+ int nn = *n;
+ while (nn-- > 0) *dest++ = *src++;
+}
+
+/* i7pnvr... inverts permutation array. (Indices in array are 1-based) */
+void F77_NAME(i7pnvr)(int *n, int x[], const int y[])
+{
+ int i, nn = *n;
+ for (i = 0; i < nn; i++) x[y[i] - 1] = i + 1;
+}
+
+/* stopx.... returns .true. if the break key has been pressed. */
+int F77_NAME(stopx)(void)
+{
+ return 0; /* interrupts are caught elsewhere */
+}
+
+static
+double* check_gv(SEXP gr, SEXP hs, SEXP rho, int n, double *gv, double *hv)
+{
+ SEXP gval = PROTECT(coerceVector(PROTECT(eval(gr, rho)), REALSXP));
+ if (LENGTH(gval) != n)
+ error(_("gradient function must return a numeric vector of length %d"), n);
+ Memcpy(gv, REAL(gval), n);
+ for (int i = 0; i < n; i++)
+ if(ISNAN(gv[i])) error("NA/NaN gradient evaluation");
+ if (hv) {
+ SEXP hval = PROTECT(eval(hs, rho));
+ SEXP dim = getAttrib(hval, R_DimSymbol);
+ int i, j, pos;
+ double *rhval = REAL(hval);
+
+ if (!isReal(hval) || LENGTH(dim) != 2 ||
+ INTEGER(dim)[0] != n || INTEGER(dim)[1] != n)
+ error(_("Hessian function must return a square numeric matrix of order %d"),
+ n);
+ for (i = 0, pos = 0; i < n; i++) /* copy lower triangle row-wise */
+ for (j = 0; j <= i; j++) {
+ hv[pos] = rhval[i + j * n];
+ if(ISNAN(hv[pos])) error("NA/NaN Hessian evaluation");
+ pos++;
+ }
+ UNPROTECT(1);
+ }
+ UNPROTECT(2);
+ return gv;
+}
void
nlminb_iterate(double b[], double d[], double fx, double g[], double h[],
- int iv[], int liv, int lv, int n, double v[], double x[]) { }
+ int iv[], int liv, int lv, int n, double v[], double x[])
+{
+ int lh = (n * (n + 1))/2;
+ if (b) {
+ if (g) {
+ if (h)
+ F77_CALL(drmnhb)(b, d, &fx, g, h, iv, &lh, &liv, &lv, &n, v, x);
+ else
+ F77_CALL(drmngb)(b, d, &fx, g, iv, &liv, &lv, &n, v, x);
+ } else F77_CALL(drmnfb)(b, d, &fx, iv, &liv, &lv, &n, v, x);
+ } else {
+ if (g) {
+ if (h)
+ F77_CALL(drmnh)(d, &fx, g, h, iv, &lh, &liv, &lv, &n, v, x);
+ else
+ F77_CALL(drmng)(d, &fx, g, iv, &liv, &lv, &n, v, x);
+ } else F77_CALL(drmnf)(d, &fx, iv, &liv, &lv, &n, v, x);
+ }
+}
+
+SEXP port_ivset(SEXP kind, SEXP iv, SEXP v)
+{
+ Rf_divset(asInteger(kind), INTEGER(iv), LENGTH(iv), LENGTH(v), REAL(v));
+ return R_NilValue;
+}
+
+SEXP port_nlminb(SEXP fn, SEXP gr, SEXP hs, SEXP rho,
+ SEXP lowerb, SEXP upperb, SEXP d, SEXP iv, SEXP v)
+{
+ int i, n = LENGTH(d);
+ SEXP xpt;
+ SEXP dot_par_symbol = install(".par");
+ double *b = (double *) NULL, *g = (double *) NULL,
+ *h = (double *) NULL, fx = R_PosInf;
+ if (isNull(rho)) {
+ error(_("use of NULL environment is defunct"));
+ rho = R_BaseEnv;
+ } else
+ if (!isEnvironment(rho))
+ error(_("'rho' must be an environment"));
+ if (!isReal(d) || n < 1)
+ error(_("'d' must be a nonempty numeric vector"));
+ if (hs != R_NilValue && gr == R_NilValue)
+ error(_("When Hessian defined must also have gradient defined"));
+ if (R_NilValue == (xpt = findVarInFrame(rho, dot_par_symbol)) ||
+ !isReal(xpt) || LENGTH(xpt) != n)
+ error(_("environment 'rho' must contain a numeric vector '.par' of length %d"),
+ n);
+ /* We are going to alter .par, so must duplicate it */
+ defineVar(dot_par_symbol, duplicate(xpt), rho);
+ PROTECT(xpt = findVarInFrame(rho, dot_par_symbol));
+
+ if ((LENGTH(lowerb) == n) && (LENGTH(upperb) == n)) {
+ if (isReal(lowerb) && isReal(upperb)) {
+ double *rl=REAL(lowerb), *ru=REAL(upperb);
+ b = (double *)R_alloc(2*n, sizeof(double));
+ for (i = 0; i < n; i++) {
+ b[2*i] = rl[i];
+ b[2*i + 1] = ru[i];
+ }
+ } else error(_("'lower' and 'upper' must be numeric vectors"));
+ }
+ if (gr != R_NilValue) {
+ g = (double *)R_alloc(n, sizeof(double));
+ if (hs != R_NilValue)
+ h = (double *)R_alloc((n * (n + 1))/2, sizeof(double));
+ }
+
+ do {
+ nlminb_iterate(b, REAL(d), fx, g, h, INTEGER(iv), LENGTH(iv),
+ LENGTH(v), n, REAL(v), REAL(xpt));
+ if (INTEGER(iv)[0] == 2 && g) check_gv(gr, hs, rho, n, g, h);
+ else {
+ fx = asReal(eval(fn, rho));
+ if (ISNAN(fx)) {
+ warning("NA/NaN function evaluation");
+ fx = R_PosInf;
+ }
+ }
+
+ /* duplicate .par value again in case a callback has stored
+ value (package varComp does this) */
+ defineVar(dot_par_symbol, duplicate(xpt), rho);
+ xpt = findVarInFrame(rho, dot_par_symbol);
+ UNPROTECT(1);
+ PROTECT(xpt);
+ } while(INTEGER(iv)[0] < 3);
+
+ UNPROTECT(1); /* xpt */
+ return R_NilValue;
+}
void
nlsb_iterate(double b[], double d[], double dr[], int iv[], int liv,
int lv, int n, int nd, int p, double r[], double rd[],
- double v[], double x[]) { }
+ double v[], double x[])
+{
+ int ione = 1;
+ if (b)
+ F77_CALL(drn2gb)(b, d, dr, iv, &liv, &lv, &n, &nd,
+ &ione, &nd, &p, r, rd, v, x);
+ else
+ F77_CALL(drn2g)(d, dr, iv, &liv, &lv, &n, &nd, &ione,
+ &nd, &p, r, rd, v, x);
+}
+
+/**
+ * Return the element of a given name from a named list
+ *
+ * @param list
+ * @param nm name of desired element
+ *
+ * @return element of list with name nm
+ */
+static R_INLINE SEXP getElement(SEXP list, char *nm)
+{
+ int i; SEXP names = getAttrib(list, R_NamesSymbol);
+
+ if (!isNewList(list) || LENGTH(names) != LENGTH(list))
+ error(_("'getElement' applies only to named lists"));
+ for (i = 0; i < LENGTH(list); i++)
+ if (!strcmp(CHAR(STRING_ELT(names, i)), nm)) /* ASCII only */
+ return(VECTOR_ELT(list, i));
+ return R_NilValue;
+}
+
+/**
+ * Return the element of a given name from a named list after ensuring
+ * that it is a function
+ *
+ * @param list
+ * @param enm name of desired element
+ * @param lnm string version of the name of the list
+ *
+ * @return a SEXP that points to a function
+ */
+static R_INLINE SEXP getFunc(SEXP list, char *enm, char *lnm)
+{
+ SEXP ans;
+ if (!isFunction(ans = getElement(list, enm)))
+ error(_("%s$%s() not found"), lnm, enm);
+ return ans;
+}
+
+static void neggrad(SEXP gf, SEXP rho, SEXP gg)
+{
+ SEXP val = PROTECT(eval(gf, rho));
+ int *dims = INTEGER(getAttrib(val, R_DimSymbol)),
+ *gdims = INTEGER(getAttrib(gg, R_DimSymbol));
+ int i, ntot = gdims[0] * gdims[1];
+
+ if (TYPEOF(val) != TYPEOF(gg) || !isMatrix(val) || dims[0] != gdims[0] ||
+ dims[1] != gdims[1])
+ error(_("'gradient' must be a numeric matrix of dimension (%d,%d)"),
+ gdims[0], gdims[1]);
+ for (i = 0; i < ntot; i++) REAL(gg)[i] = - REAL(val)[i];
+ UNPROTECT(1);
+}
+
+/**
+ * Evaluate an expression in an environment, check that the length and
+ * mode are as expected and store the result.
+ *
+ * @param fcn expression to evaluate
+ * @param rho environment in which to evaluate it
+ * @param vv position to store the result
+ *
+ * @return vv with new contents
+ */
+static
+SEXP eval_check_store(SEXP fcn, SEXP rho, SEXP vv)
+{
+ SEXP v = PROTECT(eval(fcn, rho));
+ if (TYPEOF(v) != TYPEOF(vv) || LENGTH(v) != LENGTH(vv))
+ error(_("fcn produced mode %d, length %d - wanted mode %d, length %d"),
+ TYPEOF(v), LENGTH(v), TYPEOF(vv), LENGTH(vv));
+ switch (TYPEOF(v)) {
+ case LGLSXP:
+ Memcpy(LOGICAL(vv), LOGICAL(v), LENGTH(vv));
+ break;
+ case INTSXP:
+ Memcpy(INTEGER(vv), INTEGER(v), LENGTH(vv));
+ break;
+ case REALSXP:
+ Memcpy(REAL(vv), REAL(v), LENGTH(vv));
+ break;
+ default:
+ error(_("invalid type for eval_check_store"));
+ }
+ UNPROTECT(1);
+ return vv;
+}
+
+SEXP port_nlsb(SEXP m, SEXP d, SEXP gg, SEXP iv, SEXP v,
+ SEXP lowerb, SEXP upperb)
+{
+ int *dims = INTEGER(getAttrib(gg, R_DimSymbol));
+ int i, n = LENGTH(d), p = LENGTH(d), nd = dims[0];
+ SEXP getPars, setPars, resid, gradient,
+ rr = PROTECT(allocVector(REALSXP, nd)),
+ x = PROTECT(allocVector(REALSXP, n));
+ // This used to use Calloc, but that will leak if
+ // there is a premature return (and did in package drfit)
+ double *b = (double *) NULL,
+ *rd = (double *)R_alloc(nd, sizeof(double));
+
+ if (!isReal(d) || n < 1)
+ error(_("'d' must be a nonempty numeric vector"));
+ if(!isNewList(m)) error(_("m must be a list"));
+ /* Initialize parameter vector */
+ getPars = PROTECT(lang1(getFunc(m, "getPars", "m")));
+ eval_check_store(getPars, R_GlobalEnv, x);
+ /* Create the setPars call */
+ setPars = PROTECT(lang2(getFunc(m, "setPars", "m"), x));
+ /* Evaluate residual and gradient */
+ resid = PROTECT(lang1(getFunc(m, "resid", "m")));
+ eval_check_store(resid, R_GlobalEnv, rr);
+ gradient = PROTECT(lang1(getFunc(m, "gradient", "m")));
+ neggrad(gradient, R_GlobalEnv, gg);
+
+ if ((LENGTH(lowerb) == n) && (LENGTH(upperb) == n)) {
+ if (isReal(lowerb) && isReal(upperb)) {
+ double *rl = REAL(lowerb), *ru = REAL(upperb);
+ b = (double *)R_alloc(2*n, sizeof(double));
+ for (i = 0; i < n; i++) {
+ b[2*i] = rl[i];
+ b[2*i + 1] = ru[i];
+ }
+ } else error(_("'lowerb' and 'upperb' must be numeric vectors"));
+ }
+
+ do {
+ nlsb_iterate(b, REAL(d), REAL(gg), INTEGER(iv), LENGTH(iv),
+ LENGTH(v), n, nd, p, REAL(rr), rd,
+ REAL(v), REAL(x));
+ switch(INTEGER(iv)[0]) {
+ case -3:
+ eval(setPars, R_GlobalEnv);
+ eval_check_store(resid, R_GlobalEnv, rr);
+ neggrad(gradient, R_GlobalEnv, gg);
+ break;
+ case -2:
+ eval_check_store(resid, R_GlobalEnv, rr);
+ neggrad(gradient, R_GlobalEnv, gg);
+ break;
+ case -1:
+ eval(setPars, R_GlobalEnv);
+ eval_check_store(resid, R_GlobalEnv, rr);
+ neggrad(gradient, R_GlobalEnv, gg);
+ break;
+ case 0:
+ Rprintf("nlsb_iterate returned %d", INTEGER(iv)[0]);
+ break;
+ case 1:
+ eval(setPars, R_GlobalEnv);
+ eval_check_store(resid, R_GlobalEnv, rr);
+ break;
+ case 2:
+ eval(setPars, R_GlobalEnv);
+ neggrad(gradient, R_GlobalEnv, gg);
+ break;
+ }
+ } while(INTEGER(iv)[0] < 3);
+
+ UNPROTECT(6);
+ return R_NilValue;
+}
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/statsR_dummy.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/statsR_dummy.c
index 74ecccd2bf..d7d8f45b63 100644
--- a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/statsR_dummy.c
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/statsR_dummy.c
@@ -27,13 +27,8 @@ SEXP getListElement(SEXP list, char *str) UNIMPLEMENTED
/* Declarations for .Call entry points */
-SEXP logit_link(SEXP mu) UNIMPLEMENTED
-SEXP logit_linkinv(SEXP eta) UNIMPLEMENTED
-SEXP logit_mu_eta(SEXP eta) UNIMPLEMENTED
-SEXP binomial_dev_resids(SEXP y, SEXP mu, SEXP wt) UNIMPLEMENTED
SEXP cutree(SEXP merge, SEXP which) UNIMPLEMENTED
-SEXP rWishart(SEXP ns, SEXP nuP, SEXP scal) UNIMPLEMENTED
SEXP Cdqrls(SEXP x, SEXP y, SEXP tol, SEXP chk) UNIMPLEMENTED
SEXP Cdist(SEXP x, SEXP method, SEXP attrs, SEXP p) UNIMPLEMENTED
SEXP r2dtable(SEXP n, SEXP r, SEXP c) UNIMPLEMENTED
@@ -44,9 +39,6 @@ SEXP fft(SEXP z, SEXP inverse) UNIMPLEMENTED
SEXP mvfft(SEXP z, SEXP inverse) UNIMPLEMENTED
SEXP nextn(SEXP n, SEXP factors) UNIMPLEMENTED
-SEXP cfilter(SEXP sx, SEXP sfilter, SEXP ssides, SEXP scircular) UNIMPLEMENTED
-SEXP rfilter(SEXP x, SEXP filter, SEXP out) UNIMPLEMENTED
-SEXP lowess(SEXP x, SEXP y, SEXP sf, SEXP siter, SEXP sdelta) UNIMPLEMENTED
SEXP DoubleCentre(SEXP A) UNIMPLEMENTED
SEXP BinDist(SEXP x, SEXP weights, SEXP slo, SEXP sup, SEXP sn) UNIMPLEMENTED
@@ -169,16 +161,9 @@ SEXP optimhess(SEXP call, SEXP op, SEXP args, SEXP rho) UNIMPLEMENTED
SEXP call_dqagi(SEXP x) UNIMPLEMENTED
SEXP call_dqags(SEXP x) UNIMPLEMENTED
-SEXP Rsm(SEXP x, SEXP stype, SEXP send) UNIMPLEMENTED
-SEXP tukeyline(SEXP x, SEXP y, SEXP call) UNIMPLEMENTED
-SEXP runmed(SEXP x, SEXP stype, SEXP sk, SEXP end, SEXP print_level) UNIMPLEMENTED
SEXP influence(SEXP mqr, SEXP do_coef, SEXP e, SEXP stol) UNIMPLEMENTED
-SEXP pSmirnov2x(SEXP statistic, SEXP snx, SEXP sny) UNIMPLEMENTED
-SEXP pKolmogorov2x(SEXP statistic, SEXP sn) UNIMPLEMENTED
-SEXP pKS2(SEXP sn, SEXP stol) UNIMPLEMENTED
-SEXP ksmooth(SEXP x, SEXP y, SEXP snp, SEXP skrn, SEXP sbw) UNIMPLEMENTED
SEXP SplineCoef(SEXP method, SEXP x, SEXP y) UNIMPLEMENTED
SEXP SplineEval(SEXP xout, SEXP z) UNIMPLEMENTED
@@ -187,26 +172,8 @@ SEXP ApproxTest(SEXP x, SEXP y, SEXP method, SEXP sf) UNIMPLEMENTED
SEXP Approx(SEXP x, SEXP y, SEXP v, SEXP method,
SEXP yleft, SEXP yright, SEXP sf) UNIMPLEMENTED
-SEXP LogLin(SEXP dtab, SEXP conf, SEXP table, SEXP start,
- SEXP snmar, SEXP eps, SEXP iter) UNIMPLEMENTED
-
-SEXP pAnsari(SEXP q, SEXP sm, SEXP sn) UNIMPLEMENTED
-SEXP qAnsari(SEXP p, SEXP sm, SEXP sn) UNIMPLEMENTED
-SEXP pKendall(SEXP q, SEXP sn) UNIMPLEMENTED
-SEXP pRho(SEXP q, SEXP sn, SEXP lower) UNIMPLEMENTED
-SEXP SWilk(SEXP x) UNIMPLEMENTED
-
-SEXP bw_den(SEXP nbin, SEXP sx) UNIMPLEMENTED
-SEXP bw_den_binned(SEXP sx) UNIMPLEMENTED
-SEXP bw_ucv(SEXP sn, SEXP sd, SEXP cnt, SEXP sh) UNIMPLEMENTED
-SEXP bw_bcv(SEXP sn, SEXP sd, SEXP cnt, SEXP sh) UNIMPLEMENTED
-SEXP bw_phi4(SEXP sn, SEXP sd, SEXP cnt, SEXP sh) UNIMPLEMENTED
-SEXP bw_phi6(SEXP sn, SEXP sd, SEXP cnt, SEXP sh) UNIMPLEMENTED
-
-SEXP Fexact(SEXP x, SEXP pars, SEXP work, SEXP smult) UNIMPLEMENTED
SEXP Fisher_sim(SEXP sr, SEXP sc, SEXP sB) UNIMPLEMENTED
SEXP chisq_sim(SEXP sr, SEXP sc, SEXP sB, SEXP E) UNIMPLEMENTED
-SEXP d2x2xk(SEXP sK, SEXP sm, SEXP sn, SEXP st, SEXP srn) UNIMPLEMENTED
SEXP stats_signrank_free(void) UNIMPLEMENTED
SEXP stats_wilcox_free(void) UNIMPLEMENTED
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/ts.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/ts.c
index bdffee7d65..ea2ea340fe 100644
--- a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/ts.c
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/ts.c
@@ -19,58 +19,8 @@
#include "ts.h"
-void multi_burg(int *pn, double *x, int *pomax, int *pnser, double *coef,
- double *pacf, double *var, double *aic, int *porder,
- int *useaic, int *vmethod) { }
-void multi_yw(double *acf, int *pn, int *pomax, int *pnser, double *coef,
- double *pacf, double *var, double *aic, int *porder,
- int *puseaic) { }
-void HoltWinters (double *x, int *xl, double *alpha, double *beta,
- double *gamma, int *start_time, int *seasonal, int *period,
- int *dotrend, int *doseasonal,
- double *a, double *b, double *s, double *SSE, double *level,
- double *trend, double *season) { }
+// functions from ts.c implemented in Java, here are dummy implementations to make the linker happy.
-void starma(Starma G, int *ifault) { }
-
-void karma(Starma G, double *sumlog, double *ssq, int iupd, int *nit) { }
-
-void forkal(Starma G, int id, int il, double *delta, double *y,
- double *amse, int *ifault) { }
-
-SEXP setup_starma(SEXP na, SEXP x, SEXP pn, SEXP xreg, SEXP pm,
- SEXP dt, SEXP ptrans, SEXP sncond) { return NULL; }
-SEXP free_starma(SEXP pG) { return NULL; }
-SEXP set_trans(SEXP pG, SEXP ptrans) { return NULL; }
-SEXP arma0fa(SEXP pG, SEXP inparams) { return NULL; }
-SEXP get_s2(SEXP pG) { return NULL; }
-SEXP get_resid(SEXP pG) { return NULL; }
-SEXP Dotrans(SEXP pG, SEXP x) { return NULL; }
-SEXP arma0_kfore(SEXP pG, SEXP pd, SEXP psd, SEXP n_ahead) { return NULL; }
-SEXP Starma_method(SEXP pG, SEXP method) { return NULL; }
-SEXP Gradtrans(SEXP pG, SEXP x) { return NULL; }
-SEXP Invtrans(SEXP pG, SEXP x) { return NULL; }
-
-SEXP ARMAtoMA(SEXP ar, SEXP ma, SEXP lag_max) { return NULL; }
-
-SEXP KalmanLike(SEXP sy, SEXP mod, SEXP sUP, SEXP op, SEXP fast) { return NULL; }
-SEXP KalmanFore(SEXP nahead, SEXP mod, SEXP fast) { return NULL; }
-SEXP KalmanSmooth(SEXP sy, SEXP mod, SEXP sUP) { return NULL; }
-SEXP ARIMA_undoPars(SEXP sin, SEXP sarma) { return NULL; }
-SEXP ARIMA_transPars(SEXP sin, SEXP sarma, SEXP strans) { return NULL; }
-SEXP ARIMA_Invtrans(SEXP in, SEXP sarma) { return NULL; }
-SEXP ARIMA_Gradtrans(SEXP in, SEXP sarma) { return NULL; }
-SEXP ARIMA_Like(SEXP sy, SEXP mod, SEXP sUP, SEXP giveResid) { return NULL; }
-SEXP ARIMA_CSS(SEXP sy, SEXP sarma, SEXP sPhi, SEXP sTheta, SEXP sncond,
- SEXP giveResid) { return NULL; }
-SEXP TSconv(SEXP a, SEXP b) { return NULL; }
-SEXP getQ0(SEXP sPhi, SEXP sTheta) { return NULL; }
-SEXP getQ0bis(SEXP sPhi, SEXP sTheta, SEXP sTol) { return NULL; }
-
-SEXP acf(SEXP x, SEXP lmax, SEXP sCor) { return NULL; }
-SEXP pacf1(SEXP acf, SEXP lmax) { return NULL; }
-SEXP ar2ma(SEXP ar, SEXP npsi) { return NULL; }
-SEXP Burg(SEXP x, SEXP order) { return NULL; }
SEXP pp_sum(SEXP u, SEXP sl) { return NULL; }
SEXP intgrt_vec(SEXP x, SEXP xi, SEXP slag) { return NULL; }
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/foreign/CallAndExternalFunctions.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/foreign/CallAndExternalFunctions.java
index 20e64dfe9f..f88668a6f8 100644
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/foreign/CallAndExternalFunctions.java
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/foreign/CallAndExternalFunctions.java
@@ -524,75 +524,35 @@ public class CallAndExternalFunctions {
return BinDist.create();
case "influence":
return Influence.create();
- case "isoreg":
- case "monoFC_m":
- case "numeric_deriv":
- case "nls_iter":
- case "setup_starma":
- case "free_starma":
- case "set_trans":
- case "arma0fa":
- case "get_s2":
- case "get_resid":
- case "Dotrans":
- case "arma0_kfore":
- case "Starma_method":
- case "Invtrans":
- case "Gradtrans":
- case "ARMAtoMA":
- case "KalmanLike":
- case "KalmanFore":
- case "KalmanSmooth":
- case "ARIMA_undoPars":
- case "ARIMA_transPars":
- case "ARIMA_Invtrans":
- case "ARIMA_Gradtrans":
- case "ARIMA_Like":
- case "ARIMA_CSS":
- case "TSconv":
- case "getQ0":
- case "getQ0bis":
- case "port_ivset":
- case "port_nlminb":
- case "port_nlsb":
- case "logit_link":
- case "logit_linkinv":
- case "logit_mu_eta":
- case "binomial_dev_resids":
- case "rWishart":
case "mvfft":
+ // TODO: only transforms arguments and then calls already ported fft
+ return new UnimplementedExternal(name);
case "nextn":
+ // TODO: do not want to pull in fourier.c, should be simple to port
+ return new UnimplementedExternal(name);
case "r2dtable":
- case "cfilter":
- case "rfilter":
- case "lowess":
- case "Rsm":
- case "tukeyline":
- case "runmed":
- case "pSmirnov2x":
- case "pKolmogorov2x":
- case "pKS2":
- case "ksmooth":
- case "LogLin":
- case "pAnsari":
- case "qAnsari":
- case "pKendall":
- case "pRho":
- case "SWilk":
- case "bw_den":
- case "bw_ucv":
- case "bw_bcv":
- case "bw_phi4":
- case "bw_phi6":
- case "acf":
- case "pacf1":
- case "ar2ma":
- case "Burg":
- case "pp_sum":
- case "Fexact":
+ // TODO: do not want to pull in random.c + uses PutRNG(), we can pull in rcont.c
+ // and then this
+ // becomes simple wrapper around it.
+ return new UnimplementedExternal(name);
case "Fisher_sim":
case "chisq_sim":
- case "d2x2xk":
+ // TODO: uses PutRNG(), with rcont.c may become moderately difficult to port
+ return new UnimplementedExternal(name);
+ case "Rsm":
+ return new UnimplementedExternal(name);
+ case "optim":
+ case "optimhess":
+ case "zeroin2":
+ case "dqagi":
+ case "dqags":
+ case "nlm":
+ // TODO: file optim.c uses Defn.h with non public RFFI API
+ // It seems that Defn.h can be replaced with Rinternals.h
+ // From GNUR R core it pulls few aux macros like F77_CALL, we can pull those
+ // individually
+ // Furthermore it requires to pull lbfgsb.c and linkpack (Appl/Linpack.h)
+ // routines from core
return new UnimplementedExternal(name);
case "intgrt_vec":
@@ -656,6 +616,8 @@ public class CallAndExternalFunctions {
default:
return null;
}
+ // Note: some externals that may be ported with reasonable effort
+ // tukeyline, rfilter, SWilk, acf, Burg, d2x2xk, pRho
}
/**
diff --git a/documentation/dev/build-process.md b/documentation/dev/build-process.md
index 4efe86888f..c4eaf40416 100644
--- a/documentation/dev/build-process.md
+++ b/documentation/dev/build-process.md
@@ -41,11 +41,14 @@ See also [building](building.md), [release](../../com.oracle.truffle.r.release/R
In contrast to the previous build architecture, which extracted the necessary original
sources needed by FastR from the GNUR distribution during the build, the current build
architecture maintains the required original sources as part of the project in the `com.oracle.truffle.r.native/gnur/patch`
- directory. The `patch` directory contains both the original and FastR specific native sources.
+ directory. The `patch` directory contains both the original and FastR specific native sources
+ that are necessary to build the GNU R parts required by FastR, especially the libraries.
Some of the original sources are patched, but the original ones are still available via the GIT history.
- Note: All the original (non-patched) files were added to GIT in a single commit (`a2d8b606a8f7a61c65ec96545644f28dd4af7a71`).
- Their modifications are made in subsequent commits.
+ Note: All the original (non-patched) GNU R files were added to GIT in branch named `gnur`. When pulling
+ additional files from GNU R sources or upgrading GNU R version, one should work on this branch only and
+ then merge the result back to the master branch. Any patches to those sources should be done on as usual
+ (i.e. based off current master branch and merged back to master branch).
Thera are many original GNUR files that are just taken without any modification from GNUR
and copied to their respective location in the FastR directory layout (See the section *Building `run`* for details).
@@ -88,7 +91,7 @@ See also [building](building.md), [release](../../com.oracle.truffle.r.release/R
2. the solaris studio compilers must be used, assumed to be on the `PATH`
3. Solaris runs on x64 and Sparc and the configure options are different
* makes `com.oracle.truffle.r.native/gnur/patch-build/src/include` creating `com.oracle.truffle.r.native/gnur/patch-build/include`.
- Some headers are already patched to conform the FastR needs (in the previous system, the patching was done by `mx.fastr/mx_fastr_edinclude.py`).
+ TBD: Some headers are already patched to conform the FastR needs (in the previous system, the patching was done by `mx.fastr/mx_fastr_edinclude.py`).
The header files in the resulting `include` directory are later linked from `com.oracle.truffle.r.native/include`. See *Building `include`*.
_Patched files_:
diff --git a/mx.fastr/copyrights/overrides b/mx.fastr/copyrights/overrides
index 5b02a6c593..6ebcb40641 100644
--- a/mx.fastr/copyrights/overrides
+++ b/mx.fastr/copyrights/overrides
@@ -898,6 +898,30 @@ com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/sbart.c,no.copyrigh
com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/stats.h,no.copyright
com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/statsR.h,no.copyright
com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/ts.h,no.copyright
+com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/loglin.c,no.copyright
+com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/HoltWinters.c,no.copyright
+com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/Srunmed.c,no.copyright
+com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/Trunmed.c,no.copyright
+com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/ansari.c,no.copyright
+com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/arima.c,no.copyright
+com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/bandwidths.c,no.copyright
+com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/burg.c,no.copyright
+com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/d2x2xk.c,no.copyright
+com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/family.c,no.copyright
+com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/fexact.c,no.copyright
+com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/filter.c,no.copyright
+com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/kendall.c,no.copyright
+com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/ks.c,no.copyright
+com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/ksmooth.c,no.copyright
+com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/line.c,no.copyright
+com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/lowess.c,no.copyright
+com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/mAR.c,no.copyright
+com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/pacf.c,no.copyright
+com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/prho.c,no.copyright
+com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/rWishart.c,no.copyright
+com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/smooth.c,no.copyright
+com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/starma.c,no.copyright
+com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/swilk.c,no.copyright
com.oracle.truffle.r.native/gnur/patch/src/library/tools/src/gramRd.c,no.copyright
com.oracle.truffle.r.native/gnur/patch/src/library/tools/src/init.c,no.copyright
com.oracle.truffle.r.native/gnur/patch/src/library/tools/src/tools.h,no.copyright
--
GitLab