Skip to content
Snippets Groups Projects
Commit 1eaf5d55 authored by stepan's avatar stepan
Browse files

Use more externals from GNU R for the stats package

parent bab748aa
No related branches found
No related tags found
No related merge requests found
Hide whitespace changes
Inline Side-by-side
Showing
with 982 additions and 197 deletions
com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/Srunmed.c
+ 2
− 1
View file @ 1eaf5d55
...@@ -20,7 +20,8 @@ ...@@ -20,7 +20,8 @@
*/ */
#include "modreg.h" #include "modreg.h"
#define R_xlen_t int
#define XLENGTH LENGTH
#include "Trunmed.c" #include "Trunmed.c"
static void Srunmed(double* y, double* smo, R_xlen_t n, int bw, static void Srunmed(double* y, double* smo, R_xlen_t n, int bw,
......
com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/Trunmed.c
+ 2
− 0
View file @ 1eaf5d55
...@@ -45,6 +45,8 @@ ...@@ -45,6 +45,8 @@
*/ */
#include <math.h> #include <math.h>
#define R_xlen_t int
#define XLENGTH LENGTH
static void static void
swap(int l, int r, double *window, int *outlist, int *nrlist, int print_level) swap(int l, int r, double *window, int *outlist, int *nrlist, int print_level)
......
com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/gnur_extracts.c
+ 0
− 23
View file @ 1eaf5d55
...@@ -31,29 +31,6 @@ ...@@ -31,29 +31,6 @@
// extracts from some GnuR stats C files // 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 // from d1mach.c
#include <Rmath.h> #include <Rmath.h>
......
com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/nls.c
+ 342
− 11
View file @ 1eaf5d55
/* /*
* R : A Computer Language for Statistical Data Analysis * Routines used in calculating least squares solutions in a
* Copyright (C) 1997-2007 The R Core Team. * 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 * 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 * it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or * the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version. * (at your option) any later version.
* *
* This program is distributed in the hope that it will be useful, * This program is distributed in the hope that it will be
* but WITHOUT ANY WARRANTY; without even the implied warranty of * useful, but WITHOUT ANY WARRANTY; without even the implied
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* GNU General Public License for more details. * PURPOSE. See the GNU General Public License for more
* details.
* *
* You should have received a copy of the GNU General Public License * You should have received a copy of the GNU General Public
* along with this program; if not, a copy is available at * 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 <stdlib.h>
#include <string.h>
#include <math.h>
#include <float.h>
#include <R.h>
#include <Rinternals.h> #include <Rinternals.h>
#include "nls.h" #include "nls.h"
SEXP nls_iter(SEXP m, SEXP control, SEXP doTraceArg) { return NULL; } #ifndef MIN
SEXP numeric_deriv(SEXP expr, SEXP theta, SEXP rho, SEXP dir) { return NULL; } #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;
}
com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/port.c
+ 578
− 10
View file @ 1eaf5d55
/* /*
* R : A Computer Language for Statistical Data Analysis * 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 * 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 * it under the terms of the GNU General Public License as published by
...@@ -14,26 +14,594 @@ ...@@ -14,26 +14,594 @@
* *
* You should have received a copy of the GNU General Public License * You should have received a copy of the GNU General Public License
* along with this program; if not, a copy is available at * 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" #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, /* names of 1-based indices into iv and v */
SEXP lowerb, SEXP upperb, SEXP d, SEXP iv, SEXP v) { return NULL; } #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 void
nlminb_iterate(double b[], double d[], double fx, double g[], double h[], 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 void
nlsb_iterate(double b[], double d[], double dr[], int iv[], int liv, nlsb_iterate(double b[], double d[], double dr[], int iv[], int liv,
int lv, int n, int nd, int p, double r[], double rd[], 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;
}
com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/statsR_dummy.c
+ 0
− 33
View file @ 1eaf5d55
...@@ -27,13 +27,8 @@ SEXP getListElement(SEXP list, char *str) UNIMPLEMENTED ...@@ -27,13 +27,8 @@ SEXP getListElement(SEXP list, char *str) UNIMPLEMENTED
/* Declarations for .Call entry points */ /* 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 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 Cdqrls(SEXP x, SEXP y, SEXP tol, SEXP chk) UNIMPLEMENTED
SEXP Cdist(SEXP x, SEXP method, SEXP attrs, SEXP p) UNIMPLEMENTED SEXP Cdist(SEXP x, SEXP method, SEXP attrs, SEXP p) UNIMPLEMENTED
SEXP r2dtable(SEXP n, SEXP r, SEXP c) UNIMPLEMENTED SEXP r2dtable(SEXP n, SEXP r, SEXP c) UNIMPLEMENTED
...@@ -44,9 +39,6 @@ SEXP fft(SEXP z, SEXP inverse) UNIMPLEMENTED ...@@ -44,9 +39,6 @@ SEXP fft(SEXP z, SEXP inverse) UNIMPLEMENTED
SEXP mvfft(SEXP z, SEXP inverse) UNIMPLEMENTED SEXP mvfft(SEXP z, SEXP inverse) UNIMPLEMENTED
SEXP nextn(SEXP n, SEXP factors) 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 DoubleCentre(SEXP A) UNIMPLEMENTED
SEXP BinDist(SEXP x, SEXP weights, SEXP slo, SEXP sup, SEXP sn) 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 ...@@ -169,16 +161,9 @@ SEXP optimhess(SEXP call, SEXP op, SEXP args, SEXP rho) UNIMPLEMENTED
SEXP call_dqagi(SEXP x) UNIMPLEMENTED SEXP call_dqagi(SEXP x) UNIMPLEMENTED
SEXP call_dqags(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 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 SplineCoef(SEXP method, SEXP x, SEXP y) UNIMPLEMENTED
SEXP SplineEval(SEXP xout, SEXP z) UNIMPLEMENTED SEXP SplineEval(SEXP xout, SEXP z) UNIMPLEMENTED
...@@ -187,26 +172,8 @@ SEXP ApproxTest(SEXP x, SEXP y, SEXP method, SEXP sf) 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 Approx(SEXP x, SEXP y, SEXP v, SEXP method,
SEXP yleft, SEXP yright, SEXP sf) UNIMPLEMENTED 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 Fisher_sim(SEXP sr, SEXP sc, SEXP sB) UNIMPLEMENTED
SEXP chisq_sim(SEXP sr, SEXP sc, SEXP sB, SEXP E) 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_signrank_free(void) UNIMPLEMENTED
SEXP stats_wilcox_free(void) UNIMPLEMENTED SEXP stats_wilcox_free(void) UNIMPLEMENTED
com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/ts.c
+ 1
− 51
View file @ 1eaf5d55
...@@ -19,58 +19,8 @@ ...@@ -19,58 +19,8 @@
#include "ts.h" #include "ts.h"
void multi_burg(int *pn, double *x, int *pomax, int *pnser, double *coef, // functions from ts.c implemented in Java, here are dummy implementations to make the linker happy.
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) { }
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 pp_sum(SEXP u, SEXP sl) { return NULL; }
SEXP intgrt_vec(SEXP x, SEXP xi, SEXP slag) { return NULL; } SEXP intgrt_vec(SEXP x, SEXP xi, SEXP slag) { return NULL; }
com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/foreign/CallAndExternalFunctions.java
+ 26
− 64
View file @ 1eaf5d55
...@@ -524,75 +524,35 @@ public class CallAndExternalFunctions { ...@@ -524,75 +524,35 @@ public class CallAndExternalFunctions {
return BinDist.create(); return BinDist.create();
case "influence": case "influence":
return Influence.create(); 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": case "mvfft":
// TODO: only transforms arguments and then calls already ported fft
return new UnimplementedExternal(name);
case "nextn": case "nextn":
// TODO: do not want to pull in fourier.c, should be simple to port
return new UnimplementedExternal(name);
case "r2dtable": case "r2dtable":
case "cfilter": // TODO: do not want to pull in random.c + uses PutRNG(), we can pull in rcont.c
case "rfilter": // and then this
case "lowess": // becomes simple wrapper around it.
case "Rsm": return new UnimplementedExternal(name);
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":
case "Fisher_sim": case "Fisher_sim":
case "chisq_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); return new UnimplementedExternal(name);
case "intgrt_vec": case "intgrt_vec":
...@@ -656,6 +616,8 @@ public class CallAndExternalFunctions { ...@@ -656,6 +616,8 @@ public class CallAndExternalFunctions {
default: default:
return null; return null;
} }
// Note: some externals that may be ported with reasonable effort
// tukeyline, rfilter, SWilk, acf, Burg, d2x2xk, pRho
} }
/** /**
......
documentation/dev/build-process.md
+ 7
− 4
View file @ 1eaf5d55
...@@ -41,11 +41,14 @@ See also [building](building.md), [release](../../com.oracle.truffle.r.release/R ...@@ -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 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 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` 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. 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`). Note: All the original (non-patched) GNU R files were added to GIT in branch named `gnur`. When pulling
Their modifications are made in subsequent commits. 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 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). 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 ...@@ -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` 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 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`. * 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`*. The header files in the resulting `include` directory are later linked from `com.oracle.truffle.r.native/include`. See *Building `include`*.
_Patched files_: _Patched files_:
......
mx.fastr/copyrights/overrides
+ 24
− 0
View file @ 1eaf5d55
...@@ -898,6 +898,30 @@ com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/sbart.c,no.copyrigh ...@@ -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/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/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/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/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/init.c,no.copyright
com.oracle.truffle.r.native/gnur/patch/src/library/tools/src/tools.h,no.copyright com.oracle.truffle.r.native/gnur/patch/src/library/tools/src/tools.h,no.copyright
......
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment