[Genabel-commits] r1359 - in pkg: DatABEL/src/ITERlib GenABEL GenABEL/R GenABEL/src/ITERlib TestABEL/inst/unitTests TestABEL/src VariABEL/src/ITERlib
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Nov 4 11:03:00 CET 2013
Author: maartenk
Date: 2013-11-04 11:03:00 +0100 (Mon, 04 Nov 2013)
New Revision: 1359
Added:
pkg/TestABEL/src/Rstuff.cpp
pkg/TestABEL/src/Rstuff.h
Removed:
pkg/TestABEL/src/Rstaff.cpp
pkg/TestABEL/src/Rstaff.h
Modified:
pkg/DatABEL/src/ITERlib/iterator.cpp
pkg/GenABEL/ChangeLog
pkg/GenABEL/R/export.merlin.R
pkg/GenABEL/src/ITERlib/iterator.cpp
pkg/GenABEL/src/ITERlib/iterator_functions.cpp
pkg/TestABEL/inst/unitTests/output.txt
pkg/TestABEL/src/dautil.cpp
pkg/VariABEL/src/ITERlib/iterator.cpp
pkg/VariABEL/src/ITERlib/iterator_functions.cpp
Log:
Replaced all 'staff' words and filenames for 'stuff'
Modified: pkg/DatABEL/src/ITERlib/iterator.cpp
===================================================================
--- pkg/DatABEL/src/ITERlib/iterator.cpp 2013-11-04 08:35:37 UTC (rev 1358)
+++ pkg/DatABEL/src/ITERlib/iterator.cpp 2013-11-04 10:03:00 UTC (rev 1359)
@@ -256,7 +256,7 @@
/**
// OLD STUFF BELOW HERE:
- // iterator and other staff
+ // iterator and other stuff
SEXP databel_impute_prob_2_databel_mach_dose(SEXP imputedata, SEXP OutFileName, SEXP CacheSizeMb)
{
CHECK_PTR(imputedata);
Modified: pkg/GenABEL/ChangeLog
===================================================================
--- pkg/GenABEL/ChangeLog 2013-11-04 08:35:37 UTC (rev 1358)
+++ pkg/GenABEL/ChangeLog 2013-11-04 10:03:00 UTC (rev 1359)
@@ -173,7 +173,7 @@
Bug [#1641] (regression bug with merge.snp.data in version 1.6.9;
filed in by Karl Froner) fixed. Now GenABEL deals with exceptional
situation in merge.snp.data / monomorphic part; added case of no overlap
-in SNPs (skip monomorphic staff then). RUnit regression test
+in SNPs (skip monomorphic stuff then). RUnit regression test
runit.merge.R/test.merge.bug1641 added.
Modifications in 'estlambda': plot=FALSE by default, added option
Modified: pkg/GenABEL/R/export.merlin.R
===================================================================
--- pkg/GenABEL/R/export.merlin.R 2013-11-04 08:35:37 UTC (rev 1358)
+++ pkg/GenABEL/R/export.merlin.R 2013-11-04 10:03:00 UTC (rev 1359)
@@ -11,7 +11,7 @@
} else {
if (dpieceFunInt==1) dump.piece=dump.piece
else if (dpieceFunInt==2) dump.piece=dump.piece.New
- else stop("weird staff!")
+ else stop("weird stuff!")
}
formats <- c("merlin","plink")
if (!(match(format,formats,nomatch=0)>0)) {
Modified: pkg/GenABEL/src/ITERlib/iterator.cpp
===================================================================
--- pkg/GenABEL/src/ITERlib/iterator.cpp 2013-11-04 08:35:37 UTC (rev 1358)
+++ pkg/GenABEL/src/ITERlib/iterator.cpp 2013-11-04 10:03:00 UTC (rev 1359)
@@ -1,5 +1,5 @@
#include <cstdarg>
-#include "Rstaff.h"
+#include "Rstuff.h"
#include "iterator_functions.h"
#include "iterator.h"
#include "gwaa_cpp.h"
@@ -409,7 +409,7 @@
/**
// OLD STUFF BELOW HERE:
- // iterator and other staff
+ // iterator and other stuff
SEXP databel_impute_prob_2_databel_mach_dose(SEXP imputedata, SEXP OutFileName, SEXP CacheSizeMb)
{
CHECK_PTR(imputedata);
Modified: pkg/GenABEL/src/ITERlib/iterator_functions.cpp
===================================================================
--- pkg/GenABEL/src/ITERlib/iterator_functions.cpp 2013-11-04 08:35:37 UTC (rev 1358)
+++ pkg/GenABEL/src/ITERlib/iterator_functions.cpp 2013-11-04 10:03:00 UTC (rev 1359)
@@ -1,5 +1,5 @@
#include <new>
-#include "Rstaff.h"
+#include "Rstuff.h"
#include "iterator_functions.h"
#ifdef __cplusplus
Modified: pkg/TestABEL/inst/unitTests/output.txt
===================================================================
--- pkg/TestABEL/inst/unitTests/output.txt 2013-11-04 08:35:37 UTC (rev 1358)
+++ pkg/TestABEL/inst/unitTests/output.txt 2013-11-04 10:03:00 UTC (rev 1359)
@@ -1,10 +1,10 @@
cd ../../..;\
R CMD INSTALL /home/erik/workspace/TestABEL
make[1]: Entering directory `/home/erik/workspace/TestABEL/src'
-g++ -I/usr/share/R/include -I. -Ifvlib -fpic -g -O2 -c Rstaff.cpp -o Rstaff.o
+g++ -I/usr/share/R/include -I. -Ifvlib -fpic -g -O2 -c Rstuff.cpp -o Rstuff.o
g++ -I/usr/share/R/include -I. -Ifvlib -fpic -g -O2 -c dautil.cpp -o dautil.o
g++ -I/usr/share/R/include -I. -Ifvlib -fpic -g -O2 -c mytest.cpp -o mytest.o
-g++ -shared -o TestABEL.so Rstaff.o dautil.o mytest.o -L/usr/lib/R/lib -lR
+g++ -shared -o TestABEL.so Rstuff.o dautil.o mytest.o -L/usr/lib/R/lib -lR
make[1]: Leaving directory `/home/erik/workspace/TestABEL/src'
NOTE: THIS PACKAGE IS NOW OBSOLETE.
Deleted: pkg/TestABEL/src/Rstaff.cpp
===================================================================
--- pkg/TestABEL/src/Rstaff.cpp 2013-11-04 08:35:37 UTC (rev 1358)
+++ pkg/TestABEL/src/Rstaff.cpp 2013-11-04 10:03:00 UTC (rev 1359)
@@ -1,906 +0,0 @@
-#include <math.h>
-
-#include "Rstaff.h"
-
-// most be included after c++ headers!
-#include <stdio.h>
-#include <Rdefines.h>
-
-extern "C" {
-// .Fortran("dqrls",
-// qr = x, n = n, p = p,
-// y = tra, ny = ny,
-// tol = as.double(tol),
-// coefficients = mat.or.vec(p, ny),
-// residuals = y, effects = y, rank = integer(1L),
-// pivot = 1L:p, qraux = double(p), work = double(2*p),
-// PACKAGE="base")$coefficients[2]
-
-void dqrls_(double*, int*, int*, double*, int*, double*, double*, double*,
- double*, int*, int*, double*, double*);
-}
-
-extern "C" {
-// .Fortran("ch2inv", x = x, nr, size, v = matrix(0, nrow = size,
-// ncol = size), info = integer(1L), DUP = FALSE, PACKAGE = "base")
-void ch2inv_(double*, int*, int*, double*, int*);
-}
-
-extern "C" {
-
-SEXP get_nvars_R(SEXP s) {
- CHECK_PTR(s);
-
- AbstractMatrix * p = (AbstractMatrix*) R_ExternalPtrAddr(s);
-
- if (p == NULL) {
- error_R("pointer is NULL\n");
- return R_NilValue;
- }
-
- SEXP out;
- PROTECT(out = allocVector(INTSXP, 1));
- unsigned int nvars = 0;
-
- try {
- nvars = (unsigned int) p->getNumVariables();
- } catch (int errcode) {
- nvars = 0;
- }
-
- if (nvars <= 0) {
- out = R_NilValue;
- } else {
- INTEGER(out)[0] = nvars;
- }
- UNPROTECT(1);
- return out;
-}
-
-SEXP get_nobs_R(SEXP s) {
- CHECK_PTR(s);
-
- AbstractMatrix * p = (AbstractMatrix*) R_ExternalPtrAddr(s);
-
- if (p == NULL) {
- error_R("pointer is NULL\n");
- return R_NilValue;
- }
-
- SEXP out;
- PROTECT(out = allocVector(INTSXP, 1));
- unsigned int nobss = 0;
-
- try {
- nobss = (unsigned int) p->getNumObservations();
- } catch (int errcode) {
- nobss = 0;
- }
-
- if (nobss <= 0) {
- out = R_NilValue;
- } else {
- INTEGER(out)[0] = nobss;
- }
- UNPROTECT(1);
- return out;
-}
-
-SEXP get_all_varnames_R(SEXP s) {
- CHECK_PTR(s);
-
- AbstractMatrix * p = (AbstractMatrix*) R_ExternalPtrAddr(s);
-
- if (p == NULL) {
- error_R("pointer is NULL\n");
- return R_NilValue;
- }
-
- R_len_t nvars = (R_len_t) 0;
-
- try {
- nvars = p->getNumVariables();
- } catch (int errcode) {
- return R_NilValue;
- }
-
- fixedchar tmp;
- SEXP ret;
- PROTECT(ret = allocVector(STRSXP, (R_len_t) nvars));
-
- try {
- for (unsigned long int i = 0; i < nvars; i++) {
- tmp = p->readVariableName(i);
- SET_STRING_ELT(ret, i, mkChar(tmp.name));
- }
- } catch (int errcode) {
- error_R("something went terribly wrong in get_all_varnames_R\n");
- UNPROTECT(1);
- return ret;
- }
- UNPROTECT(1);
- return ret;
-}
-
-// !!!
-SEXP set_all_varnames_R(SEXP s, SEXP names) {
- CHECK_PTR(s);
-
- AbstractMatrix * p = (AbstractMatrix*) R_ExternalPtrAddr(s);
-
- if (p == NULL) {
- error_R("pointer is NULL\n");
- return R_NilValue;
- }
-
- R_len_t nvars = (R_len_t) 0;
-
- try {
- nvars = p->getNumVariables();
- } catch (int errcode) {
- error_R("can not p->getNumVariables()\n");
- return R_NilValue;
- }
-
- // check that length of SEXP names is the same!!!
-
- for (unsigned long int i = 0; i < nvars; i++) {
- std::string varname = CHAR(STRING_ELT(names, i));
- try {
- p->writeVariableName(i, fixedchar(varname));
- } catch (int errcode) {
- error_R("can not set variable name for variable %ul\n", i);
- return R_NilValue;
- }
- }
-
- SEXP ret;
- PROTECT(ret = allocVector(LGLSXP, 1));
- LOGICAL(ret)[0] = TRUE;
- UNPROTECT(1);
- return ret;
-
-}
-
-SEXP get_all_obsnames_R(SEXP s) {
- CHECK_PTR(s);
-
- AbstractMatrix * p = (AbstractMatrix*) R_ExternalPtrAddr(s);
-
- if (p == NULL) {
- error_R("pointer is NULL\n");
- return R_NilValue;
- }
-
- R_len_t nobss = (R_len_t) 0;
-
- try {
- nobss = p->getNumObservations();
- } catch (int errcode) {
- return R_NilValue;
- }
-
- fixedchar tmp;
- SEXP ret;
- PROTECT(ret = allocVector(STRSXP, (R_len_t) nobss));
-
- try {
- for (unsigned long int i = 0; i < nobss; i++) {
- tmp = p->readObservationName(i);
- SET_STRING_ELT(ret, i, mkChar(tmp.name));
- }
- } catch (int errcode) {
- error_R("something went terribly wrong in get_all_obsnames_R\n");
- UNPROTECT(1);
- return ret;
- }
- UNPROTECT(1);
- return ret;
-}
-
-// !!!
-SEXP set_all_obsnames_R(SEXP s, SEXP names) {
- CHECK_PTR(s);
-
- AbstractMatrix * p = (AbstractMatrix*) R_ExternalPtrAddr(s);
-
- if (p == NULL) {
- error_R("pointer is NULL\n");
- return R_NilValue;
- }
-
- R_len_t nobss = (R_len_t) 0;
-
- try {
- nobss = p->getNumObservations();
- } catch (int errcode) {
- error_R("can not p->getNumObservations()\n");
- return R_NilValue;
- }
-
- // check that length of SEXP names is the same!!!
-
- for (unsigned long int i = 0; i < nobss; i++) {
- std::string obsname = CHAR(STRING_ELT(names, i));
- try {
- p->writeObservationName(i, fixedchar(obsname));
- } catch (int errcode) {
- error_R("can not set observation name for observation %ul\n", i);
- return R_NilValue;
- }
- }
-
- SEXP ret;
- PROTECT(ret = allocVector(LGLSXP, 1));
- LOGICAL(ret)[0] = TRUE;
- UNPROTECT(1);
- return ret;
-
-}
-
-static void AbstractMatrixRFinalizer(SEXP x) {
- CHECK_PTR(x);
- if (x == R_NilValue)
- return;
- AbstractMatrix* p = (AbstractMatrix *) EXTPTR_PTR(x);
- if (p == NULL)
- return;
- // p->free_resources();
- Rprintf("finalizing AbstractMatrix: %p\n", p);
- delete p;
-}
-
-// !!!
-SEXP disconnect_R(SEXP s) {
- AbstractMatrixRFinalizer(s);
- R_ClearExternalPtr(s);
- return R_NilValue;
-}
-
-SEXP externalptr_is_null(SEXP s) {
- CHECK_PTR(s);
- AbstractMatrix * p = (AbstractMatrix*) R_ExternalPtrAddr(s);
- SEXP ret;
- PROTECT(ret = allocVector(LGLSXP, 1));
- LOGICAL(ret)[0] = FALSE;
- if (p == NULL)
- LOGICAL(ret)[0] = TRUE;
- UNPROTECT(1);
- return ret;
-}
-
-SEXP open_float_FileMatrix_R(SEXP fname, SEXP cacheMb) {
- unsigned long int cachesizeMb = (unsigned long int) INTEGER(cacheMb)[0];
- std::string filename = CHAR(STRING_ELT(fname, 0));
- if (cachesizeMb < 0) {
- error_R("negative cache size");
- return R_NilValue;
- }
-
- AbstractMatrix* p = NULL;
-
- try {
- p = new filevector(filename, cachesizeMb);
- } catch (int errcode) {
- return R_NilValue;
- }
-
- if (p == NULL) {
- error_R("pointer is NULL\n");
- return R_NilValue;
- }
- SEXP val = R_MakeExternalPtr(p, type_tag, R_NilValue);
- R_RegisterCFinalizerEx(val, AbstractMatrixRFinalizer, (Rboolean) TRUE);
- return val;
-}
-
-SEXP read_variable_float_FileMatrix_R(SEXP nvar, SEXP s) {
- CHECK_PTR(s);
- AbstractMatrix * p = (AbstractMatrix*) R_ExternalPtrAddr(s);
- if (p == NULL) {
- error_R("pointer is NULL\n");
- return R_NilValue;
- }
- unsigned long int nvariable = (unsigned long int) INTEGER(nvar)[0];
- unsigned int nobs = 0;
- try {
- nobs = p->getNumObservations();
- } catch (int errcode) {
- return R_NilValue;
- }
- float * internal_data = new (std::nothrow) float[nobs];
-
- try {
- p->readVariableAs(nvariable, internal_data);
- } catch (int errcode) {
- return R_NilValue;
- }
-
- SEXP out;
- PROTECT(out = allocVector(REALSXP, (R_len_t) p->getNumObservations()));
- for (unsigned long int i = 0; i < nobs; i++)
- REAL(out)[i] = (double) internal_data[i];
- UNPROTECT(1);
-
- delete[] internal_data;
-
- return out;
-}
-
-SEXP write_variable_double_FileMatrix_R(SEXP nvar, SEXP data, SEXP s) {
- CHECK_PTR(s);
- AbstractMatrix * p = (AbstractMatrix*) R_ExternalPtrAddr(s);
- if (p == NULL) {
- error_R("pointer is NULL\n");
- return R_NilValue;
- }
- unsigned long int nvariable = (unsigned long int) INTEGER(nvar)[0];
- // here generally should be very careful -- what type of data is IN?
-
- unsigned int nvars = 0;
- unsigned int nobss = 0;
-
- try {
- nvars = p->getNumVariables();
- } catch (int errocode) {
- return R_NilValue;
- }
-
- if (nvariable < 0 || nvariable >= nvars) {
- error_R("nvar (%lu) out of range!\n", nvariable);
- return R_NilValue;
- }
-
- try {
- nobss = p->getNumObservations();
- } catch (int errcode) {
- return R_NilValue;
- }
-
- // float * internal_data = new (std::nothrow) float [nobss];
- double internal_data[nobss];
- if (internal_data == NULL) {
- error_R("internal_data pointer is NULL\n");
- return R_NilValue;
- }
-
- for (unsigned long int i = 0; i < nobss; i++) {
- internal_data[i] = (double) REAL(data)[i];
- }
-
- // Rprintf("\n%lu, %lu\n",nvariable,nobss);
- // for (unsigned long int i=0;i< nobss;i++) {
- // Rprintf("%f ",internal_data[i]);
- // }
- try {
- p->writeVariableAs(nvariable, internal_data);
- } catch (int errcode) {
- error_R("can not write variable %ul\n", nvariable);
- }
-
- SEXP ret;
- PROTECT(ret = allocVector(LGLSXP, 1));
- LOGICAL(ret)[0] = TRUE;
- UNPROTECT(1);
- return ret;
-}
-
-// !!!
-SEXP set_cachesizeMb_R(SEXP s, SEXP SizeMB) {
- CHECK_PTR(s);
- AbstractMatrix * p = (AbstractMatrix*) R_ExternalPtrAddr(s);
- if (p == NULL) {
- error_R("pointer is NULL\n");
- return R_NilValue;
- }
- unsigned long int sizeMb = (unsigned long int) INTEGER(SizeMB)[0];
- try {
- p->setCacheSizeInMb(sizeMb);
- } catch (int errcode) {
- error_R("cannot reset cache size\n");
- return R_NilValue;
- }
-
- SEXP ret;
- PROTECT(ret = allocVector(LGLSXP, 1));
- LOGICAL(ret)[0] = TRUE;
- UNPROTECT(1);
- return ret;
-
-}
-
-SEXP get_cachesizeMb_R(SEXP s) {
- CHECK_PTR(s);
- AbstractMatrix * p = (AbstractMatrix*) R_ExternalPtrAddr(s);
- if (p == NULL) {
- error_R("pointer is NULL\n");
- return R_NilValue;
- }
-
- unsigned long int sizeMb = 0;
-
- try {
- sizeMb = p->getCacheSizeInMb();
- } catch (int errcode) {
- return R_NilValue;
- }
-
- SEXP out;
- PROTECT(out = allocVector(INTSXP, 1));
- INTEGER(out)[0] = (int) sizeMb;
- UNPROTECT(1);
- return (out);
-}
-
-// !!!
-SEXP text2fvf_R(SEXP Fnames, SEXP IntPars) {
-
- std::string program_name = "text2fvf_R";
- std::string infilename = CHAR(STRING_ELT(Fnames, 0));
- std::string outfilename = CHAR(STRING_ELT(Fnames, 1));
- std::string rownamesfilename = CHAR(STRING_ELT(Fnames, 2));
- std::string colnamesfilename = CHAR(STRING_ELT(Fnames, 3));
- int rownames = (int) INTEGER(IntPars)[0];
- int colnames = (int) INTEGER(IntPars)[1];
- int skiprows = (int) INTEGER(IntPars)[2];
- int skipcols = (int) INTEGER(IntPars)[3];
- int transpose = (int) INTEGER(IntPars)[4];
- int Rmatrix = (int) INTEGER(IntPars)[5];
- unsigned short int Type = (unsigned short int) INTEGER(IntPars)[6];
-
- try {
- text2fvf(program_name, infilename, outfilename, rownamesfilename,
- colnamesfilename, rownames, colnames, skiprows, skipcols,
- transpose, Rmatrix, Type, true);
- } catch (int x) {
- error_R("failed in text2fvf_R\n");
- return R_NilValue;
- }
-
- // Rprintf("well-finished in text2_float_fvf_R!\n");
- SEXP ret;
- PROTECT(ret = allocVector(LGLSXP, 1));
- LOGICAL(ret)[0] = TRUE;
- UNPROTECT(1);
- return ret;
-
-}
-
-SEXP ini_empty_FileMatrix_R(SEXP fname, SEXP nvars, SEXP nobs, SEXP Type) {
- // internal format data types
- //#define UNSIGNED_SHORT_INT 1
- //#define SHORT_INT 2
- //#define UNSIGNED_INT 3
- //#define INT 4
- //#define FLOAT 5
- //#define DOUBLE 6
-
- unsigned long int nvariables = (unsigned long int) INTEGER(nvars)[0];
- unsigned long int nobservations = (unsigned long int) INTEGER(nobs)[0];
- std::string filename = CHAR(STRING_ELT(fname, 0));
- unsigned short int type = (unsigned short int) INTEGER(Type)[0];
-
- if (type <= 0 || type > 6) {
- error_R("unknow type %u\n", type);
- return R_NilValue;
- }
- try {
- // last flag -- override
- initialize_empty_file(filename, nvariables, nobservations, type, false);
- } catch (int errcode) {
- error_R("failed in ini_empty_FileMatrix_R");
- return R_NilValue;
- }
-
- SEXP ret;
- PROTECT(ret = allocVector(LGLSXP, 1));
- LOGICAL(ret)[0] = TRUE;
- UNPROTECT(1);
- return ret;
-
-}
-
-//virtual void save(string new_file_name, unsigned long int nvars, unsigned long int nobss, unsigned long int * varindexes, unsigned long int * obsindexes)
-SEXP save_R(SEXP New_file_name, SEXP IntPars, SEXP s) {
- CHECK_PTR(s);
- AbstractMatrix * p = (AbstractMatrix*) R_ExternalPtrAddr(s);
- if (p == NULL) {
- error_R("pointer is NULL\n");
- return R_NilValue;
- }
-
- std::string new_file_name = CHAR(STRING_ELT(New_file_name, 0));
- unsigned long int nvars = (unsigned long int) INTEGER(IntPars)[0];
- unsigned long int nobss = (unsigned long int) INTEGER(IntPars)[1];
- unsigned long int varindexes[nvars];
- unsigned long int obsindexes[nobss];
-
- for (unsigned long int i = 0; i < nvars; i++)
- varindexes[i] = (unsigned long int) INTEGER(IntPars)[i + 2];
- for (unsigned long int i = 0; i < nobss; i++)
- obsindexes[i] = (unsigned long int) INTEGER(IntPars)[i + 2 + nvars];
-
- try {
- p->saveAs(new_file_name, nvars, nobss, varindexes, obsindexes);
- } catch (int errcode) {
- error_R("can not save data to file %s\n", new_file_name.c_str());
- return R_NilValue;
- }
-
- SEXP ret;
- PROTECT(ret = allocVector(LGLSXP, 1));
- LOGICAL(ret)[0] = TRUE;
- UNPROTECT(1);
- return ret;
-}
-
-// subroutine dqrls(x,n,p,y,ny,tol,b,rsd,qty,k,jpvt,qraux,work)
-// integer n,p,ny,k,jpvt(p)
-// double precision x(n,p),y(n,ny),tol,b(p,ny),rsd(n,ny),
-// . qty(n,ny),qraux(p),work(p)
-
-void CPP_dqrls(double * x, int * n, int * p, double * y, int * ny,
- double * tol, double * b, double * rsd, double * qty, int * k,
- int * jpvt, double * qraux, double * work) {
- dqrls_(x, n, p, y, ny, tol, b, rsd, qty, k, jpvt, qraux, work);
-}
-/**
- void apply_CPP_dqrls(
- int * conn,
- double * output,
- double * x, int * n, int * p,
- double * y, int * ny,
- double * tol,
- double * b,
- double * rsd, double * qty, int * k,
- int * jpvt, double * qraux, double * work
- )
- {
- double rss, resvar;
- int info;
- fr_type tmp = floatFileMatrix[0].data_type;
- double * saveX = new (std::nothrow) double [(*n)*(*p)];
- if (!saveX) error("cannot get mem for 'saveX'\n");
- double * v = new (std::nothrow) double [(*p)*(*p)];
- if (!v) error("cannot get mem for 'v'\n");
- double * se = new (std::nothrow) double [(*p)];
- if (!se) error("cannot get mem for 'se'\n");
- unsigned long int offset = (*n)*((*p)-1);
- for (int obs=0;obs<((*n)*(*p));obs++) saveX[obs]=x[obs];
- for (int var=0;var<(int)tmp.nvariables;var++) {
-
- for (unsigned int obs=0;obs<tmp.nobservations;obs++) x[obs]=saveX[obs];
-
- read_variable_float_FileMatrix(&var,
- (x+offset),conn);
-
- dqrls_(x,n,p,y,ny,tol,b,rsd,qty,k,jpvt,qraux,work);
- ch2inv_(x,n,p,v,&info);
-
- rss = 0;
- for (unsigned int i=0;i<tmp.nobservations;i++) rss+=rsd[i]*rsd[i];
- resvar = rss/((double)(n-p));
- for (int i=0;i<(*p);i++) se[i] = v[i*(*p)+i]*resvar;
-
- output[var] = b[1];
- }
- delete [] saveX;
- delete [] v;
- delete [] se;
- }
- **/
-//
-// iterator staff
-//
-
-// Product function + wrapper
-double prod(double *mydata, unsigned int size) {
- double prodtotal = mydata[0];
- for (register unsigned int i = 1; i < size; i++) {
- prodtotal *= mydata[i];
- }
- return prodtotal;
-}
-void prodWrapper(double *indata, unsigned long int indataSize, double *outdata,
- unsigned long int &outdataNcol, unsigned long int &outdataNrow,
- unsigned int narg, double *argList) {
- if (indata) {
- outdata[0] = prod(indata, indataSize);
- }
- outdataNcol = 1;
- outdataNrow = 1;
-}
-
-// Sum function + wrapper
-double sum(double *mydata, unsigned int size) {
- double sumtotal = 0.;
- for (register unsigned int i = 0; i < size; i++) {
- sumtotal += mydata[i];
- }
- return sumtotal;
-}
-void sumWrapper(double *indata, unsigned long int indataSize, double *outdata,
- unsigned long int &outdataNcol, unsigned long int &outdataNrow,
- unsigned int narg, double *argList) {
- if (indata) {
- outdata[0] = sum(indata, indataSize);
- }
- outdataNcol = 1;
- outdataNrow = 1;
-}
-
-// Sum of powers function + wrapper
-double sumpower(double *mydata, unsigned int size, int power) {
- double sumpowertotal = 0.;
- for (register unsigned int i = 0; i < size; i++) {
- sumpowertotal += pow(mydata[i], power);
- }
- return sumpowertotal;
-}
-void sumpowerWrapper(double *indata, unsigned long int indataSize,
- double *outdata, unsigned long int &outdataNcol,
- unsigned long int &outdataNrow, unsigned int narg, double *argList) {
- if (indata) {
- int power = static_cast<int> (argList[0]);
- outdata[0] = sumpower(indata, indataSize, power);
- }
- outdataNcol = 1;
- outdataNrow = 1;
-}
-
-// databel_impute_prob_2_databel_mach_dose function + wrapper
-void databel_impute_prob_2_databel_mach_dose(double *mydata, unsigned int size,
- double *outdata, int power) {
- unsigned int j = 0;
- for (unsigned int obs = 0; obs < size; obs += 3) {
- outdata[j++] = 2. * mydata[obs + 2] + mydata[obs + 1];
- }
-}
-void databel_impute_prob_2_databel_mach_doseWrapper(double *indata,
- unsigned long int indataSize, double *outdata,
- unsigned long int &outdataNcol, unsigned long int &outdataNrow,
- unsigned int narg, double *argList) {
- if (indata) {
- int power = static_cast<int> (argList[0]);
- databel_impute_prob_2_databel_mach_dose(indata, indataSize, outdata, power);
- }
- outdataNcol = 1;
- outdataNrow = indataSize / 3;
-}
-
-// databel_impute_prob_2_databel_mach_prob function + wrapper
-void databel_impute_prob_2_databel_mach_prob(double *mydata, unsigned int size,
- double *outdata, int power) {
- unsigned int j = 0;
- for (unsigned int obs = 0; obs < size; obs += 3) {
- outdata[j] = mydata[obs + 1];
- outdata[size + j] = mydata[obs + 2]; // the two columns are put behind eachother
- j++;
- }
-}
-void databel_impute_prob_2_databel_mach_probWrapper(double *indata,
- unsigned long int indataSize, double *outdata,
- unsigned long int &outdataNcol, unsigned long int &outdataNrow,
- unsigned int narg, double *argList) {
- if (indata) {
- int power = static_cast<int> (argList[0]);
- databel_impute_prob_2_databel_mach_prob(indata, indataSize, outdata, power);
- }
- outdataNcol = 2;
- outdataNrow = indataSize / 3;
-}
-
-MethodConvStruct methodConverter[] = { { "sum", sumWrapper }, { "prod",
- prodWrapper }, { "sumpower", sumpowerWrapper }, {
- "databel_impute_prob_2_databel_mach_dose",
- databel_impute_prob_2_databel_mach_doseWrapper }, {
- "databel_impute_prob_2_databel_mach_prob",
- databel_impute_prob_2_databel_mach_probWrapper } };
-
-bool getDataNew(AbstractMatrix *inData, double *outData, unsigned int datasize,
- unsigned int index, unsigned int margin) {
- if (margin == 2) { // column-wise
- try {
- inData->readVariableAs(index, outData);
- } catch (int errcode) {
- return false;
- }
- } else { // row-wise
- double dTmp;
- for (int j = 0; j < datasize; j++) {
- inData->readElementAs(j, index, dTmp);
- outData[j] = dTmp;
- }
- }
-}
-
-void getDataOld(char const *inData, double *outData, unsigned int datasize,
- unsigned int index, unsigned int margin) {
- int i, j, iTmp;
- char str;
- int msk[4] = { 192, 48, 12, 3 };
- int ofs[4] = { 6, 4, 2, 0 };
- int nbytes; // the length of a row
- if ((datasize % 4) == 0) {
- nbytes = datasize / 4;
- } else {
- nbytes = ceil(1. * datasize / 4.);
- }
-
- if (margin == 1) { // row-wise
- int offset = index * nbytes;
- for (i = offset; i < offset + nbytes; i++) {
- str = inData[i];
- for (j = 0; j < 4; j++) {
- iTmp = str & msk[j];
- iTmp >>= ofs[j];
- outData[i] = static_cast<double> (iTmp);
- }
- }
- } else { // column-wise
- int insloc = 0;
- j = index % 4;
- for (i = index; i < datasize * nbytes; i += nbytes, insloc++) {
- str = inData[i];
- iTmp = str & msk[j];
- iTmp >>= ofs[j];
- outData[insloc] = static_cast<double> (iTmp);
- }
- }
-}
-
-SEXP iterator(SEXP data, SEXP nrids, SEXP nrobs, SEXP method, SEXP outputtype,
- SEXP margin, SEXP nrarg, ...) {
-
- // Check and get the data supplied
- unsigned int nids, nobs;
- bool newtype = true;
- AbstractMatrix *pDataNew;
- char const *pDataOld;
-
- if (TYPEOF(data) == EXTPTRSXP) {
- CHECK_PTR(data);
- pDataNew = (AbstractMatrix*) R_ExternalPtrAddr(data);
- if (pDataNew == NULL) {
- error_R("Pointer to data is NULL\n");
- return R_NilValue;
- }
- nids = pDataNew->getNumVariables();
- nobs = pDataNew->getNumObservations();
- } else if (TYPEOF(data) == STRSXP) {
- newtype = false;
- pDataOld = CHAR(data);
- nids = INTEGER(nrids)[0];
- nobs = INTEGER(nrobs)[0];
- } else {
- error_R("Incorrect data type\n");
- return R_NilValue;
- }
-
- // Find out and check the function supplied
- char const *methodName = CHAR(STRING_ELT(method, 0));
- myfunctiontype *pMethod = NULL;
- for (unsigned int i = 0; i < sizeof(methodConverter); i++) {
- if (strcmp(methodConverter[i].methodName, methodName) == 0) {
- pMethod = methodConverter[i].functionPtr;
- break;
- }
- }
- if (pMethod == NULL) {
- error_R("No (valid) function supplied\n");
- return R_NilValue;
- }
-
- // Find out the desired output type (file) supplied
- bool fv = true;
- char const *outputName = CHAR(STRING_ELT(outputtype, 0));
- if (strcmp(outputName, "R") == 0) {
- fv = false;
- }
-
- // Get the margin supplied
- int mar = INTEGER(margin)[0];
- if (mar < 1 || mar > 2) {
- error_R("No (valid) margin supplied\n");
- return R_NilValue;
- }
-
- // Get the nr. of additional arguments supplied
- unsigned int narg = INTEGER(nrarg)[0];
-
- // Get the additional parameters supplied, if any, and cast them to doubles
- unsigned int argListSize = narg > 0 ? narg : 1;
- double argList[argListSize];
- va_list ap;
- va_start(ap, nrarg); // nrarg is last known parameter
- for (unsigned register int i = 0; i < narg; i++) {
- SEXP tmpPointer = va_arg(ap, SEXP);
- argList[i] = REAL(tmpPointer)[0];
- }
- va_end(ap);
-
- // The actual data handling part:
-
- unsigned long int ncol, nrow;
- if (mar == 1) { // row-wise
- ncol = nobs;
- nrow = nids;
- } else { // column-wise (default)
- ncol = nids;
- nrow = nobs;
- }
-
- unsigned long int nrow_new, ncol_multi;
-
- // Get the dimensions of the output the function of our choosing will be giving
- pMethod(0, nrow, 0, ncol_multi, nrow_new, narg, argList);
- // Allocate vector
- // Start output SEXP for passing to R
- // Even when the output is put into a filevector, we still return an (empty) SEXP
- SEXP out;
- // Declare output filevector (whether we'll be using it or not)
- AbstractMatrix * outFV;
- if (!fv) {
- // Initialize output matrix once real number of rows is known
- // ASSUMPTION: nrow_new remains constant over calls to function wrapper
- PROTECT(out = allocVector(REALSXP, (R_len_t)(ncol * ncol_multi
- * nrow_new)));
- } else {
- // To avoid null pointer error, make output SEXP to return (although it will be empty)
- PROTECT(out = allocVector(REALSXP, (R_len_t) 1));
- try {
- initialize_empty_file(outputName, ncol * ncol_multi,
- nrow_new, FLOAT, false);
- } catch (int errcode) {
- error_R("Failed in iterator - call - initialize_empty_file");
- return R_NilValue;
- }
- try {
- outFV = new filevector(outputName, 64);
- } catch (int errcode) {
- error_R("Cannot initialize output file\n");
- return R_NilValue;
- }
- }
-
- double internal_data[nrow];
- double out_data[nrow_new * ncol_multi];
-
- // Read in data and apply function (row- or column-wise)
- for (unsigned long int i = 0; i < ncol; i++) {
-
- // Get row or column
- if (newtype) {
- getDataNew(pDataNew, internal_data, nrow, i, mar);
- } else {
- getDataOld(pDataOld, internal_data, nrow, i, mar);
- }
-
- // Apply function of choosing
- pMethod(internal_data, nrow, out_data, ncol_multi, nrow_new, narg,
- argList);
-
- // Write analyzed data to R vector or filevector
- for (unsigned long int j = 0; j < ncol_multi; j++) {
- if (!fv) {
- for (unsigned long int k = 0; k < nrow_new; k++) {
- // Add to output SEXP
- REAL(out)[(i * ncol_multi + j) * nrow_new + k]
- = out_data[k];
- }
- } else {
- outFV->writeVariableAs(i * ncol_multi + j, out_data);
- }
- }
- }
-
- if (!fv) {
- UNPROTECT(1);
- } else {
- delete outFV;
- }
-
- return out;
-}
-
-} // end extern
Deleted: pkg/TestABEL/src/Rstaff.h
===================================================================
--- pkg/TestABEL/src/Rstaff.h 2013-11-04 08:35:37 UTC (rev 1358)
+++ pkg/TestABEL/src/Rstaff.h 2013-11-04 10:03:00 UTC (rev 1359)
@@ -1,67 +0,0 @@
-#ifndef __RSTAFF_H__
-#define __RSTAFF_H__
-
-#include <string>
-#include <cstring>
-#include <R.h>
-
-#include "fvlib/const.h"
-#include "fvlib/convert_util.h"
-#include "fvlib/convert_util.cpp"
-#include "fvlib/AbstractMatrix.h"
-#include "fvlib/AbstractMatrix.cpp"
-#include "fvlib/filevector.h"
-#include "fvlib/filevector.cpp"
-#include "fvlib/frerror.h"
-#include "fvlib/frerror.cpp"
-#include "fvlib/frutil.h"
-#include "fvlib/frutil.cpp"
-#include "fvlib/frversion.h"
-#include "fvlib/Transposer.h"
-#include "fvlib/Transposer.cpp"
-#include "fvlib/Logger.h"
-#include "fvlib/Logger.cpp"
-#include "fvlib/CastUtils.h"
-#include "fvlib/CastUtils.cpp"
-
-#include "dautil.h"
-
-#include <stdarg.h>
-
-// maximal number of file-matrices allowed
-// #define MAX_FM_OBJECTS 10
-
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-static SEXP type_tag;
-
-/* macro to check if ptr valid */
-#define CHECK_PTR(s) do { \
- if (TYPEOF(s) != EXTPTRSXP) \
- Rprintf("External pointer not valid - type not EXTPTRSXP but %s\n", TYPEOF(s)); \
- /*if (R_ExternalPtrTag(s) != type_tag) \
- Rprintf("External pointer not valid - %s not equal to %s\n", R_ExternalPtrTag(s), type_tag);*/ \
-} while (0)
-
-/* Install the type tag */
-SEXP AbstractMatrix_init(void)
-{
- type_tag = install("AbstractMatrix");
- return R_NilValue;
-}
-
-#ifdef __cplusplus
-}
-#endif
-
-typedef void (myfunctiontype)(double *, unsigned long int,
- double *, unsigned long int &, unsigned long int &, unsigned int, double *);
-
-typedef struct MethodConvStruct {
- char *methodName;
- myfunctiontype *functionPtr;
-};
-
-#endif
Copied: pkg/TestABEL/src/Rstuff.cpp (from rev 1358, pkg/TestABEL/src/Rstaff.cpp)
===================================================================
--- pkg/TestABEL/src/Rstuff.cpp (rev 0)
+++ pkg/TestABEL/src/Rstuff.cpp 2013-11-04 10:03:00 UTC (rev 1359)
@@ -0,0 +1,906 @@
+#include <math.h>
+
+#include "Rstuff.h"
+
+// most be included after c++ headers!
+#include <stdio.h>
+#include <Rdefines.h>
+
+extern "C" {
+// .Fortran("dqrls",
+// qr = x, n = n, p = p,
+// y = tra, ny = ny,
+// tol = as.double(tol),
+// coefficients = mat.or.vec(p, ny),
+// residuals = y, effects = y, rank = integer(1L),
+// pivot = 1L:p, qraux = double(p), work = double(2*p),
+// PACKAGE="base")$coefficients[2]
+
+void dqrls_(double*, int*, int*, double*, int*, double*, double*, double*,
+ double*, int*, int*, double*, double*);
+}
+
+extern "C" {
+// .Fortran("ch2inv", x = x, nr, size, v = matrix(0, nrow = size,
+// ncol = size), info = integer(1L), DUP = FALSE, PACKAGE = "base")
+void ch2inv_(double*, int*, int*, double*, int*);
+}
+
+extern "C" {
+
+SEXP get_nvars_R(SEXP s) {
+ CHECK_PTR(s);
+
+ AbstractMatrix * p = (AbstractMatrix*) R_ExternalPtrAddr(s);
+
+ if (p == NULL) {
+ error_R("pointer is NULL\n");
+ return R_NilValue;
+ }
+
+ SEXP out;
+ PROTECT(out = allocVector(INTSXP, 1));
+ unsigned int nvars = 0;
+
+ try {
+ nvars = (unsigned int) p->getNumVariables();
+ } catch (int errcode) {
+ nvars = 0;
+ }
+
+ if (nvars <= 0) {
+ out = R_NilValue;
+ } else {
+ INTEGER(out)[0] = nvars;
+ }
+ UNPROTECT(1);
+ return out;
+}
+
+SEXP get_nobs_R(SEXP s) {
+ CHECK_PTR(s);
+
+ AbstractMatrix * p = (AbstractMatrix*) R_ExternalPtrAddr(s);
+
+ if (p == NULL) {
+ error_R("pointer is NULL\n");
+ return R_NilValue;
+ }
+
+ SEXP out;
+ PROTECT(out = allocVector(INTSXP, 1));
+ unsigned int nobss = 0;
+
+ try {
+ nobss = (unsigned int) p->getNumObservations();
+ } catch (int errcode) {
+ nobss = 0;
+ }
+
+ if (nobss <= 0) {
+ out = R_NilValue;
+ } else {
+ INTEGER(out)[0] = nobss;
+ }
+ UNPROTECT(1);
+ return out;
+}
+
+SEXP get_all_varnames_R(SEXP s) {
+ CHECK_PTR(s);
+
+ AbstractMatrix * p = (AbstractMatrix*) R_ExternalPtrAddr(s);
+
+ if (p == NULL) {
+ error_R("pointer is NULL\n");
+ return R_NilValue;
+ }
+
+ R_len_t nvars = (R_len_t) 0;
+
+ try {
+ nvars = p->getNumVariables();
+ } catch (int errcode) {
+ return R_NilValue;
+ }
+
+ fixedchar tmp;
+ SEXP ret;
+ PROTECT(ret = allocVector(STRSXP, (R_len_t) nvars));
+
+ try {
+ for (unsigned long int i = 0; i < nvars; i++) {
+ tmp = p->readVariableName(i);
+ SET_STRING_ELT(ret, i, mkChar(tmp.name));
+ }
+ } catch (int errcode) {
+ error_R("something went terribly wrong in get_all_varnames_R\n");
+ UNPROTECT(1);
+ return ret;
+ }
+ UNPROTECT(1);
+ return ret;
+}
+
+// !!!
+SEXP set_all_varnames_R(SEXP s, SEXP names) {
+ CHECK_PTR(s);
+
+ AbstractMatrix * p = (AbstractMatrix*) R_ExternalPtrAddr(s);
+
+ if (p == NULL) {
+ error_R("pointer is NULL\n");
+ return R_NilValue;
+ }
+
+ R_len_t nvars = (R_len_t) 0;
+
+ try {
+ nvars = p->getNumVariables();
+ } catch (int errcode) {
+ error_R("can not p->getNumVariables()\n");
+ return R_NilValue;
+ }
+
+ // check that length of SEXP names is the same!!!
+
+ for (unsigned long int i = 0; i < nvars; i++) {
+ std::string varname = CHAR(STRING_ELT(names, i));
+ try {
+ p->writeVariableName(i, fixedchar(varname));
+ } catch (int errcode) {
+ error_R("can not set variable name for variable %ul\n", i);
+ return R_NilValue;
+ }
+ }
+
+ SEXP ret;
+ PROTECT(ret = allocVector(LGLSXP, 1));
+ LOGICAL(ret)[0] = TRUE;
+ UNPROTECT(1);
+ return ret;
+
+}
+
+SEXP get_all_obsnames_R(SEXP s) {
+ CHECK_PTR(s);
+
+ AbstractMatrix * p = (AbstractMatrix*) R_ExternalPtrAddr(s);
+
+ if (p == NULL) {
+ error_R("pointer is NULL\n");
+ return R_NilValue;
+ }
+
+ R_len_t nobss = (R_len_t) 0;
+
+ try {
+ nobss = p->getNumObservations();
+ } catch (int errcode) {
+ return R_NilValue;
+ }
+
+ fixedchar tmp;
+ SEXP ret;
+ PROTECT(ret = allocVector(STRSXP, (R_len_t) nobss));
+
+ try {
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/genabel -r 1359
More information about the Genabel-commits
mailing list