void* put_jmp_hook_with_regs(void* function_address, void* fake_function, int instructions_size) {
typedef unsigned char uchar;
uchar* p_copy = (uchar*)malloc(0x1000);
uchar* p = (uchar*)function_address;
uchar* p_regs = (uchar*)malloc(0x1000);
unprotect(p_copy);
unprotect(p);
unprotect(p_regs);
memcpy(p_copy, p, instructions_size);
p_regs[0] = 0x54; // push esp
p_regs[1] = 0x51; // push ecx
p_regs[2] = 0x52; // push edx
p_regs[3] = 0x50; // push eax
p_regs[4] = 0xb8; // movl %eax, ???????
p_regs[9] = 0xff; // call *%eax
p_regs[10] = 0xd0; //
p_regs[11] = 0x83; // add $0x10, %esp
p_regs[12] = 0xc4; //
p_regs[13] = 0x10; //
p_regs[14] = 0xc3; // ret
*((void**)(p_regs+5))=fake_function;
inconditional_jump(p, p_regs);
inconditional_jump(p_copy+instructions_size, p+instructions_size);
return (void*)p_copy;
}
void* InterceptFunction(void* voidptr_AddressOfDetouredFunction, unsigned long uslng_CopyLength, void* voidptr_AddressOfDetourFunction)
{
DATATYPE_ADDRESS Relocation;
//printf("copy length: %ld\n", uslng_CopyLength);
//printf("MIN_REQUIRED_FOR_DETOUR : %d\n", MIN_REQUIRED_FOR_DETOUR );
void* voidptr_BackupForOriginalFunction = malloc(uslng_CopyLength + MIN_REQUIRED_FOR_DETOUR);
//printf("Sizeof Backuppointer %ld\n", sizeof(voidptr_BackupForOriginalFunction));
//printf("Sizeof AddrDetouredFunction %d\n", sizeof(voidptr_AddressOfDetouredFunction));
// printf("Here 1\n");
memcpy(voidptr_BackupForOriginalFunction, voidptr_AddressOfDetourFunction, uslng_CopyLength);
// printf("Here 2\n");
if (OPCODE_NOT_DEFINED)
{
printf("Error: OP-Code not defined\n.");
exit(EXIT_FAILURE);
}
// printf("JMP_OPCODE 0x%X\n", JMP_OPCODE);
// printf("OPCODE_LENGTH %d\n", OPCODE_LENGTH);
// printf("MIN_REQUIRED_FOR_DETOUR %d\n", MIN_REQUIRED_FOR_DETOUR);
memset(reinterpret_cast<void*> (reinterpret_cast<unsigned long> (voidptr_BackupForOriginalFunction)+uslng_CopyLength),
JMP_OPCODE, OPCODE_LENGTH);
// printf("Here 3\n");
Relocation = static_cast<DATATYPE_ADDRESS> (reinterpret_cast<unsigned long> (voidptr_AddressOfDetouredFunction)
-(reinterpret_cast<unsigned long> (voidptr_BackupForOriginalFunction)
+MIN_REQUIRED_FOR_DETOUR));
// printf("Here 4\n");
memcpy(reinterpret_cast<void*> (reinterpret_cast<unsigned long> (voidptr_BackupForOriginalFunction)
+uslng_CopyLength + OPCODE_LENGTH), &Relocation, ADDRESS_LENGTH);
// printf("Here 5\n");
int retUnprotect = unprotect(FuncGetPage(reinterpret_cast <unsigned long> (voidptr_AddressOfDetouredFunction)), uslngPageSize);
printf("Patch unprotect: %d\n", retUnprotect);
memset(voidptr_AddressOfDetouredFunction, JMP_OPCODE, OPCODE_LENGTH);
Relocation = static_cast<DATATYPE_ADDRESS> (reinterpret_cast<unsigned long> (voidptr_AddressOfDetourFunction)
-(reinterpret_cast<unsigned long> (voidptr_AddressOfDetouredFunction)
+MIN_REQUIRED_FOR_DETOUR));
memcpy(reinterpret_cast<void*> (reinterpret_cast<unsigned long> (voidptr_AddressOfDetouredFunction)
+OPCODE_LENGTH), &Relocation, ADDRESS_LENGTH);
int retReprotect = unprotect(FuncGetPage(reinterpret_cast <unsigned long> (voidptr_BackupForOriginalFunction)), uslngPageSize);
printf("Patch reprotect: %d\n", retReprotect);
return voidptr_BackupForOriginalFunction;
}
void mirrorup( TCHAR* fromPath, TCHAR* toPath, bool reverseClean = false ) {
if ( !reverseClean ) mirrorup( toPath, fromPath, true );
WIN32_FIND_DATA fromFindData, toFindData;
TCHAR fromMask[ BUF_LEN ]; bool ok;
_stprintf( fromMask, _T("%s\\*"), fromPath );
HANDLE fromFind = FindFirstFile( fromMask, &fromFindData );
if ( fromFind == INVALID_HANDLE_VALUE ) return;
do {
if ( !_tcscmp( fromFindData.cFileName, _T(".")) ||
!_tcscmp( fromFindData.cFileName, _T(".."))) continue;
bool isDir = ( fromFindData.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY );
TCHAR fromFileName[ BUF_LEN ], toFileName[ BUF_LEN ];
_stprintf( fromFileName, _T("%s\\%s"), fromPath, fromFindData.cFileName );
_stprintf( toFileName, _T("%s\\%s"), toPath, fromFindData.cFileName );
HANDLE toFind = FindFirstFile( toFileName, &toFindData );
bool toFound = ( toFind != INVALID_HANDLE_VALUE );
if ( reverseClean ) {
if ( isDir ) mirrorup( fromFileName, toFileName, reverseClean );
if ( !toFound ) {
ok = unprotect( fromFileName );
if ( !isDir ) ok = ok && DeleteFile( fromFileName );
if ( ok ) okCount++; else errCount++;
_tprintf( _T("%s) delete %s\n"), ( ok? _T("+") : _T("-")), fromFileName );
}
} else { // not reverseClean
if ( !toFound || !isDir && (
fromFindData.nFileSizeHigh != toFindData.nFileSizeHigh ||
fromFindData.nFileSizeLow != toFindData.nFileSizeLow ||
CompareFileTime( &fromFindData.ftLastWriteTime,
&toFindData.ftLastWriteTime ))) {
if ( toFound ) unprotect( toFileName );
if ( ok = ( isDir ?
CreateDirectoryEx( fromFileName, toFileName, 0 ) :
CopyFile( fromFileName, toFileName, 0 )))
okCount++; else errCount++;
_tprintf( _T("%s) copy %s\n"), ( ok? _T("+") : _T("-")), fromFileName );
}
if ( isDir ) mirrorup( fromFileName, toFileName, reverseClean );
}
if ( toFound ) FindClose( toFind );
} while ( FindNextFile( fromFind, &fromFindData ));
FindClose( fromFind );
}
/* Compute A*X + Y for scalar a, vectors X and Y of length N.
* Y must be a big.matrix, X can be an R vector or big.matrix.
* The contents of Y are *replaced* by this routine and a reference
* to Y is returned.
*/
SEXP
daxpy_wrapper (SEXP N, SEXP A, SEXP X, SEXP Y, SEXP X_isBM)
{
SEXP ans, Tr;
double *pY;
double *pA = DOUBLE_DATA(A);
double *pX = make_double_ptr (X, X_isBM);
INT incx = 1;
INT incy = 1;
INT NN = (INT) * (DOUBLE_DATA (N));
PROTECT(ans = Y);
PROTECT(Tr = allocVector(LGLSXP, 1));
LOGICAL(Tr)[0] = 1;
pY = make_double_ptr (Y, Tr);
/* An example of an alternate C-blas interface (e.g., ACML) */
#ifdef CBLAS
daxpy_ (NN, pA, pX, incx, pY, incy);
#elif REFBLAS
/* Standard Fortran interface without underscoring */
int8_daxpy (&NN, pA, pX, &incx, pY, &incy);
#else
/* Standard Fortran interface from R's blas */
daxpy_ (&NN, pA, pX, &incx, pY, &incy);
#endif
unprotect(2);
return ans;
}
bool NamedSearchParser::endElement( const QString&, const QString&, const QString &qName )
{
if(qName == "name")
namedSearch.name = unprotect(buffer.trimmed());
else if (qName == "count")
namedSearch.count = unprotect(buffer.trimmed()).toInt();
else if (qName == "type")
namedSearch.type = unprotect(buffer.trimmed()).toInt();
else if (qName == "text")
namedSearch.text = unprotect(buffer.trimmed());
else if(qName == "NamedSearch") {
result.append(namedSearch);
}
return true;
}
ghw_error_e GhwAllocatorImpl::dump(u32 level )
{
protect();
LOGD("GhwAllocatorImpl Static Counters %d %d %d\n",GhwAllocatorImpl::count,GhwMemBlock::count,GhwAllocatorDevice::count);
u32 maxFree = 0, totalFree = 0;
GhwMemBlockNode* node = mList.getHead();
while(node) {
totalFree += node->get()->getFreeSize();
u32 blockMax = node->get()->getMaxFreeSize();
if(blockMax > maxFree) maxFree = blockMax;
node = node->getNext();
}
LOGD("GhwAllocatorImpl[%x] totalDeviceAllocSize[%d] totalFree[%d] maxFree[%d] in numSlabs[%d]\n",
this,mTotalAllocSize,totalFree,maxFree,mList.getCount());
if (level) {
level--;
GhwMemBlockNode* node = mList.getHead();
while(node) {
node->get()->dump(level);
node = node->getNext();
}
}
unprotect();
return GHW_ERROR_NONE;
}
void* put_jmp_hook(void* function_address, void* fake_function, int instructions_size) {
typedef unsigned char uchar;
uchar* p_copy = (uchar*)malloc(0x1000);
uchar* p = (uchar*)function_address;
unprotect(p_copy);
unprotect(p);
memcpy(p_copy, p, instructions_size);
inconditional_jump(p, fake_function);
inconditional_jump(p_copy+instructions_size, p+instructions_size);
return (void*)p_copy;
}
static void
zero_reseau(void)
{
if (neurbase!=NIL) {
#ifndef NONEURTYPE
int i;
for (i=0; i<neurmax; i++)
set_neurtype(neuraddress[i], NULL, NULL);
#endif
free((char *)neurbase);
neurbase = NIL;
neurnombre = neurmax = 0;
}
if (synbase!=NIL) {
free((char *)synbase);
synbase = NIL;
synnombre = synmax = 0;
}
#ifdef ITERATIVE
if (weightbase!=NIL) {
weightbase = NIL;
weightnombre = weightmax = 0;
}
if (w_matrix != NIL) {
unprotect(w_matrix);
if (w_matrix_var)
var_SET(w_matrix_var,NIL);
}
#endif
if (neuraddress!=NIL)
free((char *)neuraddress);
if (netconvert != NIL)
free((char *)netconvert);
}
PRIVATE void run_finalize_queue(void) {
OBJ *x;
x = allocmem(sizeof(OBJ));
*x = NULL;
protect(x);
wait_for_finalize();
*x = next_to_finalize();
while (*x != NULL) {
if (OVECTORP(*x)) {
finalize_ovector((OVECTOR) (*x));
} else {
/* %%% NOTE here's where objects should be handed to user level
to finalize. %%% */
*x = NULL; /* GC's the object */
}
*x = next_to_finalize();
}
unprotect(x);
freemem(x);
}
RSTypeRef * RSAutoreleaseZone::RSAutoreleasePage::add(RSTypeRef obj)
{
assert(!full());
unprotect();
*next++ = obj;
protect();
return next-1;
}
void unpatchfunc(void* patched_function, unsigned char* original_function, unsigned long uslng_DetourLength)
{
//DWORD dw_OldProtect;
//VirtualProtect(patched_function, uslng_DetourLength, PAGE_EXECUTE_READWRITE, &dw_OldProtect);
int retUnprotect = unprotect(FuncGetPage(reinterpret_cast<unsigned long>(patched_function)), uslngPageSize);
printf("Unpatch: unprotect: %d\n", retUnprotect);
unsigned int intIndex;
for (intIndex = 0; intIndex < uslng_DetourLength; ++intIndex)
*((unsigned char*)patched_function + intIndex) = *(original_function + intIndex);
//VirtualProtect(patched_function, uslng_DetourLength, dw_OldProtect, &dw_OldProtect);
int retReprotect = unprotect(FuncGetPage(reinterpret_cast<unsigned long>(patched_function)), uslngPageSize);
printf("Unpatch reprotect: %d\n", retReprotect);
if (original_function != NULL)
free((void*)original_function);
}
RSAutoreleaseZone::RSAutoreleasePage::~RSAutoreleasePage()
{
selfCheck();
unprotect();
assert(empty());
// Not recursive: we don't want to blow out the stack
// if a thread accumulates a stupendous amount of garbage
assert(!child);
}
int
generic_spi_access_done(void)
{
generic_i2c_deassert_cs();
ar7100_reg_wr_nf(GENERIC_SPI_FS, 0);
unprotect();
return 0;
}
GhwMemHandle* GhwAllocatorImpl::alloc(u32 size, u32 alignment )
{
if((alignment > 12) || (size == 0)) return NULL;
protect();
if(alignment < mAlignment) alignment = mAlignment;
GhwMemBlockNode* node = mList.getHead();
while(node) {
GhwMemBlock* handle = node->get();
GhwMemHandle* mem = handle->alloc(size,alignment);
if(mem) {
unprotect();
return mem;
}
node = node->getNext();
}
u32 alignsize = size ;
if(mMode != GHW_MEM_ALLOC_SIMPLE) {
if(alignsize > mSlabSize) {
u32 factor = (alignsize+mSlabSize-1)/mSlabSize;
alignsize = factor*mSlabSize;
}
else {
alignsize = mSlabSize;
}
}
GhwMemBlock* handle = new GhwMemBlock(this,mDevice,alignsize);
if(handle && ( handle->initCheck() == 0)) {
mTotalAllocSize += alignsize;
handle->setNode(mList.addElement(handle,mList.getCount()));
GhwMemHandle* mem = handle->alloc(size,alignment);
handle->release();
unprotect();
return mem;
}
unprotect();
return NULL;
}
ghw_error_e GhwAllocatorImpl::phys2virt(u32 ipa_addr, void*& virt_addr)
{
protect();
unsigned int addrin = (unsigned int) ipa_addr;
GhwMemBlockNode* node = mList.getHead();
while(node) {
u32 ipa,size;
unsigned char* addr;
node->get()->lock(ipa,(void*&)addr,size);
if((addrin > ipa) && (addrin < (ipa +size)) ) {
virt_addr = (void*) ( addr + ((unsigned int) (addrin-ipa)));
node->get()->unlock();
unprotect();
return GHW_ERROR_NONE;
}
node->get()->unlock();
node = node->getNext();
}
unprotect();
return GHW_ERROR_FAIL;
}
/* Wrappers for miscellaneous BLAS and LAPACK routines. */
SEXP
dgemm_wrapper (SEXP TRANSA, SEXP TRANSB, SEXP M, SEXP N, SEXP K,
SEXP ALPHA, SEXP A, SEXP LDA, SEXP B, SEXP LDB, SEXP BETA,
SEXP C, SEXP LDC, SEXP A_isBM, SEXP B_isBM, SEXP C_isBM,
SEXP C_offset)
{
long j = *(DOUBLE_DATA (C_offset));
double *pA = make_double_ptr (A, A_isBM);
double *pB = make_double_ptr (B, B_isBM);
double *pC;
SEXP ans;
INT MM = (INT) * (DOUBLE_DATA (M));
INT NN = (INT) * (DOUBLE_DATA (N));
INT KK = (INT) * (DOUBLE_DATA (K));
INT LDAA = (INT) * (DOUBLE_DATA (LDA));
INT LDBB = (INT) * (DOUBLE_DATA (LDB));
INT LDCC = (INT) * (DOUBLE_DATA (LDC));
if(LOGICAL_VALUE(C_isBM) == (Rboolean) TRUE)
{
/* Return results in a big matrix */
pC = make_double_ptr (C, C_isBM) + j;
PROTECT(ans = C);
} else {
/* Allocate an output R matrix and return results there
XXX Add check for size of MM and NN XXX
*/
PROTECT(ans = allocMatrix(REALSXP, (int)MM, (int)NN));
pC = NUMERIC_DATA(ans);
}
/* An example of an alternate C-blas interface (e.g., ACML) */
#ifdef CBLAS
dgemm (*((char *) CHARACTER_VALUE (TRANSA)),
*((char *) CHARACTER_VALUE (TRANSB)),
MM, NN, KK, *(NUMERIC_DATA (ALPHA)), pA, LDAA, pB,
LDBB, *(NUMERIC_DATA (BETA)), pC, LDCC);
#elif REFBLAS
/* Standard Fortran interface without underscoring */
int8_dgemm ((char *) CHARACTER_VALUE (TRANSA),
(char *) CHARACTER_VALUE (TRANSB),
&MM, &NN, &KK, NUMERIC_DATA (ALPHA), pA, &LDAA, pB,
&LDBB, NUMERIC_DATA (BETA), pC, &LDCC);
#else
/* Standard Fortran interface from R's blas */
dgemm_ ((char *) CHARACTER_VALUE (TRANSA),
(char *) CHARACTER_VALUE (TRANSB),
&MM, &NN, &KK, NUMERIC_DATA (ALPHA), pA, &LDAA, pB,
&LDBB, NUMERIC_DATA (BETA), pC, &LDCC);
#endif
unprotect(1);
return ans;
}
int handle_errors_excp(char *err_str, int err_code)
{
char *tmp;
tmp = NULL;
ft_putstr_fd("42sh: ", 2);
if (err_code == 1)
ft_putendl_fd("Syntax error near unexpected token \'newline\'", 2);
else if (err_code == 2)
{
tmp = ft_strdup(err_str);
tmp = unprotect(tmp);
ft_putstr_fd(tmp, 2);
ft_putendl_fd(": event not found", 2);
ft_strdel(&tmp);
}
return (0);
}
int
generic_i2c_read_gpio(unsigned short *d)
{
int errcnt;
unsigned char b[2];
protect();
errcnt = generic_i2c_raw_read_bytes_from_addr(GENERIC_I2C_IO_EXP, b, sizeof(b));
if (errcnt == 0) {
*d = b[1]<<8 | b[0];
generic_i2c_shadow_of_gpio = *d;
}
else
printk("%s failed: %d %04x\n", __FUNCTION__, errcnt, *d );
unprotect();
return errcnt;
}
GhwAllocatorImpl::~GhwAllocatorImpl()
{
count--;
protect();
GhwMemBlockNode* node = mList.getHead();
while(node) {
node->get()->acquire();
mTotalAllocSize -= node->get()->getSize();
delete node->get();
mList.removeNode(node);
node = mList.getHead();
}
mSlabSize = 0 ;
mAlignment = 0 ;
mMode = 0 ;
mTotalAllocSize = 0 ;
unprotect();
}
int
generic_i2c_write_gpio(unsigned short d)
{
int errcnt;
unsigned char b[2];
b[0] = d;
b[1] = d>>8;
protect();
errcnt = generic_i2c_raw_write_bytes_to_addr(GENERIC_I2C_IO_EXP, b, sizeof(b));
if (errcnt == 0)
generic_i2c_shadow_of_gpio = d;
else
printk("%s failed: %d %04x\n", __FUNCTION__, errcnt, d );
unprotect();
return errcnt;
}
ghw_error_e GhwAllocatorImpl::reset()
{
protect();
GhwMemBlockNode* node = mList.getHead();
switch (mMode) {
case GHW_MEM_ALLOC_RETAIN_ALL:
{
while(node) {
node->get()->acquire();
node->get()->reset();
node->get()->release();
node = node->getNext();
}
break;
}
default:
{
while(node) {
if((mMode == GHW_MEM_ALLOC_RETAIN_ONE) && (mList.getCount() == 1)) {
node->get()->acquire();
node->get()->reset();
node->get()->release();
break;
}
node->get()->acquire();
mTotalAllocSize -= node->get()->getSize();
delete node->get();
mList.removeNode(node);
node = mList.getHead();
}
break;
}
}
unprotect();
return GHW_ERROR_NONE;
}
/* using thernau's habit: name a S object "charlie2" and the pointer
** to the contents of the object "charlie"; the latter is
** used in the computations
*/
SEXP netfastpinter2( SEXP efac2, SEXP edims2,
SEXP ecut2, SEXP expect2,
SEXP x2, SEXP y2,SEXP ys2, SEXP status2, SEXP times2, SEXP myprec2) {
int i,j,k,jfine;
int n,
edim,
ntime,
nprec;
double **x;
double *data2, *si, *sitt;
double **ecut, *etemp;
double hazard; /*cum hazard over an interval */
double thiscell,
time,
et2,
fyisi, /* fyisi and fyidlisi are the values in the finer division of the interval, ftime is the tiny time in those intervals */
fyidlisi,
fyidlisi2,
fyisi2,
ftime,
fthiscell,
fint,
sisum,
sisumtt,
lambdapi,
lambdapi2,
timestart;
int indx,
indx2;
double wt;
int *efac, *edims, *status;
double *expect, *y,*ys, *times, *myprec;
SEXP rlist, rlistnames;
/*my declarations*/
SEXP yidli2, dnisi2,yisi2,yidlisi2,yi2,dni2,dnisisq2,yisitt2,yidlisitt2,yidlisiw2;
double *yidli, *dnisi,*yisi,*yidlisi,*yi,*dni,*dnisisq, *yisitt,*yidlisitt,*yidlisiw;
/*
** copies of input arguments
*/
efac = INTEGER(efac2);
edims = INTEGER(edims2);
edim = LENGTH(edims2);
expect= REAL(expect2);
n = LENGTH(y2); /*number of individuals */
x = dmatrix(REAL(x2), n, edim);
y = REAL(y2); /*follow-up times*/
ys = REAL(ys2);
status = INTEGER(status2); /* status */
times = REAL(times2);
ntime = LENGTH(times2); /*length of times for reportint */
myprec = REAL(myprec2);
//nprec = LENGTH(myprec);
/* scratch space */
data2 = (double *)ALLOC(edim+1, sizeof(double));
si = (double *)ALLOC(n, sizeof(double)); /*Si for each individual - this is a pointer, the values are called using s[i]*/
sitt = (double *)ALLOC(n, sizeof(double)); /*Si at the beg. of the interval for each individual */
/*
** Set up ecut index as a ragged array
*/
ecut = (double **)ALLOC(edim, sizeof(double *));
etemp = REAL(ecut2);
for (i=0; i<edim; i++) {
ecut[i] = etemp;
if (efac[i]==0) etemp += edims[i];
else if(efac[i] >1) etemp += 1 + (efac[i]-1)*edims[i];
}
/*
** Create output arrays
*/
PROTECT(yidli2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/
yidli = REAL(yidli2);
PROTECT(dnisi2 = allocVector(REALSXP, ntime)); /*sum dNi/Si for each time* - length=length(times2)*/
dnisi = REAL(dnisi2);
PROTECT(yisi2 = allocVector(REALSXP, ntime)); /*sum Yi/Si for each time* - length=length(times2)*/
yisi = REAL(yisi2);
PROTECT(yisitt2 = allocVector(REALSXP, ntime)); /*add tt*/
yisitt = REAL(yisitt2);
PROTECT(yidlisi2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/
yidlisi = REAL(yidlisi2);
PROTECT(yidlisitt2 = allocVector(REALSXP, ntime)); /*add tt*/
yidlisitt = REAL(yidlisitt2);
PROTECT(yidlisiw2 = allocVector(REALSXP, ntime)); /*add w*/
yidlisiw = REAL(yidlisiw2);
PROTECT(yi2 = allocVector(REALSXP, ntime)); /* sum yi at each time*/
yi = REAL(yi2);
PROTECT(dni2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/
dni = REAL(dni2);
PROTECT(dnisisq2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/
dnisisq = REAL(dnisisq2);
/*initialize Si values*/
for (i=0; i<n; i++) {
si[i] =1;
}
/*initialize output values*/
for (j=0; j<ntime; j++) {
yidli[j] =0;
dnisi[j] =0;
yisi[j]=0;
yisitt[j]=0;
yidlisi[j]=0;
yidlisitt[j]=0;
yidlisiw[j]=0;
yi[j]=0;
dni[j]=0;
dnisisq[j]=0;
}
time =0;
timestart=0;
//for (j=0; j<nprec ; j++) { /* loop in time */
//fthiscell = myprec[j];
//}
for (j=0; j<ntime ; j++) { /* loop in time */
//for (j=0; j<2 ; j++) {
thiscell = times[j] - time;
/* add an additional, tinier division for integral calculation. Keep values only at the end of the less fine division (j). For now, precision is fixed to 0.1*/
ftime=0;
fyisi=0;
fyidlisi=0;
fyisi2=0;
fyidlisi2=0;
hazard=0;
jfine=0;
fint=0;
/*initialize Sitt values*/
for (i=0; i<n; i++) {
sitt[i] =si[i]; // si at the beginning of the crude interval
}
while(ftime<thiscell){ // start the finer division
jfine+=1;
/*initialize output values for those that happen only at event times - I need them at the end of the crude interval - hence, I set them back to zero everytime I start a new fine interval*/
dnisi[j] =0;
dni[j]=0;
dnisisq[j]=0;
timestart = time + ftime; // time elapsed from the start of the study to the beginning of this interval - this is the time at which the population tables are evaluated
/*temporary - precision is set to 1!*/
fthiscell=myprec[0]; //the length of this fine interval is min(precision, time to the end of crude interval)
//fthiscell=0.1;
if((thiscell-ftime)<fthiscell){
fthiscell=thiscell-ftime;
}
sisum=0;
sisumtt=0;
/* compute for each individual within the finer division*/
for (i=0; i<n; i++) {
if(y[i]>= times[j]){ // if still at risk - this is the same throughout the time intervals - the crude fine intervals are at event and censoring times. Spi must be calculated also for those entering later (period...)
/*
** initialize
*/
for (k=0; k<edim; k++){
data2[k] = x[k][i]; /* the individual's values of demographic variables at time 0 */
if (efac[k] !=1) data2[k] += timestart; /* add time to time changing variables */
}
/*
** add up hazard
*/
/* expected calc
** The wt parameter only comes into play for older style US rate
** tables, where pystep does interpolation.
** Each call to pystep moves up to the next 'boundary' in the
** expected table, data2 contains our current position therein
*/
/* while (etime >0) {*/ //this loop is needed if changes can happen between the interval points.
et2 = pystep2(edim, &indx, &indx2, &wt, data2, efac, edims, ecut, fthiscell, 1);
lambdapi = expect[indx];
lambdapi2 = expect[indx2];
if(ys[i]<=times[j]){ //he has entered before the crude interval - this guy is at risk for the whole interval - contributes to the values on this interval
fyidlisi+= lambdapi/si[i];
fyidlisi2+= lambdapi/(si[i]*exp(-fthiscell* lambdapi));
fyisi+=1/si[i];
fyisi2+=1/(si[i]*exp(-fthiscell* lambdapi));
if (wt <1) hazard+= fthiscell*(wt*lambdapi +(1-wt)*lambdapi2);
else hazard+= fthiscell* lambdapi; //length of the time interval * hazard on this interval
} // if start of observation before this time
/*for (k=0; k<edim; k++)
if (efac[k] !=1) data2[k] += et2;*/
/*etime -= et2;
}*/
si[i] = si[i]* exp(-fthiscell* lambdapi); //the value of SPi at the end of this fine interval - calculated for all not censored yet, even those not yet at risk
if(ys[i]<=times[j]){ //he has entered before the crude interval - this guy is at risk for the whole interval - contributes to the values on this interval
sisum+=1/si[i];
sisumtt+=1/sitt[i];
}
if(jfine==1){ //count the number at risk only on the first fine interval
yi[j]+=1;
}
if(y[i]==times[j]){
dnisi[j]+=status[i]/si[i];
dni[j]+=status[i];
dnisisq[j]+=status[i]/(si[i]*si[i]);
} // if this person died at this time
} // if still at risk
}// loop through individuals
fint+= (fyidlisi/fyisi/2 + fyidlisi2/fyisi2/2)*fthiscell; //the value under the integral at the end of the fine time interval: the product of the value at the beginning * the length of the time interval
ftime+= fthiscell;
}// loop through fine times
yisi[j]=sisum; //sum of 1/si at the end of the crude interval
yisitt[j]=sisumtt; //sum of 1/si at the beginning of the crude interval
yidlisi[j]=hazard/sisum; //the total hazard divided by the si at the end of the crude interval
yidlisitt[j]=hazard/sisumtt; // the total hazard divided by the si at the beginning of the crude interval
yidlisiw[j]=fint; //this is now my best shot at the integrated value on the interval
yidli[j]=hazard; //total hazard (yidlambda) on this interval
time += thiscell;
}// loop through crude times AAAA
/*
** package the output
*/
PROTECT(rlist = allocVector(VECSXP, 10)); //number of variables
SET_VECTOR_ELT(rlist,0, dnisi2);
SET_VECTOR_ELT(rlist,1, yisi2);
SET_VECTOR_ELT(rlist,2, yidlisi2);
SET_VECTOR_ELT(rlist,3, dnisisq2);
SET_VECTOR_ELT(rlist,4, yi2);
SET_VECTOR_ELT(rlist,5, dni2);
SET_VECTOR_ELT(rlist,6, yidli2);
SET_VECTOR_ELT(rlist,7, yisitt2); /*added tt*/
SET_VECTOR_ELT(rlist,8, yidlisitt2); /*added tt*/
SET_VECTOR_ELT(rlist,9, yidlisiw2); /*added w*/
PROTECT(rlistnames= allocVector(STRSXP, 10)); //number of variables
SET_STRING_ELT(rlistnames, 0, mkChar("dnisi"));
SET_STRING_ELT(rlistnames, 1, mkChar("yisi"));
SET_STRING_ELT(rlistnames, 2, mkChar("yidlisi"));
SET_STRING_ELT(rlistnames, 3, mkChar("dnisisq"));
SET_STRING_ELT(rlistnames, 4, mkChar("yi"));
SET_STRING_ELT(rlistnames, 5, mkChar("dni"));
SET_STRING_ELT(rlistnames, 6, mkChar("yidli"));
SET_STRING_ELT(rlistnames, 7, mkChar("yisitt")); /*added tt*/
SET_STRING_ELT(rlistnames, 8, mkChar("yidlisitt")); /*added tt*/
SET_STRING_ELT(rlistnames, 9, mkChar("yidlisiw")); /*added w*/
setAttrib(rlist, R_NamesSymbol, rlistnames);
unprotect(12); /*number of variables + 2*/
return(rlist);
}
PRIVATE void compile_main(FILE *conni, FILE *conno) {
REPL_DATA rd = allocmem(sizeof(repl_data));
VMstate vms;
rd->h1 = rd->h2 = NULL;
protect(&rd->h1);
protect(&rd->h2);
rd->vmregs = (VMREGS) newvector(NUM_VMREGS); /* dodgy casting :-) */
vms.r = rd->vmregs;
protect((OBJ *)(&rd->vmregs));
init_vm(&vms);
vms.c.vm_state = VM_STATE_NOQUOTA;
while (vms.c.vm_state != VM_STATE_DYING) {
ScanInst si;
char buf[16384];
rd->h1 = (OBJ) newbvector(0);
while (1) {
char *result;
result = fgets(buf, 256, conni);
if (result == NULL)
break;
while (1) {
int l = strlen(buf);
if (buf[l-1] == '\r' || buf[l-1] == '\n')
buf[l-1] = '\0';
else
break;
}
strcat(buf, "\n");
if (!strcmp(buf, ".\n"))
break;
rd->h2 = (OBJ) newstring(buf);
rd->h1 = (OBJ) bvector_concat((BVECTOR) rd->h1, (BVECTOR) rd->h2);
}
gc_reach_safepoint();
rd->h2 = (OBJ) newstringconn((BVECTOR) rd->h1);
fill_scaninst(&si, (OVECTOR) rd->h2);
while (!conn_closed((OVECTOR) rd->h2)) {
rd->h1 = (OBJ) parse(&vms, &si);
gc_reach_safepoint();
if (rd->h1 == NULL) {
sprintf(buf, "-->! the compiler returned NULL.\n");
} else {
vms.c.vm_state = VM_STATE_NOQUOTA;
ATPUT((OVECTOR) rd->h1, ME_OWNER, (OBJ) vms.r->vm_uid);
vms.r->vm_effuid = vms.r->vm_uid;
{
OVECTOR c = newovector_noinit(CL_MAXSLOTINDEX, T_CLOSURE);
ATPUT(c, CL_SELF, NULL);
ATPUT(c, CL_METHOD, rd->h1);
rd->h1 = (OBJ) c;
}
apply_closure(&vms, (OVECTOR) rd->h1, newvector_noinit(1));
while (!run_vm(&vms)) ;
rd->h1 = (OBJ) newvector(2);
ATPUT((VECTOR) rd->h1, 0, NULL);
ATPUT((VECTOR) rd->h1, 1, vms.r->vm_acc);
rd->h1 = lookup_prim(0x00001, NULL)(&vms, (VECTOR) rd->h1);
rd->h1 = (OBJ) bvector_concat((BVECTOR) rd->h1, newbvector(1));
/* terminates C-string */
gc_reach_safepoint();
sprintf(buf, "--> %s\n", ((BVECTOR) rd->h1)->vec);
}
fputs(buf, conno);
}
}
unprotect((OBJ *)(&rd->vmregs));
unprotect(&rd->h2);
unprotect(&rd->h1);
freemem(rd);
}
SEXP coxfit6(SEXP maxiter2, SEXP time2, SEXP status2,
SEXP covar2, SEXP offset2, SEXP weights2,
SEXP strata2, SEXP method2, SEXP eps2,
SEXP toler2, SEXP ibeta, SEXP doscale2) {
int i,j,k, person;
double **covar, **cmat, **imat; /*ragged arrays */
double wtave;
double *a, *newbeta;
double *a2, **cmat2;
double *scale;
double denom=0, zbeta, risk;
double temp, temp2;
int ndead; /* actually, the sum of their weights */
double newlk=0;
double dtime, d2;
double deadwt; /*sum of case weights for the deaths*/
double efronwt; /* sum of weighted risk scores for the deaths*/
int halving; /*are we doing step halving at the moment? */
int nrisk; /* number of subjects in the current risk set */
/* copies of scalar input arguments */
int nused, nvar, maxiter;
int method;
double eps, toler;
int doscale;
/* vector inputs */
double *time, *weights, *offset;
int *status, *strata;
/* returned objects */
SEXP imat2, means2, beta2, u2, loglik2;
double *beta, *u, *loglik, *means;
SEXP sctest2, flag2, iter2;
double *sctest;
int *flag, *iter;
SEXP rlist, rlistnames;
int nprotect; /* number of protect calls I have issued */
/* get local copies of some input args */
nused = LENGTH(offset2);
nvar = ncols(covar2);
method = asInteger(method2);
maxiter = asInteger(maxiter2);
eps = asReal(eps2); /* convergence criteria */
toler = asReal(toler2); /* tolerance for cholesky */
doscale = asInteger(doscale2);
time = REAL(time2);
weights = REAL(weights2);
offset= REAL(offset2);
status = INTEGER(status2);
strata = INTEGER(strata2);
/*
** Set up the ragged arrays and scratch space
** Normally covar2 does not need to be duplicated, even though
** we are going to modify it, due to the way this routine was
** was called. In this case NAMED(covar2) will =0
*/
nprotect =0;
if (NAMED(covar2)>0) {
PROTECT(covar2 = duplicate(covar2));
nprotect++;
}
covar= dmatrix(REAL(covar2), nused, nvar);
PROTECT(imat2 = allocVector(REALSXP, nvar*nvar));
nprotect++;
imat = dmatrix(REAL(imat2), nvar, nvar);
a = (double *) R_alloc(2*nvar*nvar + 4*nvar, sizeof(double));
newbeta = a + nvar;
a2 = newbeta + nvar;
scale = a2 + nvar;
cmat = dmatrix(scale + nvar, nvar, nvar);
cmat2= dmatrix(scale + nvar +nvar*nvar, nvar, nvar);
/*
** create output variables
*/
PROTECT(beta2 = duplicate(ibeta));
beta = REAL(beta2);
PROTECT(means2 = allocVector(REALSXP, nvar));
means = REAL(means2);
PROTECT(u2 = allocVector(REALSXP, nvar));
u = REAL(u2);
PROTECT(loglik2 = allocVector(REALSXP, 2));
loglik = REAL(loglik2);
PROTECT(sctest2 = allocVector(REALSXP, 1));
sctest = REAL(sctest2);
PROTECT(flag2 = allocVector(INTSXP, 1));
flag = INTEGER(flag2);
PROTECT(iter2 = allocVector(INTSXP, 1));
iter = INTEGER(iter2);
nprotect += 7;
/*
** Subtract the mean from each covar, as this makes the regression
** much more stable.
*/
for (i=0; i<nvar; i++) {
temp=0;
for (person=0; person<nused; person++) temp += covar[i][person];
temp /= nused;
means[i] = temp;
for (person=0; person<nused; person++) covar[i][person] -=temp;
if (doscale==1) { /* and also scale it */
temp =0;
for (person=0; person<nused; person++) {
temp += fabs(covar[i][person]);
}
if (temp > 0) temp = nused/temp; /* scaling */
else temp=1.0; /* rare case of a constant covariate */
scale[i] = temp;
for (person=0; person<nused; person++) covar[i][person] *= temp;
}
}
if (doscale==1) {
for (i=0; i<nvar; i++) beta[i] /= scale[i]; /*rescale initial betas */
}
else {
for (i=0; i<nvar; i++) scale[i] = 1.0;
}
/*
** do the initial iteration step
*/
strata[nused-1] =1;
loglik[1] =0;
for (i=0; i<nvar; i++) {
u[i] =0;
a2[i] =0;
for (j=0; j<nvar; j++) {
imat[i][j] =0 ;
cmat2[i][j] =0;
}
}
for (person=nused-1; person>=0; ) {
if (strata[person] == 1) {
nrisk =0 ;
denom = 0;
for (i=0; i<nvar; i++) {
a[i] = 0;
for (j=0; j<nvar; j++) cmat[i][j] = 0;
}
}
dtime = time[person];
ndead =0; /*number of deaths at this time point */
deadwt =0; /* sum of weights for the deaths */
efronwt=0; /* sum of weighted risks for the deaths */
while(person >=0 &&time[person]==dtime) {
/* walk through the this set of tied times */
nrisk++;
zbeta = offset[person]; /* form the term beta*z (vector mult) */
for (i=0; i<nvar; i++)
zbeta += beta[i]*covar[i][person];
zbeta = coxsafe(zbeta);
risk = exp(zbeta) * weights[person];
denom += risk;
/* a is the vector of weighted sums of x, cmat sums of squares */
for (i=0; i<nvar; i++) {
a[i] += risk*covar[i][person];
for (j=0; j<=i; j++)
cmat[i][j] += risk*covar[i][person]*covar[j][person];
}
if (status[person]==1) {
ndead++;
deadwt += weights[person];
efronwt += risk;
loglik[1] += weights[person]*zbeta;
for (i=0; i<nvar; i++)
u[i] += weights[person]*covar[i][person];
if (method==1) { /* Efron */
for (i=0; i<nvar; i++) {
a2[i] += risk*covar[i][person];
for (j=0; j<=i; j++)
cmat2[i][j] += risk*covar[i][person]*covar[j][person];
}
}
}
person--;
if (strata[person]==1) break; /*ties don't cross strata */
}
if (ndead >0) { /* we need to add to the main terms */
if (method==0) { /* Breslow */
loglik[1] -= deadwt* log(denom);
for (i=0; i<nvar; i++) {
temp2= a[i]/ denom; /* mean */
u[i] -= deadwt* temp2;
for (j=0; j<=i; j++)
imat[j][i] += deadwt*(cmat[i][j] - temp2*a[j])/denom;
}
}
else { /* Efron */
/*
** If there are 3 deaths we have 3 terms: in the first the
** three deaths are all in, in the second they are 2/3
** in the sums, and in the last 1/3 in the sum. Let k go
** from 0 to (ndead -1), then we will sequentially use
** denom - (k/ndead)*efronwt as the denominator
** a - (k/ndead)*a2 as the "a" term
** cmat - (k/ndead)*cmat2 as the "cmat" term
** and reprise the equations just above.
*/
for (k=0; k<ndead; k++) {
temp = (double)k/ ndead;
wtave = deadwt/ndead;
d2 = denom - temp*efronwt;
loglik[1] -= wtave* log(d2);
for (i=0; i<nvar; i++) {
temp2 = (a[i] - temp*a2[i])/ d2;
u[i] -= wtave *temp2;
for (j=0; j<=i; j++)
imat[j][i] += (wtave/d2) *
((cmat[i][j] - temp*cmat2[i][j]) -
temp2*(a[j]-temp*a2[j]));
}
}
for (i=0; i<nvar; i++) {
a2[i]=0;
for (j=0; j<nvar; j++) cmat2[i][j]=0;
}
}
}
} /* end of accumulation loop */
loglik[0] = loglik[1]; /* save the loglik for iter 0 */
/* am I done?
** update the betas and test for convergence
*/
for (i=0; i<nvar; i++) /*use 'a' as a temp to save u0, for the score test*/
a[i] = u[i];
*flag= cholesky2(imat, nvar, toler);
chsolve2(imat,nvar,a); /* a replaced by a *inverse(i) */
temp=0;
for (i=0; i<nvar; i++)
temp += u[i]*a[i];
*sctest = temp; /* score test */
/*
** Never, never complain about convergence on the first step. That way,
** if someone HAS to they can force one iter at a time.
*/
for (i=0; i<nvar; i++) {
newbeta[i] = beta[i] + a[i];
}
if (maxiter==0) {
chinv2(imat,nvar);
for (i=0; i<nvar; i++) {
beta[i] *= scale[i]; /*return to original scale */
u[i] /= scale[i];
imat[i][i] *= scale[i]*scale[i];
for (j=0; j<i; j++) {
imat[j][i] *= scale[i]*scale[j];
imat[i][j] = imat[j][i];
}
}
goto finish;
}
/*
** here is the main loop
*/
halving =0 ; /* =1 when in the midst of "step halving" */
for (*iter=1; *iter<= maxiter; (*iter)++) {
newlk =0;
for (i=0; i<nvar; i++) {
u[i] =0;
for (j=0; j<nvar; j++)
imat[i][j] =0;
}
/*
** The data is sorted from smallest time to largest
** Start at the largest time, accumulating the risk set 1 by 1
*/
for (person=nused-1; person>=0; ) {
if (strata[person] == 1) { /* rezero temps for each strata */
denom = 0;
nrisk =0;
for (i=0; i<nvar; i++) {
a[i] = 0;
for (j=0; j<nvar; j++) cmat[i][j] = 0;
}
}
dtime = time[person];
deadwt =0;
ndead =0;
efronwt =0;
while(person>=0 && time[person]==dtime) {
nrisk++;
zbeta = offset[person];
for (i=0; i<nvar; i++)
zbeta += newbeta[i]*covar[i][person];
zbeta = coxsafe(zbeta);
risk = exp(zbeta) * weights[person];
denom += risk;
for (i=0; i<nvar; i++) {
a[i] += risk*covar[i][person];
for (j=0; j<=i; j++)
cmat[i][j] += risk*covar[i][person]*covar[j][person];
}
if (status[person]==1) {
ndead++;
deadwt += weights[person];
newlk += weights[person] *zbeta;
for (i=0; i<nvar; i++)
u[i] += weights[person] *covar[i][person];
if (method==1) { /* Efron */
efronwt += risk;
for (i=0; i<nvar; i++) {
a2[i] += risk*covar[i][person];
for (j=0; j<=i; j++)
cmat2[i][j] += risk*covar[i][person]*covar[j][person];
}
}
}
person--;
if (strata[person]==1) break; /*tied times don't cross strata*/
}
if (ndead >0) { /* add up terms*/
if (method==0) { /* Breslow */
newlk -= deadwt* log(denom);
for (i=0; i<nvar; i++) {
temp2= a[i]/ denom; /* mean */
u[i] -= deadwt* temp2;
for (j=0; j<=i; j++)
imat[j][i] += (deadwt/denom)*
(cmat[i][j] - temp2*a[j]);
}
}
else { /* Efron */
for (k=0; k<ndead; k++) {
temp = (double)k / ndead;
wtave= deadwt/ ndead;
d2= denom - temp* efronwt;
newlk -= wtave* log(d2);
for (i=0; i<nvar; i++) {
temp2 = (a[i] - temp*a2[i])/ d2;
u[i] -= wtave*temp2;
for (j=0; j<=i; j++)
imat[j][i] += (wtave/d2)*
((cmat[i][j] - temp*cmat2[i][j]) -
temp2*(a[j]-temp*a2[j]));
}
}
for (i=0; i<nvar; i++) { /*in anticipation */
a2[i] =0;
for (j=0; j<nvar; j++) cmat2[i][j] =0;
}
}
}
} /* end of accumulation loop */
/* am I done?
** update the betas and test for convergence
*/
*flag = cholesky2(imat, nvar, toler);
if (fabs(1-(loglik[1]/newlk))<= eps && halving==0) { /* all done */
loglik[1] = newlk;
chinv2(imat, nvar); /* invert the information matrix */
for (i=0; i<nvar; i++) {
beta[i] = newbeta[i]*scale[i];
u[i] /= scale[i];
imat[i][i] *= scale[i]*scale[i];
for (j=0; j<i; j++) {
imat[j][i] *= scale[i]*scale[j];
imat[i][j] = imat[j][i];
}
}
goto finish;
}
if (*iter== maxiter) break; /*skip the step halving calc*/
if (newlk < loglik[1]) { /*it is not converging ! */
halving =1;
for (i=0; i<nvar; i++)
newbeta[i] = (newbeta[i] + beta[i]) /2; /*half of old increment */
}
else {
halving=0;
loglik[1] = newlk;
chsolve2(imat,nvar,u);
j=0;
for (i=0; i<nvar; i++) {
beta[i] = newbeta[i];
newbeta[i] = newbeta[i] + u[i];
}
}
} /* return for another iteration */
/*
** We end up here only if we ran out of iterations
*/
loglik[1] = newlk;
chinv2(imat, nvar);
for (i=0; i<nvar; i++) {
beta[i] = newbeta[i]*scale[i];
u[i] /= scale[i];
imat[i][i] *= scale[i]*scale[i];
for (j=0; j<i; j++) {
imat[j][i] *= scale[i]*scale[j];
imat[i][j] = imat[j][i];
}
}
*flag = 1000;
finish:
/*
** create the output list
*/
PROTECT(rlist= allocVector(VECSXP, 8));
SET_VECTOR_ELT(rlist, 0, beta2);
SET_VECTOR_ELT(rlist, 1, means2);
SET_VECTOR_ELT(rlist, 2, u2);
SET_VECTOR_ELT(rlist, 3, imat2);
SET_VECTOR_ELT(rlist, 4, loglik2);
SET_VECTOR_ELT(rlist, 5, sctest2);
SET_VECTOR_ELT(rlist, 6, iter2);
SET_VECTOR_ELT(rlist, 7, flag2);
/* add names to the objects */
PROTECT(rlistnames = allocVector(STRSXP, 8));
SET_STRING_ELT(rlistnames, 0, mkChar("coef"));
SET_STRING_ELT(rlistnames, 1, mkChar("means"));
SET_STRING_ELT(rlistnames, 2, mkChar("u"));
SET_STRING_ELT(rlistnames, 3, mkChar("imat"));
SET_STRING_ELT(rlistnames, 4, mkChar("loglik"));
SET_STRING_ELT(rlistnames, 5, mkChar("sctest"));
SET_STRING_ELT(rlistnames, 6, mkChar("iter"));
SET_STRING_ELT(rlistnames, 7, mkChar("flag"));
setAttrib(rlist, R_NamesSymbol, rlistnames);
unprotect(nprotect+2);
return(rlist);
}
CodeInjectionStream::CodeInjectionStream(void *start, size_t size)
: start(static_cast<uint8_t*>(start)), currentPtr(static_cast<uint8_t*>(start)), size(size), needsFlush(false), oldProtection(0)
{
unprotect();
}
~ProtectContext()
{ unprotect(); }
/* using thernau's habit: name a S object "charlie2" and the pointer
** to the contents of the object "charlie"; the latter is
** used in the computations
*/
SEXP netfastpinter( SEXP efac2, SEXP edims2,
SEXP ecut2, SEXP expect2,
SEXP x2, SEXP y2,SEXP ys2, SEXP status2, SEXP times2) {
int i,j,k;
int n,
edim,
ntime;
double **x;
double *data2, *si, *sitt;
double **ecut, *etemp;
double hazard, hazspi; /*cum hazard over an interval, also weigthed hazard */
double thiscell,
etime,
time,
et2;
int indx,
indx2;
double wt;
int *efac, *edims, *status;
double *expect, *y,*ys, *times;
SEXP rlist, rlistnames;
/*my declarations*/
SEXP yidli2, dnisi2,yisi2,yidlisi2,yi2,dni2,dnisisq2,yisitt2,yidlisitt2,yidlisiw2;
double *yidli, *dnisi,*yisi,*yidlisi,*yi,*dni,*dnisisq, *yisitt,*yidlisitt,*yidlisiw;
/*
** copies of input arguments
*/
efac = INTEGER(efac2);
edims = INTEGER(edims2);
edim = LENGTH(edims2);
expect= REAL(expect2);
n = LENGTH(y2); /*number of individuals */
x = dmatrix(REAL(x2), n, edim);
y = REAL(y2); /*follow-up times*/
ys = REAL(ys2);
status = INTEGER(status2); /* status */
times = REAL(times2);
ntime = LENGTH(times2); /*length of times for reportint */
/* scratch space */
data2 = (double *)ALLOC(edim+1, sizeof(double));
si = (double *)ALLOC(n, sizeof(double)); /*Si for each individual - this is a pointer, the values are called using s[i]*/
sitt = (double *)ALLOC(n, sizeof(double)); /*Si at the beg. of the interval for each individual */
/*
** Set up ecut index as a ragged array
*/
ecut = (double **)ALLOC(edim, sizeof(double *));
etemp = REAL(ecut2);
for (i=0; i<edim; i++) {
ecut[i] = etemp;
if (efac[i]==0) etemp += edims[i];
else if(efac[i] >1) etemp += 1 + (efac[i]-1)*edims[i];
}
/*
** Create output arrays
*/
PROTECT(yidli2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/
yidli = REAL(yidli2);
PROTECT(dnisi2 = allocVector(REALSXP, ntime)); /*sum dNi/Si for each time* - length=length(times2)*/
dnisi = REAL(dnisi2);
PROTECT(yisi2 = allocVector(REALSXP, ntime)); /*sum Yi/Si for each time* - length=length(times2)*/
yisi = REAL(yisi2);
PROTECT(yisitt2 = allocVector(REALSXP, ntime)); /*add tt*/
yisitt = REAL(yisitt2);
PROTECT(yidlisi2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/
yidlisi = REAL(yidlisi2);
PROTECT(yidlisitt2 = allocVector(REALSXP, ntime)); /*add tt*/
yidlisitt = REAL(yidlisitt2);
PROTECT(yidlisiw2 = allocVector(REALSXP, ntime)); /*add w*/
yidlisiw = REAL(yidlisiw2);
PROTECT(yi2 = allocVector(REALSXP, ntime)); /* sum yi at each time*/
yi = REAL(yi2);
PROTECT(dni2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/
dni = REAL(dni2);
PROTECT(dnisisq2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/
dnisisq = REAL(dnisisq2);
/*initialize Si values*/
for (i=0; i<n; i++) {
si[i] =1;
sitt[i] =1;
}
/*initialize output values*/
for (j=0; j<ntime; j++) {
yidli[j] =0;
dnisi[j] =0;
yisi[j]=0;
yisitt[j]=0;
yidlisi[j]=0;
yidlisitt[j]=0;
yidlisiw[j]=0;
yi[j]=0;
dni[j]=0;
dnisisq[j]=0;
}
time =0;
for (j=0; j<ntime ; j++) { /* loop in time */
thiscell = times[j] - time;
/* compute for each individual*/
for (i=0; i<n; i++) {
if(y[i]>= times[j]){ // if still at risk
/*
** initialize
*/
for (k=0; k<edim; k++){
data2[k] = x[k][i]; /* the individual's values of demographic variables at time 0 */
if (efac[k] !=1) data2[k] += time; /* add time to time changing variables */
}
/*
** add up hazard
*/
/* expected calc
** The wt parameter only comes into play for older style US rate
** tables, where pystep does interpolation.
** Each call to pystep moves up to the next 'boundary' in the
** expected table, data2 contains our current position therein
*/
etime = thiscell;
hazard =0;
hazspi=0; //integration of haz/si
while (etime >0) {
et2 = pystep(edim, &indx, &indx2, &wt, data2, efac,
edims, ecut, etime, 1);
hazspi+= et2* expect[indx]/(si[i]*exp(-hazard)); //add the integrated part
if (wt <1) hazard+= et2*(wt*expect[indx] +(1-wt)*expect[indx2]);
else hazard+= et2* expect[indx];
for (k=0; k<edim; k++)
if (efac[k] !=1) data2[k] += et2;
etime -= et2;
}
sitt[i] = si[i]; // si at the beginning of the interval
si[i] = si[i]* exp(-hazard);
if(ys[i]<=times[j]){ // if start of observation before this time
yisi[j]+=1/si[i];
yisitt[j]+=1/sitt[i];
yidlisi[j]+=hazard/si[i];
yidlisitt[j]+=hazard/sitt[i];
yidlisiw[j]+=hazspi;
yidli[j]+=hazard;
yi[j]+=1;
if(y[i]==times[j]){
dnisi[j]+=status[i]/si[i];
dni[j]+=status[i];
dnisisq[j]+=status[i]/(si[i]*si[i]);
} // if this person died at this time
} // if start of observation before this time
} // if still at risk
}// loop through individuals
time += thiscell;
}// loop through times
/*
** package the output
*/
PROTECT(rlist = allocVector(VECSXP, 10)); //number of variables
SET_VECTOR_ELT(rlist,0, dnisi2);
SET_VECTOR_ELT(rlist,1, yisi2);
SET_VECTOR_ELT(rlist,2, yidlisi2);
SET_VECTOR_ELT(rlist,3, dnisisq2);
SET_VECTOR_ELT(rlist,4, yi2);
SET_VECTOR_ELT(rlist,5, dni2);
SET_VECTOR_ELT(rlist,6, yidli2);
SET_VECTOR_ELT(rlist,7, yisitt2); /*added tt*/
SET_VECTOR_ELT(rlist,8, yidlisitt2); /*added tt*/
SET_VECTOR_ELT(rlist,9, yidlisiw2); /*added w*/
PROTECT(rlistnames= allocVector(STRSXP, 10)); //number of variables
SET_STRING_ELT(rlistnames, 0, mkChar("dnisi"));
SET_STRING_ELT(rlistnames, 1, mkChar("yisi"));
SET_STRING_ELT(rlistnames, 2, mkChar("yidlisi"));
SET_STRING_ELT(rlistnames, 3, mkChar("dnisisq"));
SET_STRING_ELT(rlistnames, 4, mkChar("yi"));
SET_STRING_ELT(rlistnames, 5, mkChar("dni"));
SET_STRING_ELT(rlistnames, 6, mkChar("yidli"));
SET_STRING_ELT(rlistnames, 7, mkChar("yisitt")); /*added tt*/
SET_STRING_ELT(rlistnames, 8, mkChar("yidlisitt")); /*added tt*/
SET_STRING_ELT(rlistnames, 9, mkChar("yidlisiw")); /*added w*/
setAttrib(rlist, R_NamesSymbol, rlistnames);
unprotect(12); /*number of variables + 2*/
return(rlist);
}
/* Return the secret key as an S-Exp in RESULT after locating it using
the GRIP. Stores NULL at RESULT if the operation shall be diverted
to a token; in this case an allocated S-expression with the
shadow_info part from the file is stored at SHADOW_INFO.
CACHE_MODE defines now the cache shall be used. DESC_TEXT may be
set to present a custom description for the pinentry. LOOKUP_TTL
is an optional function to convey a TTL to the cache manager; we do
not simply pass the TTL value because the value is only needed if an
unprotect action was needed and looking up the TTL may have some
overhead (e.g. scanning the sshcontrol file). */
gpg_error_t
agent_key_from_file (ctrl_t ctrl, const char *desc_text,
const unsigned char *grip, unsigned char **shadow_info,
cache_mode_t cache_mode, lookup_ttl_t lookup_ttl,
gcry_sexp_t *result)
{
int rc;
unsigned char *buf;
size_t len, buflen, erroff;
gcry_sexp_t s_skey;
int got_shadow_info = 0;
*result = NULL;
if (shadow_info)
*shadow_info = NULL;
rc = read_key_file (grip, &s_skey);
if (rc)
return rc;
/* For use with the protection functions we also need the key as an
canonical encoded S-expression in a buffer. Create this buffer
now. */
rc = make_canon_sexp (s_skey, &buf, &len);
if (rc)
return rc;
switch (agent_private_key_type (buf))
{
case PRIVATE_KEY_CLEAR:
break; /* no unprotection needed */
case PRIVATE_KEY_PROTECTED:
{
char *desc_text_final;
char *comment = NULL;
/* Note, that we will take the comment as a C string for
display purposes; i.e. all stuff beyond a Nul character is
ignored. */
{
gcry_sexp_t comment_sexp;
comment_sexp = gcry_sexp_find_token (s_skey, "comment", 0);
if (comment_sexp)
comment = gcry_sexp_nth_string (comment_sexp, 1);
gcry_sexp_release (comment_sexp);
}
desc_text_final = NULL;
if (desc_text)
rc = modify_description (desc_text, comment? comment:"", s_skey,
&desc_text_final);
gcry_free (comment);
if (!rc)
{
rc = unprotect (ctrl, desc_text_final, &buf, grip,
cache_mode, lookup_ttl);
if (rc)
log_error ("failed to unprotect the secret key: %s\n",
gpg_strerror (rc));
}
xfree (desc_text_final);
}
break;
case PRIVATE_KEY_SHADOWED:
if (shadow_info)
{
const unsigned char *s;
size_t n;
rc = agent_get_shadow_info (buf, &s);
if (!rc)
{
n = gcry_sexp_canon_len (s, 0, NULL,NULL);
assert (n);
*shadow_info = xtrymalloc (n);
if (!*shadow_info)
rc = out_of_core ();
else
{
memcpy (*shadow_info, s, n);
rc = 0;
got_shadow_info = 1;
}
}
if (rc)
log_error ("get_shadow_info failed: %s\n", gpg_strerror (rc));
}
else
rc = gpg_error (GPG_ERR_UNUSABLE_SECKEY);
break;
default:
log_error ("invalid private key format\n");
rc = gpg_error (GPG_ERR_BAD_SECKEY);
break;
}
gcry_sexp_release (s_skey);
s_skey = NULL;
if (rc || got_shadow_info)
{
xfree (buf);
return rc;
}
buflen = gcry_sexp_canon_len (buf, 0, NULL, NULL);
rc = gcry_sexp_sscan (&s_skey, &erroff, (char*)buf, buflen);
wipememory (buf, buflen);
xfree (buf);
if (rc)
{
log_error ("failed to build S-Exp (off=%u): %s\n",
(unsigned int)erroff, gpg_strerror (rc));
return rc;
}
*result = s_skey;
return 0;
}
SEXP coxexact(SEXP maxiter2, SEXP y2,
SEXP covar2, SEXP offset2, SEXP strata2,
SEXP ibeta, SEXP eps2, SEXP toler2) {
int i,j,k;
int iter;
double **covar, **imat; /*ragged arrays */
double *time, *status; /* input data */
double *offset;
int *strata;
int sstart; /* starting obs of current strata */
double *score;
double *oldbeta;
double zbeta;
double newlk=0;
double temp;
int halving; /*are we doing step halving at the moment? */
int nrisk; /* number of subjects in the current risk set */
int dsize, /* memory needed for one coxc0, coxc1, or coxd2 array */
dmemtot, /* amount needed for all arrays */
maxdeath, /* max tied deaths within a strata */
ndeath; /* number of deaths at the current time point */
double dtime; /* time value under current examiniation */
double *dmem0, **dmem1, *dmem2; /* pointers to memory */
double *dtemp; /* used for zeroing the memory */
double *d1; /* current first derivatives from coxd1 */
double d0; /* global sum from coxc0 */
/* copies of scalar input arguments */
int nused, nvar, maxiter;
double eps, toler;
/* returned objects */
SEXP imat2, beta2, u2, loglik2;
double *beta, *u, *loglik;
SEXP rlist, rlistnames;
int nprotect; /* number of protect calls I have issued */
nused = LENGTH(offset2);
nvar = ncols(covar2);
maxiter = asInteger(maxiter2);
eps = asReal(eps2); /* convergence criteria */
toler = asReal(toler2); /* tolerance for cholesky */
/*
** Set up the ragged array pointer to the X matrix,
** and pointers to time and status
*/
covar= dmatrix(REAL(covar2), nused, nvar);
time = REAL(y2);
status = time +nused;
strata = INTEGER(PROTECT(duplicate(strata2)));
offset = REAL(offset2);
/* temporary vectors */
score = (double *) R_alloc(nused+nvar, sizeof(double));
oldbeta = score + nused;
/*
** create output variables
*/
PROTECT(beta2 = duplicate(ibeta));
beta = REAL(beta2);
PROTECT(u2 = allocVector(REALSXP, nvar));
u = REAL(u2);
PROTECT(imat2 = allocVector(REALSXP, nvar*nvar));
imat = dmatrix(REAL(imat2), nvar, nvar);
PROTECT(loglik2 = allocVector(REALSXP, 5)); /* loglik, sctest, flag,maxiter*/
loglik = REAL(loglik2);
nprotect = 5;
strata[0] =1; /* in case the parent forgot */
dsize = 0;
maxdeath =0;
j=0; /* start of the strata */
for (i=0; i<nused;) {
if (strata[i]==1) { /* first obs of a new strata */
if (i>0) {
/* If maxdeath <2 leave the strata alone at it's current value of 1 */
if (maxdeath >1) strata[j] = maxdeath;
j = i;
if (maxdeath*nrisk >dsize) dsize = maxdeath*nrisk;
}
maxdeath =0; /* max tied deaths at any time in this strata */
nrisk=0;
ndeath =0;
}
dtime = time[i];
ndeath =0; /*number tied here */
while (time[i] ==dtime) {
nrisk++;
ndeath += status[i];
i++;
if (i>=nused || strata[i] >0) break; /*tied deaths don't cross strata */
}
if (ndeath > maxdeath) maxdeath=ndeath;
}
if (maxdeath*nrisk >dsize) dsize = maxdeath*nrisk;
if (maxdeath >1) strata[j] = maxdeath;
/* Now allocate memory for the scratch arrays
Each per-variable slice is of size dsize
*/
dmemtot = dsize * ((nvar*(nvar+1))/2 + nvar + 1);
dmem0 = (double *) R_alloc(dmemtot, sizeof(double)); /*pointer to memory */
dmem1 = (double **) R_alloc(nvar, sizeof(double*));
dmem1[0] = dmem0 + dsize; /*points to the first derivative memory */
for (i=1; i<nvar; i++) dmem1[i] = dmem1[i-1] + dsize;
d1 = (double *) R_alloc(nvar, sizeof(double)); /*first deriv results */
/*
** do the initial iteration step
*/
newlk =0;
for (i=0; i<nvar; i++) {
u[i] =0;
for (j=0; j<nvar; j++)
imat[i][j] =0 ;
}
for (i=0; i<nused; ) {
if (strata[i] >0) { /* first obs of a new strata */
maxdeath= strata[i];
dtemp = dmem0;
for (j=0; j<dmemtot; j++) *dtemp++ =0.0;
sstart =i;
nrisk =0;
}
dtime = time[i]; /*current unique time */
ndeath =0;
while (time[i] == dtime) {
zbeta= offset[i];
for (j=0; j<nvar; j++) zbeta += covar[j][i] * beta[j];
score[i] = exp(zbeta);
if (status[i]==1) {
newlk += zbeta;
for (j=0; j<nvar; j++) u[j] += covar[j][i];
ndeath++;
}
nrisk++;
i++;
if (i>=nused || strata[i] >0) break;
}
/* We have added up over the death time, now process it */
if (ndeath >0) { /* Add to the loglik */
d0 = coxd0(ndeath, nrisk, score+sstart, dmem0, maxdeath);
R_CheckUserInterrupt();
newlk -= log(d0);
dmem2 = dmem0 + (nvar+1)*dsize; /*start for the second deriv memory */
for (j=0; j<nvar; j++) { /* for each covariate */
d1[j] = coxd1(ndeath, nrisk, score+sstart, dmem0, dmem1[j],
covar[j]+sstart, maxdeath) / d0;
if (ndeath > 3) R_CheckUserInterrupt();
u[j] -= d1[j];
for (k=0; k<= j; k++) { /* second derivative*/
temp = coxd2(ndeath, nrisk, score+sstart, dmem0, dmem1[j],
dmem1[k], dmem2, covar[j] + sstart,
covar[k] + sstart, maxdeath);
if (ndeath > 5) R_CheckUserInterrupt();
imat[k][j] += temp/d0 - d1[j]*d1[k];
dmem2 += dsize;
}
}
}
}
loglik[0] = newlk; /* save the loglik for iteration zero */
loglik[1] = newlk; /* and it is our current best guess */
/*
** update the betas and compute the score test
*/
for (i=0; i<nvar; i++) /*use 'd1' as a temp to save u0, for the score test*/
d1[i] = u[i];
loglik[3] = cholesky2(imat, nvar, toler);
chsolve2(imat,nvar, u); /* u replaced by u *inverse(imat) */
loglik[2] =0; /* score test stored here */
for (i=0; i<nvar; i++)
loglik[2] += u[i]*d1[i];
if (maxiter==0) {
iter =0; /*number of iterations */
loglik[4] = iter;
chinv2(imat, nvar);
for (i=1; i<nvar; i++)
for (j=0; j<i; j++) imat[i][j] = imat[j][i];
/* assemble the return objects as a list */
PROTECT(rlist= allocVector(VECSXP, 4));
SET_VECTOR_ELT(rlist, 0, beta2);
SET_VECTOR_ELT(rlist, 1, u2);
SET_VECTOR_ELT(rlist, 2, imat2);
SET_VECTOR_ELT(rlist, 3, loglik2);
/* add names to the list elements */
PROTECT(rlistnames = allocVector(STRSXP, 4));
SET_STRING_ELT(rlistnames, 0, mkChar("coef"));
SET_STRING_ELT(rlistnames, 1, mkChar("u"));
SET_STRING_ELT(rlistnames, 2, mkChar("imat"));
SET_STRING_ELT(rlistnames, 3, mkChar("loglik"));
setAttrib(rlist, R_NamesSymbol, rlistnames);
unprotect(nprotect+2);
return(rlist);
}
/*
** Never, never complain about convergence on the first step. That way,
** if someone has to they can force one iter at a time.
*/
for (i=0; i<nvar; i++) {
oldbeta[i] = beta[i];
beta[i] = beta[i] + u[i];
}
halving =0 ; /* =1 when in the midst of "step halving" */
for (iter=1; iter<=maxiter; iter++) {
newlk =0;
for (i=0; i<nvar; i++) {
u[i] =0;
for (j=0; j<nvar; j++)
imat[i][j] =0;
}
for (i=0; i<nused; ) {
if (strata[i] >0) { /* first obs of a new strata */
maxdeath= strata[i];
dtemp = dmem0;
for (j=0; j<dmemtot; j++) *dtemp++ =0.0;
sstart =i;
nrisk =0;
}
dtime = time[i]; /*current unique time */
ndeath =0;
while (time[i] == dtime) {
zbeta= offset[i];
for (j=0; j<nvar; j++) zbeta += covar[j][i] * beta[j];
score[i] = exp(zbeta);
if (status[i]==1) {
newlk += zbeta;
for (j=0; j<nvar; j++) u[j] += covar[j][i];
ndeath++;
}
nrisk++;
i++;
if (i>=nused || strata[i] >0) break;
}
/* We have added up over the death time, now process it */
if (ndeath >0) { /* Add to the loglik */
d0 = coxd0(ndeath, nrisk, score+sstart, dmem0, maxdeath);
R_CheckUserInterrupt();
newlk -= log(d0);
dmem2 = dmem0 + (nvar+1)*dsize; /*start for the second deriv memory */
for (j=0; j<nvar; j++) { /* for each covariate */
d1[j] = coxd1(ndeath, nrisk, score+sstart, dmem0, dmem1[j],
covar[j]+sstart, maxdeath) / d0;
if (ndeath > 3) R_CheckUserInterrupt();
u[j] -= d1[j];
for (k=0; k<= j; k++) { /* second derivative*/
temp = coxd2(ndeath, nrisk, score+sstart, dmem0, dmem1[j],
dmem1[k], dmem2, covar[j] + sstart,
covar[k] + sstart, maxdeath);
if (ndeath > 5) R_CheckUserInterrupt();
imat[k][j] += temp/d0 - d1[j]*d1[k];
dmem2 += dsize;
}
}
}
}
/* am I done?
** update the betas and test for convergence
*/
loglik[3] = cholesky2(imat, nvar, toler);
if (fabs(1-(loglik[1]/newlk))<= eps && halving==0) { /* all done */
loglik[1] = newlk;
loglik[4] = iter;
chinv2(imat, nvar);
for (i=1; i<nvar; i++)
for (j=0; j<i; j++) imat[i][j] = imat[j][i];
/* assemble the return objects as a list */
PROTECT(rlist= allocVector(VECSXP, 4));
SET_VECTOR_ELT(rlist, 0, beta2);
SET_VECTOR_ELT(rlist, 1, u2);
SET_VECTOR_ELT(rlist, 2, imat2);
SET_VECTOR_ELT(rlist, 3, loglik2);
/* add names to the list elements */
PROTECT(rlistnames = allocVector(STRSXP, 4));
SET_STRING_ELT(rlistnames, 0, mkChar("coef"));
SET_STRING_ELT(rlistnames, 1, mkChar("u"));
SET_STRING_ELT(rlistnames, 2, mkChar("imat"));
SET_STRING_ELT(rlistnames, 3, mkChar("loglik"));
setAttrib(rlist, R_NamesSymbol, rlistnames);
unprotect(nprotect+2);
return(rlist);
}
if (iter==maxiter) break; /*skip the step halving and etc */
if (newlk < loglik[1]) { /*it is not converging ! */
halving =1;
for (i=0; i<nvar; i++)
beta[i] = (oldbeta[i] + beta[i]) /2; /*half of old increment */
}
else {
halving=0;
loglik[1] = newlk;
chsolve2(imat,nvar,u);
for (i=0; i<nvar; i++) {
oldbeta[i] = beta[i];
beta[i] = beta[i] + u[i];
}
}
} /* return for another iteration */
/*
** Ran out of iterations
*/
loglik[1] = newlk;
loglik[3] = 1000; /* signal no convergence */
loglik[4] = iter;
chinv2(imat, nvar);
for (i=1; i<nvar; i++)
for (j=0; j<i; j++) imat[i][j] = imat[j][i];
/* assemble the return objects as a list */
PROTECT(rlist= allocVector(VECSXP, 4));
SET_VECTOR_ELT(rlist, 0, beta2);
SET_VECTOR_ELT(rlist, 1, u2);
SET_VECTOR_ELT(rlist, 2, imat2);
SET_VECTOR_ELT(rlist, 3, loglik2);
/* add names to the list elements */
PROTECT(rlistnames = allocVector(STRSXP, 4));
SET_STRING_ELT(rlistnames, 0, mkChar("coef"));
SET_STRING_ELT(rlistnames, 1, mkChar("u"));
SET_STRING_ELT(rlistnames, 2, mkChar("imat"));
SET_STRING_ELT(rlistnames, 3, mkChar("loglik"));
setAttrib(rlist, R_NamesSymbol, rlistnames);
unprotect(nprotect+2);
return(rlist);
}
