INTSXP, // 03 INTEGER IER
};
static R_NativePrimitiveArgType makeqr_t[] = {
INTSXP, // 01 INTEGER NP
INTSXP, // 02 INTEGER NN
REALSXP, // 04 DOUBLE WEIGHTS
REALSXP, // 05 DOUBLE TXMAT
REALSXP, // 06 DOUBLE YVEC
REALSXP, // 07 DOUBLE D
REALSXP, // 08 DOUBLE RBAR
REALSXP, // 09 DOUBLE THETAB
REALSXP, // 10 DOUBLE SSERR
INTSXP, // 03 INTEGER IER
};
static R_FortranMethodDef fortranEntries[] = {
{ "bakwrd", (DL_FUNC)&F77_SUB(bakwrd), 20, bakwrd_t},
{ "forwrd", (DL_FUNC)&F77_SUB(forwrd), 20, forwrd_t},
{ "seqrep", (DL_FUNC)&F77_SUB(seqrep), 20, seqrep_t},
{ "xhaust", (DL_FUNC)&F77_SUB(xhaust), 22, xhaust_t},
{ "initr", (DL_FUNC)&F77_SUB(initr), 11, initr_t},
{ "sing", (DL_FUNC)&F77_SUB(sing), 10, sing_t},
{ "ssleaps", (DL_FUNC)&F77_SUB(ssleaps), 6, ssleaps_t},
{ "tolset", (DL_FUNC)&F77_SUB(tolset), 7, tolset_t},
{ "makeqr", (DL_FUNC)&F77_SUB(makeqr), 10, makeqr_t},
{NULL, NULL, 0, NULL}
};
void R_init_earth(DllInfo *dll) // called by R after R loads the earth package
{
R_registerRoutines(dll, cEntries, callEntries, fortranEntries, NULL);
R_useDynamicSymbols(dll, FALSE);
}
#include <stdlib.h>
#include <R_ext/Rdynload.h>
#include <R_ext/Visibility.h>
#include "frailtypack.h"
static const R_FortranMethodDef FortEntries[] = {
{"additive", (DL_FUNC) &F77_SUB(additive), 62},
{"cvpl", (DL_FUNC) &F77_SUB(cvpl), 29},
{"cvpl_logn", (DL_FUNC) &F77_SUB(cvpl_logn), 29},
{"cvpl_long", (DL_FUNC) &F77_SUB(cvpl_long), 38},
{"cvplnl", (DL_FUNC) &F77_SUB(cvplnl), 45},
{"frailpenal", (DL_FUNC) &F77_SUB(frailpenal), 58},
{"frailpred_sha_nor_mc", (DL_FUNC) &F77_SUB(frailpred_sha_nor_mc), 5},
{"joint", (DL_FUNC) &F77_SUB(joint), 64},
{"joint_longi", (DL_FUNC) &F77_SUB(joint_longi), 62},
{"jointlonginl", (DL_FUNC) &F77_SUB(jointlonginl), 62},
{"joint_multiv", (DL_FUNC) &F77_SUB(joint_multiv), 63},
{"longiuninl", (DL_FUNC) &F77_SUB(longiuninl), 31},
{"nested", (DL_FUNC) &F77_SUB(nested), 57},
{"predict", (DL_FUNC) &F77_SUB(predict), 44},
{"predict_biv", (DL_FUNC) &F77_SUB(predict_biv), 32},
{"predictfam", (DL_FUNC) &F77_SUB(predictfam), 31},
{"predict_logn_sha", (DL_FUNC) &F77_SUB(predict_logn_sha), 15},
{"predict_recurr_sha", (DL_FUNC) &F77_SUB(predict_recurr_sha), 19},
{"predict_tri", (DL_FUNC) &F77_SUB(predict_tri), 38},
{"predicttrinl", (DL_FUNC) &F77_SUB(predicttrinl), 42},
{"risque2", (DL_FUNC) &F77_SUB(risque2), 6},
{"survival_cpm", (DL_FUNC) &F77_SUB(survival_cpm), 6},
{"survival_cpm2", (DL_FUNC) &F77_SUB(survival_cpm2), 6},
{"survival_frailty", (DL_FUNC) &F77_SUB(survival_frailty), 8},
#include <R.h>
#include <Rinternals.h>
#include <R_ext/Rdynload.h>
#include "lcmm.h"
static R_FortranMethodDef FortRout[] = {
{"hetmixlin", (DL_FUNC) &F77_SUB(hetmixlin), 34},
{"hetmixcont", (DL_FUNC) &F77_SUB(hetmixcont), 47},
{"hetmixord", (DL_FUNC) &F77_SUB(hetmixord), 39},
{"hetmixcontmult", (DL_FUNC) &F77_SUB(hetmixcontmult), 54},
{"jointhet", (DL_FUNC) &F77_SUB(jointhet), 59},
{"predictcont", (DL_FUNC) &F77_SUB(predictcont), 21},
{"predictmult", (DL_FUNC) &F77_SUB(predictmult), 23},
{"predictcondmult", (DL_FUNC) &F77_SUB(predictcondmult), 14},
{"cvpl", (DL_FUNC) &F77_SUB(cvpl), 41},
{"postprob2", (DL_FUNC) &F77_SUB(postprob2), 40},
{"calculustransfo", (DL_FUNC) &F77_SUB(calculustransfo), 16},
{NULL, NULL, 0}
};
void R_init_lcmm(DllInfo * dll)
{
R_registerRoutines(dll, NULL, NULL, FortRout, NULL);
R_useDynamicSymbols(dll, FALSE);
R_forceSymbols(dll, TRUE);
}
void F77_SUB(mstepmvn)(double *y,int *pn, int *pp, int *pg,int *pncov,
double *tau, double *sumtau, double *mu, double *sigma)
{
int p= *pp,n= *pn,g= *pg, ncov= *pncov;
int h,i,j,k;
const double two=2.0,zero= 0.0;
double sum;
for(h=0;h<g;h++) {
//pro[h]=sumtau[h]/(double)n;
// calculate the means
for(j=0;j<p;j++) {
sum=zero;
for(i=0;i<n;i++)
sum += y[j*n+i]*tau[h*n+i];
if(sumtau[h] < two)
mu[h*p+j] = zero;
else
mu[h*p+j] = sum/sumtau[h];}
// calculate the covariances
for(j=0;j<p;j++)
for(i=0;i<=j;i++)
sigma[h*p*p+j*p+i] = zero;
for(i=0;i<n;i++)
for(k=0;k<p ;k++)
for(j=0;j<=k;j++)
sigma[h*p*p+k*p+j] += (y[j*n+i]-mu[h*p+j])*(y[k*n+i]-mu[h*p+k])*tau[h*n+i];
for(j=0;j<p;j++) {
for(i=0;i<=j;i++) {
if(sumtau[h] < two)
sigma[h*p*p+j*p+i] =zero;
else
sigma[h*p*p+j*p+i]=sigma[h*p*p+j*p+i]/sumtau[h];
sigma[h*p*p+i*p+j]=sigma[h*p*p+j*p+i];}
}
}
// end of loop (h)
F77_SUB(getcov)(sigma,sumtau,&n,&p,&g,&ncov);
return;
}
void F77_SUB(mstepmvt)(double *y,int *pn, int *pp, int *pg,int *pncov,
double *tau,double *xuu, double *sumtau, double *sumxuu,double *sumxuuln,
double *mu, double *sigma, double *dof)
{
int p= *pp,n= *pn,g= *pg, ncov= *pncov;
int h,i,j,k;
double sum,bx=200;
const double two=2.0,zero= 0.0;
for(h=0;h<g;h++) {
// calculate the means
for(j=0;j<p;j++) {
sum=zero;
for( i=0;i<n;i++)
sum += y[j*n+i]*tau[h*n+i]*xuu[h*n+i];
if(sumtau[h] < two)
mu[h*p+j] = zero;
else
mu[h*p+j] = sum/sumxuu[h];}
// calculate the covariances
for(j=0;j<p;j++)
for( i=0;i<=j;i++)
sigma[h*p*p+j*p+i] = zero;
for(i=0;i<n;i++)
for( k=0;k<p ;k++)
for( j=0;j<=k;j++)
sigma[h*p*p+k*p+j] += (y[j*n+i]-mu[h*p+j])*(y[k*n+i]-mu[h*p+k])*tau[h*n+i]*xuu[h*n+i];
for( j=0;j<p;j++) {
for(i=0;i<=j;i++) {
if(sumtau[h] < two)
sigma[h*p*p+j*p+i] =zero;
else
sigma[h*p*p+j*p+i]=sigma[h*p*p+j*p+i]/sumtau[h];
sigma[h*p*p+i*p+j]=sigma[h*p*p+j*p+i];}}
}
// calculate the degrees of freedom
F77_SUB(getdof)(&n, &g, sumtau, sumxuuln, dof,&bx);
if(ncov!=3)
F77_SUB(getcov)(sigma,sumtau,&n,&p,&g,&ncov);
return;
}
/* 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, write to the Free Software Foundation, Inc., */
/* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. */
#include <R.h>
#include <Rinternals.h>
#include <R_ext/Rdynload.h>
#include <R_ext/Visibility.h>
#include "DeconWK.h"
static
R_NativePrimitiveArgType getmin_t[] =
{REALSXP, REALSXP, INTSXP, REALSXP, REALSXP, INTSXP, INTSXP};
static const
R_FortranMethodDef FortEntries[] = {
{"getmin", (DL_FUNC) &F77_SUB(getmin), 7, getmin_t},
{NULL, NULL, 0}
};
void attribute_visible
R_init_DeconWK(DllInfo *dll){
R_registerRoutines(dll, NULL, NULL, FortEntries, NULL);
R_useDynamicSymbols(dll, FALSE);
}
void
loess_(double *y, double *x_, int *size_info, double *weights, double *span,
int *degree, int *parametric, int *drop_square, int *normalize,
char **statistics, char **surface, double *cell, char **trace_hat_in,
int *iterations, double *fitted_values, double *fitted_residuals,
double *enp, double *s, double *one_delta, double *two_delta,
double *pseudovalues, double *trace_hat_out, double *diagonal,
double *robust, double *divisor, int *parameter, int *a, double *xi,
double *vert, double *vval)
{
double *x, *x_tmp, new_cell, trL, delta1, delta2, sum_squares = 0,
*pseudo_resid, *temp, *xi_tmp, *vert_tmp, *vval_tmp,
*diag_tmp, trL_tmp = 0, d1_tmp = 0, d2_tmp = 0, sum, mean;
int i, j, k, p, N, D, sum_drop_sqr = 0, sum_parametric = 0,
setLf, nonparametric = 0, *order_parametric,
*order_drop_sqr, zero = 0, max_kd, *a_tmp, *param_tmp;
int cut, comp();
char *new_stat, *mess;
void condition();
D = size_info[0];
N = size_info[1];
max_kd = (N > 200 ? N : 200);
*one_delta = *two_delta = *trace_hat_out = 0;
x = (double *) malloc(D * N * sizeof(double));
x_tmp = (double *) malloc(D * N * sizeof(double));
temp = (double *) malloc(N * sizeof(double));
a_tmp = (int *) malloc(max_kd * sizeof(int));
xi_tmp = (double *) malloc(max_kd * sizeof(double));
vert_tmp = (double *) malloc(D * 2 * sizeof(double));
vval_tmp = (double *) malloc((D + 1) * max_kd * sizeof(double));
diag_tmp = (double *) malloc(N * sizeof(double));
param_tmp = (int *) malloc(N * sizeof(int));
order_parametric = (int *) malloc(D * sizeof(int));
order_drop_sqr = (int *) malloc(D * sizeof(int));
if((*iterations) > 0)
pseudo_resid = (double *) malloc(N * sizeof(double));
new_cell = (*span) * (*cell);
for(i = 0; i < N; i++)
robust[i] = 1;
for(i = 0; i < (N * D); i++)
x_tmp[i] = x_[i];
if((*normalize) && (D > 1)) {
cut = ceil(0.100000000000000000001 * N);
for(i = 0; i < D; i++) {
k = i * N;
for(j = 0; j < N; j++)
temp[j] = x_[k + j];
qsort(temp, N, sizeof(double), comp);
sum = 0;
for(j = cut; j <= (N - cut - 1); j++)
sum = sum + temp[j];
mean = sum / (N - 2 * cut);
sum = 0;
for(j = cut; j <= (N - cut - 1); j++) {
temp[j] = temp[j] - mean;
sum = sum + temp[j] * temp[j];
}
divisor[i] = sqrt(sum / (N - 2 * cut - 1));
for(j = 0; j < N; j++) {
p = k + j;
x_tmp[p] = x_[p] / divisor[i];
}
}
}
else
for(i = 0; i < D; i++) divisor[i] = 1;
j = D - 1;
for(i = 0; i < D; i++) {
sum_drop_sqr = sum_drop_sqr + drop_square[i];
sum_parametric = sum_parametric + parametric[i];
if(parametric[i])
order_parametric[j--] = i;
else
order_parametric[nonparametric++] = i;
}
//Reorder the predictors w/ the non-parametric first
for(i = 0; i < D; i++) {
order_drop_sqr[i] = 2 - drop_square[order_parametric[i]];
k = i * N;
p = order_parametric[i] * N;
for(j = 0; j < N; j++)
x[k + j] = x_tmp[p + j];
}
// Misc. checks .............................
if((*degree) == 1 && sum_drop_sqr) {
error_status = 1;
error_message = "Specified the square of a factor predictor to be "\
"dropped when degree = 1";
return;
}
if(D == 1 && sum_drop_sqr) {
error_status = 1;
error_message = "Specified the square of a predictor to be dropped "\
"with only one numeric predictor";
return;
}
if(sum_parametric == D) {
error_status = 1;
error_message = "Specified parametric for all predictors";
return;
}
// Start the iterations .....................
for(j = 0; j <= (*iterations); j++) {
new_stat = j ? "none" : *statistics;
for(i = 0; i < N; i++)
robust[i] = weights[i] * robust[i];
condition(surface, new_stat, trace_hat_in);
setLf = !strcmp(surf_stat, "interpolate/exact");
loess_raw(y, x, weights, robust, &D, &N, span, degree,
&nonparametric, order_drop_sqr, &sum_drop_sqr,
&new_cell, &surf_stat, fitted_values, parameter, a,
xi, vert, vval, diagonal, &trL, &delta1, &delta2,
&setLf);
if(j == 0) {
*trace_hat_out = trL;
*one_delta = delta1;
*two_delta = delta2;
}
for(i = 0; i < N; i++){
fitted_residuals[i] = y[i] - fitted_values[i];
};
if(j < (*iterations))
F77_SUB(lowesw)(fitted_residuals, &N, robust, temp);
}
if((*iterations) > 0) {
F77_SUB(lowesp)(&N, y, fitted_values, weights, robust, temp,
pseudovalues);
loess_raw(pseudovalues, x, weights, weights, &D, &N, span,
degree, &nonparametric, order_drop_sqr, &sum_drop_sqr,
&new_cell, &surf_stat, temp, param_tmp, a_tmp, xi_tmp,
vert_tmp, vval_tmp, diag_tmp, &trL_tmp, &d1_tmp, &d2_tmp,
&zero);
for(i = 0; i < N; i++)
pseudo_resid[i] = pseudovalues[i] - temp[i];
}
if((*iterations) == 0)
for(i = 0; i < N; i++)
sum_squares = sum_squares + weights[i] *
fitted_residuals[i] * fitted_residuals[i];
else
for(i = 0; i < N; i++)
sum_squares = sum_squares + weights[i] *
pseudo_resid[i] * pseudo_resid[i];
*enp = (*one_delta) + 2 * (*trace_hat_out) - N;
*s = sqrt(sum_squares / (*one_delta));
//Clean the mess and leave ..................
free(x);
free(x_tmp);
free(temp);
free(xi_tmp);
free(vert_tmp);
free(vval_tmp);
free(diag_tmp);
free(a_tmp);
free(param_tmp);
free(order_parametric);
free(order_drop_sqr);
if((*iterations) > 0)
free(pseudo_resid);
}
#include <R.h>
#include <Rinternals.h>
#include <R_ext/Rdynload.h>
#include "declarations.h"
static R_FortranMethodDef FortEntries[] = {
{"fartransform", (DL_FUNC) &F77_SUB(artransform), 2},
{"fldl", (DL_FUNC) &F77_SUB(ldl), 4},
{"fldlssm", (DL_FUNC) &F77_SUB(ldlssm), 15},
{"fsignaltheta", (DL_FUNC) &F77_SUB(signaltheta), 12},
{"fapprox", (DL_FUNC) &F77_SUB(approx), 26},
{"fgsmoothall", (DL_FUNC) &F77_SUB(gsmoothall), 43},
{"fngsmooth", (DL_FUNC) &F77_SUB(ngsmooth), 39},
{"fkfilter", (DL_FUNC) &F77_SUB(kfilter), 31},
{"fgloglik", (DL_FUNC) &F77_SUB(gloglik), 19},
{"fngloglik", (DL_FUNC) &F77_SUB(ngloglik), 36},
{"fisample", (DL_FUNC) &F77_SUB(isample), 35},
{"fzalpha", (DL_FUNC) &F77_SUB(zalpha), 10},
{"fvarmeanw", (DL_FUNC) &F77_SUB(varmeanw), 8},
{"fsimfilter", (DL_FUNC) &F77_SUB(simfilter), 30},
{"fngfilter", (DL_FUNC) &F77_SUB(ngfilter), 39},
{"fisamplefilter", (DL_FUNC) &F77_SUB(isamplefilter), 35},
{"fsimgaussian", (DL_FUNC) &F77_SUB(simgaussian), 30},
{"fsimgaussianuncond", (DL_FUNC) &F77_SUB(simgaussianuncond), 30},
{"fmvfilter", (DL_FUNC) &F77_SUB(mvfilter), 12},
{NULL, NULL, 0}
};
void R_init_KFAS(DllInfo *dll)
{
{NULL, NULL, 0}
};
#define FDEF(name) {#name, (DL_FUNC) &F77_SUB(name), sizeof(name ## _t)/sizeof(name ## _t[0]), name ##_t}
static R_NativePrimitiveArgType lowesw_t[] = { REALSXP, INTSXP, REALSXP, INTSXP};
static R_NativePrimitiveArgType lowesp_t[] = {
INTSXP, REALSXP, REALSXP, REALSXP, REALSXP, INTSXP, REALSXP};
static const R_FortranMethodDef FortEntries[] = {
FDEF(lowesw),
FDEF(lowesp),
{"setppr", (DL_FUNC) &F77_SUB(setppr), 6},
{"smart", (DL_FUNC) &F77_SUB(smart), 16},
{"pppred", (DL_FUNC) &F77_SUB(pppred), 5},
{"setsmu", (DL_FUNC) &F77_SUB(setsmu), 0},
{"rbart", (DL_FUNC) &F77_SUB(rbart), 20},
{"bvalus", (DL_FUNC) &F77_SUB(bvalus), 7},
{"supsmu", (DL_FUNC) &F77_SUB(supsmu), 10},
{"hclust", (DL_FUNC) &F77_SUB(hclust), 11},
{"hcass2", (DL_FUNC) &F77_SUB(hcass2), 6},
{"kmns", (DL_FUNC) &F77_SUB(kmns), 17},
{"eureka", (DL_FUNC) &F77_SUB(eureka), 6},
{"stl", (DL_FUNC) &F77_SUB(stl), 18},
{NULL, NULL, 0}
};
#define EXTDEF(name, n) {#name, (DL_FUNC) &name, n}
#include "expm.h"
#include "logm-eigen.h"
#include "matpow.h"
static const R_CallMethodDef CallEntries[] = {
{"do_expm", (DL_FUNC) &do_expm, 2},
{"R_matpow", (DL_FUNC) &R_matpow, 2},
{"R_dgebal", (DL_FUNC) &R_dgebal, 2},
{"do_expm_eigen", (DL_FUNC) &do_expm_eigen, 2},
{"do_logm_eigen", (DL_FUNC) &do_logm_eigen, 2},
{"R_matexp_MH09", (DL_FUNC) &R_matexp_MH09, 2},
{NULL, NULL, 0}
};
static const R_FortranMethodDef FortEntries[] = {
{"matexpRBS", (DL_FUNC) &F77_SUB(matexprbs), 5}, // ./matexp.f
{"matrexp", (DL_FUNC) &F77_SUB(matrexp), 5}, // ./matrexp.f
{"matrexpO", (DL_FUNC) &F77_SUB(matrexpo), 5}, // ./matrexpO.f
{NULL, NULL, 0}
};
void R_init_expm(DllInfo *dll)
{
R_registerRoutines(dll, NULL, CallEntries, FortEntries, NULL);
R_useDynamicSymbols(dll, FALSE);
/* callable C code from other packages C code :*/
R_RegisterCCallable("expm", "expm", (DL_FUNC) expm);
R_RegisterCCallable("matpow", "matpow", (DL_FUNC) matpow);
R_RegisterCCallable("expm_eigen", "expm_eigen", (DL_FUNC) expm_eigen);
R_RegisterCCallable("logm_eigen", "logm_eigen", (DL_FUNC) logm_eigen);
