logspline/0000755000176200001440000000000012654243261012253 5ustar liggesuserslogspline/src/0000755000176200001440000000000012654166601013044 5ustar liggesuserslogspline/src/Makevars0000644000176200001440000000003712654166601014540 0ustar liggesusersPKG_LIBS=$(BLAS_LIBS) $(FLIBS) logspline/src/x2c.h0000644000176200001440000000765712654166601013730 0ustar liggesusers/* f2c.h -- Standard Fortran to C header file */ /** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ #ifndef F2C_INCLUDE #define F2C_INCLUDE typedef int integer; typedef char *address; typedef short int shortint; typedef float real; typedef double doublereal; typedef long int logical; typedef short int shortlogical; typedef char logical1; typedef char integer1; /* typedef long long longint; */ /* system-dependent */ #define TRUE_ (1) #define FALSE_ (0) /* Extern is for use with -E */ #ifndef Extern #define Extern extern #endif /* I/O stuff */ #ifdef f2c_i2 /* for -i2 */ typedef short flag; typedef short ftnlen; typedef short ftnint; #else typedef long flag; typedef long ftnlen; typedef long ftnint; #endif /*external read, write*/ typedef struct { flag cierr; ftnint ciunit; flag ciend; char *cifmt; ftnint cirec; } cilist; /*internal read, write*/ typedef struct { flag icierr; char *iciunit; flag iciend; char *icifmt; ftnint icirlen; ftnint icirnum; } icilist; /*open*/ typedef struct { flag oerr; ftnint ounit; char *ofnm; ftnlen ofnmlen; char *osta; char *oacc; char *ofm; ftnint orl; char *oblnk; } olist; /*close*/ typedef struct { flag cerr; ftnint cunit; char *csta; } cllist; /*rewind, backspace, endfile*/ typedef struct { flag aerr; ftnint aunit; } alist; /* inquire */ typedef struct { flag inerr; ftnint inunit; char *infile; ftnlen infilen; ftnint *inex; /*parameters in standard's order*/ ftnint *inopen; ftnint *innum; ftnint *innamed; char *inname; ftnlen innamlen; char *inacc; ftnlen inacclen; char *inseq; ftnlen inseqlen; char *indir; ftnlen indirlen; char *infmt; ftnlen infmtlen; char *inform; ftnint informlen; char *inunf; ftnlen inunflen; ftnint *inrecl; ftnint *innrec; char *inblank; ftnlen inblanklen; } inlist; #define VOID void union Multitype { /* for multiple entry points */ integer1 g; shortint h; integer i; /* longint j; */ real r; doublereal d; }; typedef union Multitype Multitype; typedef long Long; /* No longer used; formerly in Namelist */ struct Vardesc { /* for Namelist */ char *name; char *addr; ftnlen *dims; int type; }; typedef struct Vardesc Vardesc; struct Namelist { char *name; Vardesc **vars; int nvars; }; typedef struct Namelist Namelist; #define abs(x) ((x) >= 0 ? (x) : -(x)) #define dabs(x) (doublereal)abs(x) #define min(a,b) ((a) <= (b) ? (a) : (b)) #define max(a,b) ((a) >= (b) ? (a) : (b)) #define dmin(a,b) (doublereal)min(a,b) #define dmax(a,b) (doublereal)max(a,b) /* procedure parameter types for -A and -C++ */ #define F2C_proc_par_types 1 #ifdef __cplusplus typedef int /* Unknown procedure type */ (*U_fp)(...); typedef shortint (*J_fp)(...); typedef integer (*I_fp)(...); typedef real (*R_fp)(...); typedef doublereal (*D_fp)(...), (*E_fp)(...); typedef /* Complex */ VOID (*C_fp)(...); typedef /* Double Complex */ VOID (*Z_fp)(...); typedef logical (*L_fp)(...); typedef shortlogical (*K_fp)(...); typedef /* Character */ VOID (*H_fp)(...); typedef /* Subroutine */ int (*S_fp)(...); #else typedef int /* Unknown procedure type */ (*U_fp)(); typedef shortint (*J_fp)(); typedef integer (*I_fp)(); typedef real (*R_fp)(); typedef doublereal (*D_fp)(), (*E_fp)(); typedef /* Complex */ VOID (*C_fp)(); typedef /* Double Complex */ VOID (*Z_fp)(); typedef logical (*L_fp)(); typedef shortlogical (*K_fp)(); typedef /* Character */ VOID (*H_fp)(); typedef /* Subroutine */ int (*S_fp)(); #endif /* E_fp is for real functions when -R is not specified */ typedef doublereal E_f; /* real function with -R not specified */ /* undef any lower-case symbols that your C compiler predefines, e.g.: */ #ifndef Skip_f2c_Undefs #undef cray #undef gcos #undef mc68010 #undef mc68020 #undef mips #undef pdp11 #undef sgi #undef sparc #undef sun #undef sun2 #undef sun3 #undef sun4 #undef u370 #undef u3b #undef u3b2 #undef u3b5 #undef unix #undef vax #endif #endif logspline/src/allpack.f0000644000176200001440000011336312654166601014631 0ustar liggesusersc /************************************************************************* c * The following subroutines are all part of linpack. Linpack is public * c * domain software. These routines are only included here for completeness* c * All subroutine-names have been given a leading X - to prevent double * c * definitions * C LINPACK. THIS VERSION DATED 08/14/78 . C JAMES BUNCH, UNIV. CALIF. SAN DIEGO, ARGONNE NAT. LAB. c ************************************************************************** SUBROUTINE XDSIFA(A,LDA,N,KPVT,INFO) INTEGER LDA,N,KPVT(*),INFO DOUBLE PRECISION A(LDA,*) C C XDSIFA FACTORS A DOUBLE PRECISION SYMMETRIC MATRIX BY ELIMINATION C WITH SYMMETRIC PIVOTING. C C TO SOLVE A*X = B , FOLLOW XDSIFA BY XDSISL. C TO COMPUTE INVERSE(A)*C , FOLLOW XDSIFA BY XDSISL. C TO COMPUTE DETERMINANT(A) , FOLLOW XDSIFA BY XDSIDI. C TO COMPUTE INERTIA(A) , FOLLOW XDSIFA BY XDSIDI. C TO COMPUTE INVERSE(A) , FOLLOW XDSIFA BY XDSIDI. C C ON ENTRY C C A DOUBLE PRECISION(LDA,N) C THE SYMMETRIC MATRIX TO BE FACTORED. C ONLY THE DIAGONAL AND UPPER TRIANGLE ARE USED. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C C N INTEGER C THE ORDER OF THE MATRIX A . C C ON RETURN C C A A BLOCK DIAGONAL MATRIX AND THE MULTIPLIERS WHICH C WERE USED TO OBTAIN IT. C THE FACTORIZATION CAN BE WRITTEN A = U*D*TRANS(U) C WHERE U IS A PRODUCT OF PERMUTATION AND UNIT C UPPER TRIANGULAR MATRICES , TRANS(U) IS THE C TRANSPOSE OF U , AND D IS BLOCK DIAGONAL C WITH 1 BY 1 AND 2 BY 2 BLOCKS. C C KPVT INTEGER(N) C AN INTEGER VECTOR OF PIVOT INDICES. C C INFO INTEGER C = 0 NORMAL VALUE. C = K IF THE K-TH PIVOT BLOCK IS SINGULAR. THIS IS C NOT AN ERROR CONDITION FOR THIS SUBROUTINE, C BUT IT DOES INDICATE THAT XDSISL OR XDSIDI MAY C DIVIDE BY ZERO IF CALLED. C C LINPACK. THIS VERSION DATED 08/14/78 . C JAMES BUNCH, UNIV. CALIF. SAN DIEGO, ARGONNE NAT. LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS DAXPY,DSWAP,IDAMAX C FORTRAN DABS,DMAX1,DSQRT C C INTERNAL VARIABLES C DOUBLE PRECISION AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T DOUBLE PRECISION ABSAKK,ALPHA,COLMAX,ROWMAX INTEGER IMAX,IMAXP1,J,JJ,JMAX,K,KM1,KM2,KSTEP,IDAMAX LOGICAL SWAP C C C INITIALIZE C C ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. ALPHA = (1.0D0 + DSQRT(17.0D0))/8.0D0 C INFO = 0 C C MAIN LOOP ON K, WHICH GOES FROM N TO 1. C K = N 10 CONTINUE C C LEAVE THE LOOP IF K=0 OR K=1. C C ...EXIT IF (K .EQ. 0) GO TO 200 IF (K .GT. 1) GO TO 20 KPVT(1) = 1 IF (A(1,1) .EQ. 0.0D0) INFO = 1 C ......EXIT GO TO 200 20 CONTINUE C C THIS SECTION OF CODE DETERMINES THE KIND OF C ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, C KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND C SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS C REQUIRED. C KM1 = K - 1 ABSAKK = DABS(A(K,K)) C C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN C COLUMN K. C IMAX = IDAMAX(K-1,A(1,K),1) COLMAX = DABS(A(IMAX,K)) IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30 KSTEP = 1 SWAP = .FALSE. GO TO 90 30 CONTINUE C C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN C ROW IMAX. C ROWMAX = 0.0D0 IMAXP1 = IMAX + 1 DO 40 J = IMAXP1, K ROWMAX = DMAX1(ROWMAX,DABS(A(IMAX,J))) 40 CONTINUE IF (IMAX .EQ. 1) GO TO 50 JMAX = IDAMAX(IMAX-1,A(1,IMAX),1) ROWMAX = DMAX1(ROWMAX,DABS(A(JMAX,IMAX))) 50 CONTINUE IF (DABS(A(IMAX,IMAX)) .LT. ALPHA*ROWMAX) GO TO 60 KSTEP = 1 SWAP = .TRUE. GO TO 80 60 CONTINUE IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70 KSTEP = 1 SWAP = .FALSE. GO TO 80 70 CONTINUE KSTEP = 2 SWAP = IMAX .NE. KM1 80 CONTINUE 90 CONTINUE IF (DMAX1(ABSAKK,COLMAX) .NE. 0.0D0) GO TO 100 C C COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. C KPVT(K) = K INFO = K GO TO 190 100 CONTINUE IF (KSTEP .EQ. 2) GO TO 140 C C 1 X 1 PIVOT BLOCK. C IF (.NOT.SWAP) GO TO 120 C C PERFORM AN INTERCHANGE. C CALL DSWAP(IMAX,A(1,IMAX),1,A(1,K),1) DO 110 JJ = IMAX, K J = K + IMAX - JJ T = A(J,K) A(J,K) = A(IMAX,J) A(IMAX,J) = T 110 CONTINUE 120 CONTINUE C C PERFORM THE ELIMINATION. C DO 130 JJ = 1, KM1 J = K - JJ MULK = -A(J,K)/A(K,K) T = MULK CALL DAXPY(J,T,A(1,K),1,A(1,J),1) A(J,K) = MULK 130 CONTINUE C C SET THE PIVOT ARRAY. C KPVT(K) = K IF (SWAP) KPVT(K) = IMAX GO TO 190 140 CONTINUE C C 2 X 2 PIVOT BLOCK. C IF (.NOT.SWAP) GO TO 160 C C PERFORM AN INTERCHANGE. C CALL DSWAP(IMAX,A(1,IMAX),1,A(1,K-1),1) DO 150 JJ = IMAX, KM1 J = KM1 + IMAX - JJ T = A(J,K-1) A(J,K-1) = A(IMAX,J) A(IMAX,J) = T 150 CONTINUE T = A(K-1,K) A(K-1,K) = A(IMAX,K) A(IMAX,K) = T 160 CONTINUE C C PERFORM THE ELIMINATION. C KM2 = K - 2 IF (KM2 .EQ. 0) GO TO 180 AK = A(K,K)/A(K-1,K) AKM1 = A(K-1,K-1)/A(K-1,K) DENOM = 1.0D0 - AK*AKM1 DO 170 JJ = 1, KM2 J = KM1 - JJ BK = A(J,K)/A(K-1,K) BKM1 = A(J,K-1)/A(K-1,K) MULK = (AKM1*BK - BKM1)/DENOM MULKM1 = (AK*BKM1 - BK)/DENOM T = MULK CALL DAXPY(J,T,A(1,K),1,A(1,J),1) T = MULKM1 CALL DAXPY(J,T,A(1,K-1),1,A(1,J),1) A(J,K) = MULK A(J,K-1) = MULKM1 170 CONTINUE 180 CONTINUE C C SET THE PIVOT ARRAY. C KPVT(K) = 1 - K IF (SWAP) KPVT(K) = -IMAX KPVT(K-1) = KPVT(K) 190 CONTINUE K = K - KSTEP GO TO 10 200 CONTINUE RETURN END SUBROUTINE XDSISL(A,LDA,N,KPVT,B) INTEGER LDA,N,KPVT(*) DOUBLE PRECISION A(LDA,*),B(*) C C XDSISL SOLVES THE DOUBLE PRECISION SYMMETRIC SYSTEM C A * X = B C USING THE FACTORS COMPUTED BY XDSIFA. C C ON ENTRY C C A DOUBLE PRECISION(LDA,N) C THE OUTPUT FROM XDSIFA. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C C N INTEGER C THE ORDER OF THE MATRIX A . C C KPVT INTEGER(N) C THE PIVOT VECTOR FROM XDSIFA. C C B DOUBLE PRECISION(N) C THE RIGHT HAND SIDE VECTOR. C C ON RETURN C C B THE SOLUTION VECTOR X . C C ERROR CONDITION C C A DIVISION BY ZERO MAY OCCUR IF DSICO HAS SET RCOND .EQ. 0.0 C OR XDSIFA HAS SET INFO .NE. 0 . C C TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX C WITH P COLUMNS C CALL XDSIFA(A,LDA,N,KPVT,INFO) C IF (INFO .NE. 0) GO TO ... C DO 10 J = 1, P C CALL XDSISL(A,LDA,N,KPVT,C(1,J)) C 10 CONTINUE C C LINPACK. THIS VERSION DATED 08/14/78 . C JAMES BUNCH, UNIV. CALIF. SAN DIEGO, ARGONNE NAT. LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS DAXPY,DDOT C FORTRAN IABS C C INTERNAL VARIABLES. C DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,TEMP INTEGER K,KP C C LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND C D INVERSE TO B. C K = N 10 IF (K .EQ. 0) GO TO 80 IF (KPVT(K) .LT. 0) GO TO 40 C C 1 X 1 PIVOT BLOCK. C IF (K .EQ. 1) GO TO 30 KP = KPVT(K) IF (KP .EQ. K) GO TO 20 C C INTERCHANGE. C TEMP = B(K) B(K) = B(KP) B(KP) = TEMP 20 CONTINUE C C APPLY THE TRANSFORMATION. C CALL DAXPY(K-1,B(K),A(1,K),1,B(1),1) 30 CONTINUE C C APPLY D INVERSE. C B(K) = B(K)/A(K,K) K = K - 1 GO TO 70 40 CONTINUE C C 2 X 2 PIVOT BLOCK. C IF (K .EQ. 2) GO TO 60 KP = IABS(KPVT(K)) IF (KP .EQ. K - 1) GO TO 50 C C INTERCHANGE. C TEMP = B(K-1) B(K-1) = B(KP) B(KP) = TEMP 50 CONTINUE C C APPLY THE TRANSFORMATION. C CALL DAXPY(K-2,B(K),A(1,K),1,B(1),1) CALL DAXPY(K-2,B(K-1),A(1,K-1),1,B(1),1) 60 CONTINUE C C APPLY D INVERSE. C AK = A(K,K)/A(K-1,K) AKM1 = A(K-1,K-1)/A(K-1,K) BK = B(K)/A(K-1,K) BKM1 = B(K-1)/A(K-1,K) DENOM = AK*AKM1 - 1.0D0 B(K) = (AKM1*BK - BKM1)/DENOM B(K-1) = (AK*BKM1 - BK)/DENOM K = K - 2 70 CONTINUE GO TO 10 80 CONTINUE C C LOOP FORWARD APPLYING THE TRANSFORMATIONS. C K = 1 90 IF (K .GT. N) GO TO 160 IF (KPVT(K) .LT. 0) GO TO 120 C C 1 X 1 PIVOT BLOCK. C IF (K .EQ. 1) GO TO 110 C C APPLY THE TRANSFORMATION. C B(K) = B(K) + DDOT(K-1,A(1,K),1,B(1),1) KP = KPVT(K) IF (KP .EQ. K) GO TO 100 C C INTERCHANGE. C TEMP = B(K) B(K) = B(KP) B(KP) = TEMP 100 CONTINUE 110 CONTINUE K = K + 1 GO TO 150 120 CONTINUE C C 2 X 2 PIVOT BLOCK. C IF (K .EQ. 1) GO TO 140 C C APPLY THE TRANSFORMATION. C B(K) = B(K) + DDOT(K-1,A(1,K),1,B(1),1) B(K+1) = B(K+1) + DDOT(K-1,A(1,K+1),1,B(1),1) KP = IABS(KPVT(K)) IF (KP .EQ. K) GO TO 130 C C INTERCHANGE. C TEMP = B(K) B(K) = B(KP) B(KP) = TEMP 130 CONTINUE 140 CONTINUE K = K + 2 150 CONTINUE GO TO 90 160 CONTINUE RETURN END SUBROUTINE XDSIDI(A,LDA,N,KPVT,DET,INERT,WORK,JOB) INTEGER LDA,N,JOB DOUBLE PRECISION A(LDA,*),WORK(*) DOUBLE PRECISION DET(2) INTEGER KPVT(*),INERT(3) C C XDSIDI COMPUTES THE DETERMINANT, INERTIA AND INVERSE C OF A DOUBLE PRECISION SYMMETRIC MATRIX USING THE FACTORS FROM C XDSIFA. C C ON ENTRY C C A DOUBLE PRECISION(LDA,N) C THE OUTPUT FROM XDSIFA. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A. C C N INTEGER C THE ORDER OF THE MATRIX A. C C KPVT INTEGER(N) C THE PIVOT VECTOR FROM XDSIFA. C C WORK DOUBLE PRECISION(N) C WORK VECTOR. CONTENTS DESTROYED. C C JOB INTEGER C JOB HAS THE DECIMAL EXPANSION ABC WHERE C IF C .NE. 0, THE INVERSE IS COMPUTED, C IF B .NE. 0, THE DETERMINANT IS COMPUTED, C IF A .NE. 0, THE INERTIA IS COMPUTED. C C FOR EXAMPLE, JOB = 111 GIVES ALL THREE. C C ON RETURN C C VARIABLES NOT REQUESTED BY JOB ARE NOT USED. C C A CONTAINS THE UPPER TRIANGLE OF THE INVERSE OF C THE ORIGINAL MATRIX. THE STRICT LOWER TRIANGLE C IS NEVER REFERENCED. C C DET DOUBLE PRECISION(2) C DETERMINANT OF ORIGINAL MATRIX. C DETERMINANT = DET(1) * 10.0**DET(2) C WITH 1.0 .LE. DABS(DET(1)) .LT. 10.0 C OR DET(1) = 0.0. C C INERT INTEGER(3) C THE INERTIA OF THE ORIGINAL MATRIX. C INERT(1) = NUMBER OF POSITIVE EIGENVALUES. C INERT(2) = NUMBER OF NEGATIVE EIGENVALUES. C INERT(3) = NUMBER OF ZERO EIGENVALUES. C C ERROR CONDITION C C A DIVISION BY ZERO MAY OCCUR IF THE INVERSE IS REQUESTED C AND DSICO HAS SET RCOND .EQ. 0.0 C OR XDSIFA HAS SET INFO .NE. 0 . C C LINPACK. THIS VERSION DATED 08/14/78 . C JAMES BUNCH, UNIV. CALIF. SAN DIEGO, ARGONNE NAT. LAB C C SUBROUTINES AND FUNCTIONS C C BLAS DAXPY,DCOPY,DDOT,DSWAP C FORTRAN DABS,IABS,MOD C C INTERNAL VARIABLES. C DOUBLE PRECISION AKKP1,DDOT,TEMP DOUBLE PRECISION TEN,D,T,AK,AKP1 INTEGER J,JB,K,KM1,KS,KSTEP LOGICAL NOINV,NODET,NOERT C NOINV = MOD(JOB,10) .EQ. 0 NODET = MOD(JOB,100)/10 .EQ. 0 NOERT = MOD(JOB,1000)/100 .EQ. 0 C IF (NODET .AND. NOERT) GO TO 140 IF (NOERT) GO TO 10 INERT(1) = 0 INERT(2) = 0 INERT(3) = 0 10 CONTINUE IF (NODET) GO TO 20 DET(1) = 1.0D0 DET(2) = 0.0D0 TEN = 10.0D0 20 CONTINUE T = 0.0D0 DO 130 K = 1, N D = A(K,K) C C CHECK IF 1 BY 1 C IF (KPVT(K) .GT. 0) GO TO 50 C C 2 BY 2 BLOCK C USE DET (D S) = (D/T * C - T) * T , T = DABS(S) C (S C) C TO AVOID UNDERFLOW/OVERFLOW TROUBLES. C TAKE TWO PASSES THROUGH SCALING. USE T FOR FLAG. C IF (T .NE. 0.0D0) GO TO 30 T = DABS(A(K,K+1)) D = (D/T)*A(K+1,K+1) - T GO TO 40 30 CONTINUE D = T T = 0.0D0 40 CONTINUE 50 CONTINUE C IF (NOERT) GO TO 60 IF (D .GT. 0.0D0) INERT(1) = INERT(1) + 1 IF (D .LT. 0.0D0) INERT(2) = INERT(2) + 1 IF (D .EQ. 0.0D0) INERT(3) = INERT(3) + 1 60 CONTINUE C IF (NODET) GO TO 120 DET(1) = D*DET(1) IF (DET(1) .EQ. 0.0D0) GO TO 110 70 IF (DABS(DET(1)) .GE. 1.0D0) GO TO 80 DET(1) = TEN*DET(1) DET(2) = DET(2) - 1.0D0 GO TO 70 80 CONTINUE 90 IF (DABS(DET(1)) .LT. TEN) GO TO 100 DET(1) = DET(1)/TEN DET(2) = DET(2) + 1.0D0 GO TO 90 100 CONTINUE 110 CONTINUE 120 CONTINUE 130 CONTINUE 140 CONTINUE C C COMPUTE INVERSE(A) C IF (NOINV) GO TO 270 K = 1 150 IF (K .GT. N) GO TO 260 KM1 = K - 1 IF (KPVT(K) .LT. 0) GO TO 180 C C 1 BY 1 C A(K,K) = 1.0D0/A(K,K) IF (KM1 .LT. 1) GO TO 170 CALL DCOPY(KM1,A(1,K),1,WORK,1) DO 160 J = 1, KM1 A(J,K) = DDOT(J,A(1,J),1,WORK,1) CALL DAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1) 160 CONTINUE A(K,K) = A(K,K) + DDOT(KM1,WORK,1,A(1,K),1) 170 CONTINUE KSTEP = 1 GO TO 220 180 CONTINUE C C 2 BY 2 C T = DABS(A(K,K+1)) AK = A(K,K)/T AKP1 = A(K+1,K+1)/T AKKP1 = A(K,K+1)/T D = T*(AK*AKP1 - 1.0D0) A(K,K) = AKP1/D A(K+1,K+1) = AK/D A(K,K+1) = -AKKP1/D IF (KM1 .LT. 1) GO TO 210 CALL DCOPY(KM1,A(1,K+1),1,WORK,1) DO 190 J = 1, KM1 A(J,K+1) = DDOT(J,A(1,J),1,WORK,1) CALL DAXPY(J-1,WORK(J),A(1,J),1,A(1,K+1),1) 190 CONTINUE A(K+1,K+1) = A(K+1,K+1) + DDOT(KM1,WORK,1,A(1,K+1),1) A(K,K+1) = A(K,K+1) + DDOT(KM1,A(1,K),1,A(1,K+1),1) CALL DCOPY(KM1,A(1,K),1,WORK,1) DO 200 J = 1, KM1 A(J,K) = DDOT(J,A(1,J),1,WORK,1) CALL DAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1) 200 CONTINUE A(K,K) = A(K,K) + DDOT(KM1,WORK,1,A(1,K),1) 210 CONTINUE KSTEP = 2 220 CONTINUE C C SWAP C KS = IABS(KPVT(K)) IF (KS .EQ. K) GO TO 250 CALL DSWAP(KS,A(1,KS),1,A(1,K),1) DO 230 JB = KS, K J = K + KS - JB TEMP = A(J,K) A(J,K) = A(KS,J) A(KS,J) = TEMP 230 CONTINUE IF (KSTEP .EQ. 1) GO TO 240 TEMP = A(KS,K+1) A(KS,K+1) = A(K,K+1) A(K,K+1) = TEMP 240 CONTINUE 250 CONTINUE K = K + KSTEP GO TO 150 260 CONTINUE 270 CONTINUE RETURN END C******************************************************************************* SUBROUTINE XSSORT(X,Y,N,KFLAG) C***BEGIN PROLOGUE XSSORT C***DATE WRITTEN 761101 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. N6A2B1 C***KEYWORDS QUICKSORT,SINGLETON QUICKSORT,SORT,SORTING C***AUTHOR JONES, R. E., (SNLA) C WISNIEWSKI, J. A., (SNLA) C***PURPOSE XSSORT sorts array X and optionally makes the same C interchanges in array Y. The array X may be sorted in C increasing order or decreasing order. A slightly modified C QUICKSORT algorithm is used. C***DESCRIPTION C C Written by Rondall E. Jones C Modified by John A. Wisniewski to use the Singleton quicksort C algorithm. Date 18 November 1976. C C Abstract C XSSORT sorts array X and optionally makes the same C interchanges in array Y. The array X may be sorted in C increasing order or decreasing order. A slightly modified C quicksort algorithm is used. C C Reference C Singleton, R. C., Algorithm 347, An Efficient Algorithm for C Sorting with Minimal Storage, CACM,12(3),1969,185-7. C C Description of Parameters C X - array of values to be sorted (usually abscissas) C Y - array to be (optionally) carried along C N - number of values in array X to be sorted C KFLAG - control parameter C =2 means sort X in increasing order and carry Y along. C =1 means sort X in increasing order (ignoring Y) C =-1 means sort X in decreasing order (ignoring Y) C =-2 means sort X in decreasing order and carry Y along. C***REFERENCES SINGLETON,R.C., ALGORITHM 347, AN EFFICIENT ALGORITHM C FOR SORTING WITH MINIMAL STORAGE, CACM,12(3),1969, C 185-7. C***END PROLOGUE XSSORT INTEGER I,IL(21),IU(21),N,NN,KK,KFLAG,J,M,IJ,L,K DOUBLE PRECISION X(N),Y(N),R,T,TY,TTY,TT C***FIRST EXECUTABLE STATEMENT XSSORT NN = N IF (NN.GE.1) GO TO 10 RETURN 10 KK = IABS(KFLAG) IF ((KK.EQ.1).OR.(KK.EQ.2)) GO TO 15 RETURN C C ALTER ARRAY X TO GET DECREASING ORDER IF NEEDED C 15 IF (KFLAG.GE.1) GO TO 30 DO 20 I=1,NN 20 X(I) = -X(I) 30 GO TO (100,200),KK C C SORT X ONLY C 100 CONTINUE M=1 I=1 J=NN R=.375 110 IF (I .EQ. J) GO TO 155 115 IF (R .GT. .5898437) GO TO 120 R=R+3.90625E-2 GO TO 125 120 R=R-.21875 125 K=I C SELECT A CENTRAL ELEMENT OF THE C ARRAY AND SAVE IT IN LOCATION T IJ = I + (DFLOAT (J-I) * R) T=X(IJ) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN T, INTERCHANGE WITH T IF (X(I) .LE. T) GO TO 130 X(IJ)=X(I) X(I)=T T=X(IJ) 130 L=J C IF LAST ELEMENT OF ARRAY IS LESS THAN C T, INTERCHANGE WITH T IF (X(J) .GE. T) GO TO 140 X(IJ)=X(J) X(J)=T T=X(IJ) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN T, INTERCHANGE WITH T IF (X(I) .LE. T) GO TO 140 X(IJ)=X(I) X(I)=T T=X(IJ) GO TO 140 135 TT=X(L) X(L)=X(K) X(K)=TT C FIND AN ELEMENT IN THE SECOND HALF OF C THE ARRAY WHICH IS SMALLER THAN T 140 L=L-1 IF (X(L) .GT. T) GO TO 140 C FIND AN ELEMENT IN THE FIRST HALF OF C THE ARRAY WHICH IS GREATER THAN T 145 K=K+1 IF (X(K) .LT. T) GO TO 145 C INTERCHANGE THESE ELEMENTS IF (K .LE. L) GO TO 135 C SAVE UPPER AND LOWER SUBSCRIPTS OF C THE ARRAY YET TO BE SORTED IF (L-I .LE. J-K) GO TO 150 IL(M)=I IU(M)=L I=K M=M+1 GO TO 160 150 IL(M)=K IU(M)=J J=L M=M+1 GO TO 160 C BEGIN AGAIN ON ANOTHER PORTION OF C THE UNSORTED ARRAY 155 M=M-1 IF (M .EQ. 0) GO TO 300 I=IL(M) J=IU(M) 160 IF (J-I .GE. 1) GO TO 125 IF (I .EQ. 1) GO TO 110 I=I-1 165 I=I+1 IF (I .EQ. J) GO TO 155 T=X(I+1) IF (X(I) .LE. T) GO TO 165 K=I 170 X(K+1)=X(K) K=K-1 IF (T .LT. X(K)) GO TO 170 X(K+1)=T GO TO 165 C C SORT X AND CARRY Y ALONG C 200 CONTINUE M=1 I=1 J=NN R=.375 210 IF (I .EQ. J) GO TO 255 215 IF (R .GT. .5898437) GO TO 220 R=R+3.90625E-2 GO TO 225 220 R=R-.21875 225 K=I C SELECT A CENTRAL ELEMENT OF THE C ARRAY AND SAVE IT IN LOCATION T IJ = I + (DFLOAT (J-I) *R) T=X(IJ) TY= Y(IJ) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN T, INTERCHANGE WITH T IF (X(I) .LE. T) GO TO 230 X(IJ)=X(I) X(I)=T T=X(IJ) Y(IJ)= Y(I) Y(I)=TY TY= Y(IJ) 230 L=J C IF LAST ELEMENT OF ARRAY IS LESS THAN C T, INTERCHANGE WITH T IF (X(J) .GE. T) GO TO 240 X(IJ)=X(J) X(J)=T T=X(IJ) Y(IJ)= Y(J) Y(J)=TY TY= Y(IJ) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN T, INTERCHANGE WITH T IF (X(I) .LE. T) GO TO 240 X(IJ)=X(I) X(I)=T T=X(IJ) Y(IJ)= Y(I) Y(I)=TY TY= Y(IJ) GO TO 240 235 TT=X(L) X(L)=X(K) X(K)=TT TTY= Y(L) Y(L)= Y(K) Y(K)=TTY C FIND AN ELEMENT IN THE SECOND HALF OF C THE ARRAY WHICH IS SMALLER THAN T 240 L=L-1 IF (X(L) .GT. T) GO TO 240 C FIND AN ELEMENT IN THE FIRST HALF OF C THE ARRAY WHICH IS GREATER THAN T 245 K=K+1 IF (X(K) .LT. T) GO TO 245 C INTERCHANGE THESE ELEMENTS IF (K .LE. L) GO TO 235 C SAVE UPPER AND LOWER SUBSCRIPTS OF C THE ARRAY YET TO BE SORTED IF (L-I .LE. J-K) GO TO 250 IL(M)=I IU(M)=L I=K M=M+1 GO TO 260 250 IL(M)=K IU(M)=J J=L M=M+1 GO TO 260 C BEGIN AGAIN ON ANOTHER PORTION OF C THE UNSORTED ARRAY 255 M=M-1 IF (M .EQ. 0) GO TO 300 I=IL(M) J=IU(M) 260 IF (J-I .GE. 1) GO TO 225 IF (I .EQ. 1) GO TO 210 I=I-1 265 I=I+1 IF (I .EQ. J) GO TO 255 T=X(I+1) TY= Y(I+1) IF (X(I) .LE. T) GO TO 265 K=I 270 X(K+1)=X(K) Y(K+1)= Y(K) K=K-1 IF (T .LT. X(K)) GO TO 270 X(K+1)=T Y(K+1)=TY GO TO 265 C C CLEAN UP C 300 IF (KFLAG.GE.1) RETURN DO 310 I=1,NN 310 X(I) = -X(I) RETURN END SUBROUTINE XDSICO(A,LDA,N,KPVT,RCOND,Z) INTEGER LDA,N,KPVT(*) DOUBLE PRECISION A(LDA,*),Z(*) DOUBLE PRECISION RCOND C C DSICO FACTORS A DOUBLE PRECISION SYMMETRIC MATRIX BY ELIMINATION C WITH SYMMETRIC PIVOTING AND ESTIMATES THE CONDITION OF THE C MATRIX. C C IF RCOND IS NOT NEEDED, DSIFA IS SLIGHTLY FASTER. C TO SOLVE A*X = B , FOLLOW DSICO BY DSISL. C TO COMPUTE INVERSE(A)*C , FOLLOW DSICO BY DSISL. C TO COMPUTE INVERSE(A) , FOLLOW DSICO BY DSIDI. C TO COMPUTE DETERMINANT(A) , FOLLOW DSICO BY DSIDI. C TO COMPUTE INERTIA(A), FOLLOW DSICO BY DSIDI. C C ON ENTRY C C A DOUBLE PRECISION(LDA, N) C THE SYMMETRIC MATRIX TO BE FACTORED. C ONLY THE DIAGONAL AND UPPER TRIANGLE ARE USED. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C C N INTEGER C THE ORDER OF THE MATRIX A . C C OUTPUT C C A A BLOCK DIAGONAL MATRIX AND THE MULTIPLIERS WHICH C WERE USED TO OBTAIN IT. C THE FACTORIZATION CAN BE WRITTEN A = U*D*TRANS(U) C WHERE U IS A PRODUCT OF PERMUTATION AND UNIT C UPPER TRIANGULAR MATRICES , TRANS(U) IS THE C TRANSPOSE OF U , AND D IS BLOCK DIAGONAL C WITH 1 BY 1 AND 2 BY 2 BLOCKS. C C KPVT INTEGER(N) C AN INTEGER VECTOR OF PIVOT INDICES. C C RCOND DOUBLE PRECISION C AN ESTIMATE OF THE RECIPROCAL CONDITION OF A . C FOR THE SYSTEM A*X = B , RELATIVE PERTURBATIONS C IN A AND B OF SIZE EPSILON MAY CAUSE C RELATIVE PERTURBATIONS IN X OF SIZE EPSILON/RCOND . C IF RCOND IS SO SMALL THAT THE LOGICAL EXPRESSION C 1.0 + RCOND .EQ. 1.0 C IS TRUE, THEN A MAY BE SINGULAR TO WORKING C PRECISION. IN PARTICULAR, RCOND IS ZERO IF C EXACT SINGULARITY IS DETECTED OR THE ESTIMATE C UNDERFLOWS. C C Z DOUBLE PRECISION(N) C A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT. C IF A IS CLOSE TO A SINGULAR MATRIX, THEN Z IS C AN APPROXIMATE NULL VECTOR IN THE SENSE THAT C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C LINPACK DSIFA C BLAS DAXPY,DDOT,DSCAL,DASUM C FORTRAN DABS,DMAX1,IABS,DSIGN C C INTERNAL VARIABLES C DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,EK,T DOUBLE PRECISION ANORM,S,DASUM,YNORM INTEGER I,INFO,J,JM1,K,KP,KPS,KS C C C FIND NORM OF A USING ONLY UPPER HALF C DO 30 J = 1, N Z(J) = DASUM(J,A(1,J),1) JM1 = J - 1 IF (JM1 .LT. 1) GO TO 20 DO 10 I = 1, JM1 Z(I) = Z(I) + DABS(A(I,J)) 10 CONTINUE 20 CONTINUE 30 CONTINUE ANORM = 0.0D0 DO 40 J = 1, N ANORM = DMAX1(ANORM,Z(J)) 40 CONTINUE C C FACTOR C CALL XDSIFA(A,LDA,N,KPVT,INFO) C C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL C GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. C C SOLVE U*D*W = E C EK = 1.0D0 DO 50 J = 1, N Z(J) = 0.0D0 50 CONTINUE K = N 60 IF (K .EQ. 0) GO TO 120 KS = 1 IF (KPVT(K) .LT. 0) KS = 2 KP = IABS(KPVT(K)) KPS = K + 1 - KS IF (KP .EQ. KPS) GO TO 70 T = Z(KPS) Z(KPS) = Z(KP) Z(KP) = T 70 CONTINUE C IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,Z(K)) IF (Z(K) * EK .LT.0.0D0) EK = - EK Z(K) = Z(K) + EK CALL DAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) IF (KS .EQ. 1) GO TO 80 C IF (Z(K-1) .NE. 0.0D0) EK = DSIGN(EK,Z(K-1)) IF (Z(K-1) * EK .LT.0.0D0) EK = - EK Z(K-1) = Z(K-1) + EK CALL DAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) 80 CONTINUE IF (KS .EQ. 2) GO TO 100 IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 90 S = DABS(A(K,K))/DABS(Z(K)) CALL DSCAL(N,S,Z,1) EK = S*EK 90 CONTINUE IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 GO TO 110 100 CONTINUE AK = A(K,K)/A(K-1,K) AKM1 = A(K-1,K-1)/A(K-1,K) BK = Z(K)/A(K-1,K) BKM1 = Z(K-1)/A(K-1,K) DENOM = AK*AKM1 - 1.0D0 Z(K) = (AKM1*BK - BKM1)/DENOM Z(K-1) = (AK*BKM1 - BK)/DENOM 110 CONTINUE K = K - KS GO TO 60 120 CONTINUE S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) C C SOLVE TRANS(U)*Y = W C K = 1 130 IF (K .GT. N) GO TO 160 KS = 1 IF (KPVT(K) .LT. 0) KS = 2 IF (K .EQ. 1) GO TO 150 Z(K) = Z(K) + DDOT(K-1,A(1,K),1,Z(1),1) IF (KS .EQ. 2) * Z(K+1) = Z(K+1) + DDOT(K-1,A(1,K+1),1,Z(1),1) KP = IABS(KPVT(K)) IF (KP .EQ. K) GO TO 140 T = Z(K) Z(K) = Z(KP) Z(KP) = T 140 CONTINUE 150 CONTINUE K = K + KS GO TO 130 160 CONTINUE S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) C YNORM = 1.0D0 C C SOLVE U*D*V = Y C K = N 170 IF (K .EQ. 0) GO TO 230 KS = 1 IF (KPVT(K) .LT. 0) KS = 2 IF (K .EQ. KS) GO TO 190 KP = IABS(KPVT(K)) KPS = K + 1 - KS IF (KP .EQ. KPS) GO TO 180 T = Z(KPS) Z(KPS) = Z(KP) Z(KP) = T 180 CONTINUE CALL DAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) IF (KS .EQ. 2) CALL DAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) 190 CONTINUE IF (KS .EQ. 2) GO TO 210 IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 200 S = DABS(A(K,K))/DABS(Z(K)) CALL DSCAL(N,S,Z,1) YNORM = S*YNORM 200 CONTINUE IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 GO TO 220 210 CONTINUE AK = A(K,K)/A(K-1,K) AKM1 = A(K-1,K-1)/A(K-1,K) BK = Z(K)/A(K-1,K) BKM1 = Z(K-1)/A(K-1,K) DENOM = AK*AKM1 - 1.0D0 Z(K) = (AKM1*BK - BKM1)/DENOM Z(K-1) = (AK*BKM1 - BK)/DENOM 220 CONTINUE K = K - KS GO TO 170 230 CONTINUE S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) YNORM = S*YNORM C C SOLVE TRANS(U)*Z = V C K = 1 240 IF (K .GT. N) GO TO 270 KS = 1 IF (KPVT(K) .LT. 0) KS = 2 IF (K .EQ. 1) GO TO 260 Z(K) = Z(K) + DDOT(K-1,A(1,K),1,Z(1),1) IF (KS .EQ. 2) * Z(K+1) = Z(K+1) + DDOT(K-1,A(1,K+1),1,Z(1),1) KP = IABS(KPVT(K)) IF (KP .EQ. K) GO TO 250 T = Z(K) Z(K) = Z(KP) Z(KP) = T 250 CONTINUE 260 CONTINUE K = K + KS GO TO 240 270 CONTINUE C MAKE ZNORM = 1.0 S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) YNORM = S*YNORM C IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0 RETURN END SUBROUTINE XDGEFA(A,LDA,N,IPVT,INFO) INTEGER LDA,N,IPVT(*),INFO DOUBLE PRECISION A(LDA,*) DOUBLE PRECISION T INTEGER IDAMAX,J,K,KP1,L,NM1 INFO = 0 NM1 = N - 1 IF (NM1 .LT. 1) GO TO 70 DO 60 K = 1, NM1 KP1 = K + 1 L = IDAMAX(N-K+1,A(K,K),1) + K - 1 IPVT(K) = L IF (A(L,K) .EQ. 0.0D0) GO TO 40 IF (L .EQ. K) GO TO 10 T = A(L,K) A(L,K) = A(K,K) A(K,K) = T 10 CONTINUE T = -1.0D0/A(K,K) CALL DSCAL(N-K,T,A(K+1,K),1) DO 30 J = KP1, N T = A(L,J) IF (L .EQ. K) GO TO 20 A(L,J) = A(K,J) A(K,J) = T 20 CONTINUE CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) 30 CONTINUE GO TO 50 40 CONTINUE INFO = K 50 CONTINUE 60 CONTINUE 70 CONTINUE IPVT(N) = N IF (A(N,N) .EQ. 0.0D0) INFO = N RETURN END SUBROUTINE XDGEDI(A,LDA,N,IPVT,DET,WORK,JOB) INTEGER LDA,N,IPVT(*),JOB DOUBLE PRECISION A(LDA,*),DET(2),WORK(*) DOUBLE PRECISION T DOUBLE PRECISION TEN INTEGER I,J,K,KB,KP1,L,NM1 IF (JOB/10 .EQ. 0) GO TO 70 DET(1) = 1.0D0 DET(2) = 0.0D0 TEN = 10.0D0 DO 50 I = 1, N IF (IPVT(I) .NE. I) DET(1) = -DET(1) DET(1) = A(I,I)*DET(1) IF (DET(1) .EQ. 0.0D0) GO TO 60 10 IF (DABS(DET(1)) .GE. 1.0D0) GO TO 20 DET(1) = TEN*DET(1) DET(2) = DET(2) - 1.0D0 GO TO 10 20 CONTINUE 30 IF (DABS(DET(1)) .LT. TEN) GO TO 40 DET(1) = DET(1)/TEN DET(2) = DET(2) + 1.0D0 GO TO 30 40 CONTINUE 50 CONTINUE 60 CONTINUE 70 CONTINUE IF (MOD(JOB,10) .EQ. 0) GO TO 150 DO 100 K = 1, N A(K,K) = 1.0D0/A(K,K) T = -A(K,K) CALL DSCAL(K-1,T,A(1,K),1) KP1 = K + 1 IF (N .LT. KP1) GO TO 90 DO 80 J = KP1, N T = A(K,J) A(K,J) = 0.0D0 CALL DAXPY(K,T,A(1,K),1,A(1,J),1) 80 CONTINUE 90 CONTINUE 100 CONTINUE NM1 = N - 1 IF (NM1 .LT. 1) GO TO 140 DO 130 KB = 1, NM1 K = N - KB KP1 = K + 1 DO 110 I = KP1, N WORK(I) = A(I,K) A(I,K) = 0.0D0 110 CONTINUE DO 120 J = KP1, N T = WORK(J) CALL DAXPY(N,T,A(1,J),1,A(1,K),1) 120 CONTINUE L = IPVT(K) IF (L .NE. K) CALL DSWAP(N,A(1,K),1,A(1,L),1) 130 CONTINUE 140 CONTINUE 150 CONTINUE RETURN END SUBROUTINE XDGESL(A,LDA,N,IPVT,B,JOB) INTEGER LDA,N,IPVT(*),JOB DOUBLE PRECISION A(LDA,*),B(*) C C DGESL SOLVES THE DOUBLE PRECISION SYSTEM C A * X = B OR TRANS(A) * X = B C USING THE FACTORS COMPUTED BY DGECO OR DGEFA. C C ON ENTRY C C A DOUBLE PRECISION(LDA, N) C THE OUTPUT FROM DGECO OR DGEFA. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C C N INTEGER C THE ORDER OF THE MATRIX A . C C IPVT INTEGER(N) C THE PIVOT VECTOR FROM DGECO OR DGEFA. C C B DOUBLE PRECISION(N) C THE RIGHT HAND SIDE VECTOR. C C JOB INTEGER C = 0 TO SOLVE A*X = B , C = NONZERO TO SOLVE TRANS(A)*X = B WHERE C TRANS(A) IS THE TRANSPOSE. C C ON RETURN C C B THE SOLUTION VECTOR X . C C ERROR CONDITION C C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A C ZERO ON THE DIAGONAL. TECHNICALLY THIS INDICATES SINGULARITY C BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER C SETTING OF LDA . IT WILL NOT OCCUR IF THE SUBROUTINES ARE C CALLED CORRECTLY AND IF DGECO HAS SET RCOND .GT. 0.0 C OR DGEFA HAS SET INFO .EQ. 0 . C C TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX C WITH P COLUMNS C CALL DGECO(A,LDA,N,IPVT,RCOND,Z) C IF (RCOND IS TOO SMALL) GO TO ... C DO 10 J = 1, P C CALL DGESL(A,LDA,N,IPVT,C(1,J),0) C 10 CONTINUE C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS DAXPY,DDOT C INTERNAL VARIABLES C DOUBLE PRECISION DDOT,T INTEGER K,KB,L,NM1 C NM1 = N - 1 IF (JOB .NE. 0) GO TO 50 C C JOB = 0 , SOLVE A * X = B C FIRST SOLVE L*Y = B C IF (NM1 .LT. 1) GO TO 30 DO 20 K = 1, NM1 L = IPVT(K) T = B(L) IF (L .EQ. K) GO TO 10 B(L) = B(K) B(K) = T 10 CONTINUE CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1) 20 CONTINUE 30 CONTINUE C C NOW SOLVE U*X = Y C DO 40 KB = 1, N K = N + 1 - KB B(K) = B(K)/A(K,K) T = -B(K) CALL DAXPY(K-1,T,A(1,K),1,B(1),1) 40 CONTINUE GO TO 100 50 CONTINUE C C JOB = NONZERO, SOLVE TRANS(A) * X = B C FIRST SOLVE TRANS(U)*Y = B C DO 60 K = 1, N T = DDOT(K-1,A(1,K),1,B(1),1) B(K) = (B(K) - T)/A(K,K) 60 CONTINUE C C NOW SOLVE TRANS(L)*X = Y C IF (NM1 .LT. 1) GO TO 90 DO 80 KB = 1, NM1 K = N - KB B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1) L = IPVT(K) IF (L .EQ. K) GO TO 70 T = B(L) B(L) = B(K) B(K) = T 70 CONTINUE 80 CONTINUE 90 CONTINUE 100 CONTINUE RETURN END logspline/src/nlsd.c0000644000176200001440000024307412654166601014162 0ustar liggesusers/* * * Copyright [1993-2016] [Charles Kooperberg] * * Licensed under the Apache License, Version 2.0 (the "License"); * you may not use this file except in compliance with the License. * You may obtain a copy of the License at * * http://www.apache.org/licenses/LICENSE-2.0 * * Unless required by applicable law or agreed to in writing, software * distributed under the License is distributed on an "AS IS" BASIS, * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. * See the License for the specific language governing permissions and * limitations under the License. * Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. * */ #include #include #include "R.h" #define Salloc(n, t) (t *)R_alloc((long)(n), (int)sizeof(t)) #define MAXKNOTS 60 struct datastruct { int ndata; double *data; int *idata; short *same; }; /* ndata; ndat - # number of cases dat - data idat - the ips are the integration points: idat indicates what the integration point immediately to the left of a datapoint is same - is the observation the same as the previous in the same category? kdata - relates the total order to the data, if kdata[37]=(0,18), the 37th datapoint is #18 in dat0: a first index of 2 refers to dat2 3 to dat3, 4 to the first column of dat4 and 5 to the second column of dat4 */ struct space { int ndim,nk,nip,*iknots,ilow,iupp; double *knots,aic,**info,*score,*ips,low,upp,cth; struct basisfunct *basis; }; /* ndim - dimension nk - number of knots (=ndim+1) nip - number of integration points iknots - datapoint at or just left of knot ilow - is the lower bound -infinity? (1=yes) iupp - is the upper bound +infinity? (1=yes) knots - the knots aic - present value of aic info - the hessian score - score function ips - integration points low - lower integration boundary upp - upper integration boundary cth - ctheta */ struct basisfunct { double beta,*c1,**c2,sumunc; int c3[2],iks[5]; }; /* beta - coefficient c1 - to translate the basis function in the truncated power basis c2 - to translate the basisfunction at an integration point in a polynomial c3 - first and last integration point for which this function is nonzero iks - which knots are involved with this basisfunction - integrationpt sumunc - sum_i B(x_i) over the uncensored data */ static int *isvector(); static short *issvector(); static double *dsvector(),**dsmatrix(); static int nlsd(); static struct space *definespace(); static void getsame(); static void five(); static void five01(); static void five00(); static void lubksb(); static int ludcmp(); static int adddim(); static int findyl(); static int findyr(); static int findl(); static int findr(); static int findm(); static int dlocation(); static void betaadd(); static int iter(); static int iterx(); static double pompall(); static void savecode1(); static int savecoden(); static void initk(); static double rao(); static double praox(); static int getnewc2(); static double save22coden(); static void remdim(); static void betarem(); static void redo1(); static void redo2(); static void solver(); static void getc2(); static void getc1(); static void getonec1(); static void setupspace(); static int startspace(); static void startnow(); static int rearrange(); static void getip(); static void getp0(); static void getq0(); static void getp2(); static void getq2(); static void getp1(); static void getq1(); static double z1int(); static double z2int(); static double z3int(); static double pqexpi(); static double getf(); static double mylog(); static double myexp(); static void m1int(); static void l1int(); static void l2int(); static double fctf1(); static double fctf2(); static double pol3(); static double inp3(); static double mat3(); static void swapspace(); static void quadalloc(); /* allocation */ static int lusolve2(); static void luinverse(); /* matrix inversion, solve a system */ static double ctheta,*betaaddsorted; static double **kints,*cuu; /* see piter - partial integrals and so on, which we want to keep */ static struct basisfunct *bbx; /* storage */ static double ww6[7],yy6[7],ww7[33],yy7[33],*pompalcy,**pompalcyy; static int *rearix,*getiips,*luwi; static double *fiveee,*fiveh1,*fiverr,*betaaddv1,*betaremr1,*raoss,*luw,*luw2,**luww; static double *itertmp1,*itertmp2,*rearsorted,**solc1,**solc2,**solc3; static double **itertmp3,**pompcoef,**betaaddt1,**raoii,**raoc2,**betaremm2; /******************************************************************************/ void nlogcensorx(intpars) int *intpars; { intpars[0]=MAXKNOTS+5; return; } void nlogcensor(intpars,data0,dpars,logs,ad,kts) int *intpars,*ad; double *data0,*logs,*kts,*dpars; /* data0 - uncensored data; coefs on exit intpars- integer parameters dpars - double parameters ad - is a model added during addition (1), deletion (2) or not at all kts - knots */ { struct datastruct *data; struct space *spc; int i,j,strt,mind,ndmax,silent; double x,y,alpha; /* data - datastructure for all the data spc - datastructure for a model definespace - allocation for a model i,j - counters k - one line for kdata nlsd- does the work strt - where starting knots provided mind - minimum distance between knots ndmax - maximum dimension, the sign indicates whether it should be attained silent- print diagnostic output? (1=yes) alpha - penalty parameter x,y - utility */ /* we only want parameters and leave... */ if(intpars[0]<-10){ intpars[0]=MAXKNOTS+5; return; } /* define the data */ data=(struct datastruct *)Salloc(1,struct datastruct); (*data).ndata=intpars[0]; (*data).data=data0; (*data).same=issvector(intpars[0]+1); /* get the "same" vectors */ getsame(data0,intpars[0],(*data).same); (*data).idata=isvector(intpars[0]); /* allocate the space */ spc=definespace((*data).ndata); getiips=isvector((*spc).nip+10); luwi=isvector(2*MAXKNOTS+20); rearix=isvector((*data).ndata); fiverr=dsvector((*data).ndata+2*MAXKNOTS); fiveee=dsvector((*data).ndata+MAXKNOTS+5); fiveh1=dsvector((*data).ndata+MAXKNOTS+5); betaaddv1=dsvector((*data).ndata+MAXKNOTS+5); betaremr1=dsvector((*data).ndata+MAXKNOTS+5); raoss=dsvector((*data).ndata+MAXKNOTS+5); itertmp1=dsvector((*data).ndata+MAXKNOTS+5); itertmp2=dsvector((*data).ndata+MAXKNOTS+5); rearsorted=dsvector((*data).ndata+MAXKNOTS+5); luw=dsvector(2*MAXKNOTS+20); luw2=dsvector(2*MAXKNOTS+20); itertmp3=dsmatrix(MAXKNOTS+5,MAXKNOTS+5); solc1=dsmatrix(MAXKNOTS+5,MAXKNOTS+5); solc2=dsmatrix(MAXKNOTS+5,MAXKNOTS+5); solc3=dsmatrix(MAXKNOTS+5,MAXKNOTS+5); luww=dsmatrix(2*MAXKNOTS+20,2*MAXKNOTS+20); pompcoef=dsmatrix((*spc).nip+2,4); betaaddt1=dsmatrix(MAXKNOTS+5,MAXKNOTS+5); betaremm2=dsmatrix(MAXKNOTS+5,MAXKNOTS+5); raoii=dsmatrix(MAXKNOTS+5,MAXKNOTS+5); raoc2=dsmatrix((*spc).nip+10,(*spc).nip+10); pompalcy=dsvector(2*MAXKNOTS+10); betaaddsorted=dsvector((*data).ndata); pompalcyy=dsmatrix(MAXKNOTS+5,MAXKNOTS+5); bbx=(struct basisfunct *)Salloc(MAXKNOTS,struct basisfunct); /* get the integer and double parameters */ (*bbx).beta=0; (*bbx).sumunc=0; (*bbx).c3[0]=0; (*bbx).c3[1]=0; (*bbx).iks[0]=0; (*bbx).iks[1]=0; (*bbx).iks[2]=0; (*bbx).iks[3]=0; (*bbx).iks[4]=0; ndmax=intpars[1]; mind=intpars[6]; if(mind<1){ mind=2.5*pow((double)(*data).ndata,(double)0.2)+0.5; if((*data).ndata/mind<10)mind=(*data).ndata/10; if(mind<3)mind=3; } intpars[6]=mind; strt=intpars[2]; silent=intpars[3]; alpha=dpars[0]; if(strt==547) { strt= floor(2.5*pow((double)intpars[0],(double)0.2)); if(strt>25)strt=25; if(strt>intpars[0]/4)strt=intpars[0]/4; } if(alpha<0) alpha= mylog((double)intpars[0]); (*spc).ilow=intpars[4]; (*spc).iupp=intpars[5]; (*spc).low=dpars[1]; (*spc).upp=dpars[2]; i=0; /* starting knots */ if(ndmax==0) ndmax = - floor(4.*pow((double)intpars[0],(double)0.2)+1); if(ndmax>MAXKNOTS)ndmax=MAXKNOTS; if(strt<=0){ if(intpars[2]<0)intpars[2]= -intpars[2]; else intpars[2]=floor(2.5*pow((double)intpars[0],(double)0.2)+1); if(intpars[2]<0)intpars[2]= -intpars[2]; if(intpars[2]<3)intpars[2]=3; five(data0,kts,intpars,(*data).same); strt= intpars[2]; } /* they were user provided */ if(strt>0){ (*spc).nk=strt; (*spc).ndim=strt-1; for(i=0;i(*spc).knots[j]){ (*spc).iknots[j]=i; j++; i--; if(j==(*spc).nk)i=(*data).ndata+10; } else y=x; } if(j==((*spc).nk)-1) (*spc).iknots[(*spc).nk-1]=(*data).ndata-1; /* two knots outside the range of the data is not allowed */ if(j<((*spc).nk)-1){ intpars[0]=17; return; } if((*spc).iknots[1]==0){ intpars[0]=18; return; } } /* allocations */ cuu = dsvector(MAXKNOTS+5); kints = dsmatrix((*spc).nip+10,7); quadalloc(); /* do the work */ intpars[0]=nlsd(spc,data,alpha,ndmax,mind,strt,silent,logs,ad); dpars[0]= alpha; /* output */ if(intpars[0]>0 && intpars[0]<100)return; intpars[1]=(*spc).nk; intpars[2]=(*spc).ndim; for(i=0;i<((*spc).nk)+2;i++){ data0[i] = 0.; for(j=0;j<(*spc).nk-1;j++) data0[i]+=(*spc).basis[j].beta*(*spc).basis[j].c1[i]; } data0[0]+=mylog((*spc).cth); for(i=0;i<((*spc).nk);i++)kts[i]=(*spc).knots[i]; return; } /******************************************************************************/ /* the work */ static int nlsd(best,data,alpha,ndmax,mind,strt,silent,logs,ad) struct space *best; struct datastruct *data; double alpha,*logs; int ndmax,mind,strt,silent,*ad; /* best - best space up to now data - the data alpha - penalty parameter ndmax - maximum dimension size: negative: does not have to be attained mind - minimum distance between knots strt - were starting knots provided (1=yes) silent- should diagnostic info be printed? (1=yes) logs - log-likelihood of models ad - fit during addition (1), deletion (2), not at all (0) */ { struct space *current,*trynew; int add=1,i,oops=0,ndm2,oops2=0,oops3=0,j,coco=0; double xxa=0; /* current - present space trynew - needed during addition and deletion definespace- allocates a space add - adding=1, deleting=something else i - counter oops - error status ndm2 - sign of ndmax iter - fits a model swapspace - copies a model adddim- adds a dimension remdim- removes a dimension startspace- the starting model */ /* allocates storage for spaces */ trynew=definespace((*data).ndata); current=definespace((*data).ndata); /* starting */ swapspace(current,best); i=startspace(current,data,strt,silent); if(i==0)return 39; /* initialization */ ndm2=ndmax; if(ndmax<0)ndmax= -ndmax; (*best).aic=pow((double)10.,(double)150.); for(i=0;i0 || oops3>0)&& ndmax > (*current).ndim ){ /* problems. Jonge vriend, verzin een list! */ do{ for(i= -1;i> -4; i--){ /* begin opnieuw */ xxa=0.; coco=coco+1; j=startspace(current,data,i,silent); if(j==0)return 39; if(coco==10)return 39; oops=iter(current,data,silent,&xxa); oops2++; if(oops==0)i= -10; } }while(oops!=0 && ndmax > (*current).ndim); } if(oops2>2)oops2--; if(oops!=0){ if((*best).aic< -1.0e149)return 40; else swapspace(current,best); add=0; } if(oops==0){ /* compute aic */ logs[(*current).ndim-1]=(*current).aic; ad[(*current).ndim-1]=1; (*current).aic=(*current).ndim*alpha-2*(*current).aic; if((*current).ndim==ndmax)add=0; /* did we improve */ if((*current).aic<(*best).aic) swapspace(best,current); } /* continue */ if(add==1 && ndm2<0){ /* was there any recent improvement? */ for(i=2;i<(*current).ndim-2;i++){ if(logs[(*current).ndim-1]-logs[i-1]<((*current).ndim-i)/2.-0.5){ add=0; ndmax=(*current).ndim; } } } /* adds dimensions, computes new starting values */ if(add==1){ add=adddim(current,trynew,data,mind,silent); if(add!=1 && oops2<2) ndmax=(*current).ndim; if(add!=1 && oops2>=2){ oops3=1; add=1; } } /* keep on adding? */ }while(add==1); /* start deleting */ if((*current).ndim>2)do{ /* removes dimensions, computes new starting values */ if(ndmax>2)remdim(current,data,trynew,silent); /* fits the model */ oops=iter(current,data,silent,&xxa); if(oops!=0){ oops=oops+100; (*best).ndim=ndmax-1; return oops; } /* compute aic */ if((*current).aic>logs[(*current).ndim-1]){ logs[(*current).ndim-1]=(*current).aic; ad[(*current).ndim-1]=2; } (*current).aic=(*current).ndim*alpha-2*(*current).aic; /* did we improve */ if((*current).aic<(*best).aic) swapspace(best,current); /* does further deleting make sense */ }while((*current).aic-(*best).aic0)return 100; return 0; } /******************************************************************************/ /* allocates storage for a space, and initializes elements */ static struct space *definespace(nd) int nd; { int i,j,k; struct space *spc; spc=(struct space *)Salloc(1,struct space); (*spc).aic=pow(10.,100.); (*spc).ndim=0; (*spc).nk=0; (*spc).nip=0; (*spc).ilow=0; (*spc).iupp=0; (*spc).low=0.; (*spc).upp=0.; (*spc).cth=0.; (*spc).iknots=isvector(MAXKNOTS+5); (*spc).knots=dsvector(MAXKNOTS+5); (*spc).score=dsvector(MAXKNOTS+5); (*spc).info=dsmatrix(MAXKNOTS+5,MAXKNOTS+5); k=MAXKNOTS+10+nd/100+300; (*spc).ips=dsvector(k); (*spc).basis=(struct basisfunct *)Salloc(MAXKNOTS,struct basisfunct); for(i=0;ih3)h3=h1[i]; } for(i=0;ig1)g1=j; if(h1[j]>rr[i] && j0) eps1 = 0; eps2=fi-1; for(i=0;i0.0001){ eps = (eps1+eps2)/2.; s=1; w=fi; for(i=1;i<=j2;i++){ v=i; s+=w; rr[i]=s; rr[k-i-1]=n+1.-s; v=fi-v*eps; if(v<1)v=1; w*=v; } if(2*j==k)s+=w/2.; else rr[j]=(n+1)/2.; if(2.*s>=n+1)eps1=eps; else eps2=eps; } else i1=100; for(i=0;i=1;i--) { sum=b[i]; for (j=i+1;j<=n;j++) sum -= a[i][j]*b[j]; b[i]=sum/a[i][i]; } } /******************************************************************************/ #define TINY 1.0e-20; static int ludcmp(a,n,indx,d) int n,*indx; double **a,*d; { int i,imax=0,j,k; double big,dum,sum,temp,*vv; vv=luw; for(i=0;i<=n+1;i++)vv[i]=0.; *d=1.0; for (i=1;i<=n;i++) { big=0.0; for (j=1;j<=n;j++) if ((temp=fabs(a[i][j])) > big) big=temp; if (big == 0.0) return 0; vv[i]=1.0/big; } for (j=1;j<=n;j++) { for (i=1;i= big) { big=dum; imax=i; } } if (j != imax) { for (k=1;k<=n;k++) { dum=a[imax][k]; a[imax][k]=a[j][k]; a[j][k]=dum; } *d = -(*d); vv[imax]=vv[j]; } indx[j]=imax; if (a[j][j] == 0.0) a[j][j]=TINY; if (j != n) { dum=1.0/(a[j][j]); for (i=j+1;i<=n;i++) a[i][j] *= dum; } } return 1; } #undef TINY /******************************************************************************/ static int adddim(spc,spc2,data,mind,silent) struct space *spc,*spc2; struct datastruct *data; int mind,silent; { int i,nx,uu=0,ll=0,nowloc1=0,loloc=0,uploc=0,bestloc= -1; int besti= -1,nowloc2; double *sorted,nowrao1,bestrao= -1.,nowrao2; sorted=betaaddsorted; swapspace(spc2,spc); for(i=0;i<(*data).ndata;i++) sorted[i]=(*data).data[i]; nx=(*data).ndata; /* find the interval */ for(i=0;i<=(*spc).nk;i++){ /* before first knot */ if(i==0) nowloc1=findl(&ll,&uu,mind,sorted,nx,(*spc).knots[0]); /* after last knot */ if(i==(*spc).nk) nowloc1=findr(&ll,&uu,mind,sorted,nx,(*spc).knots[(*spc).nk-1]); /* in between knots */ if(i>0 && i<(*spc).nk)nowloc1= findm(&ll,&uu,mind,sorted,nx,(*spc).knots[i-1],(*spc).knots[i]); /* possible location */ if(nowloc1>=0){ nowrao1=rao(spc,data,sorted[nowloc1]); if(nowrao1>bestrao){ loloc=ll; uploc=uu; bestloc=nowloc1; bestrao=nowrao1; besti=i; } } } if(bestloc<0)return -1; /* as long as the locations are different, do interval halving */ do{ if(sorted[uploc]>sorted[loloc]){ nowloc2=findyr(uploc,bestloc,sorted); /* two search points, the upper one */ if(nowloc2>=0) nowrao2=rao(spc,data,sorted[nowloc2]); else nowrao2=bestrao; /* two search points, the lower one */ nowloc1=findyl(bestloc,loloc,sorted); if(nowloc1>=0) nowrao1=rao(spc,data,sorted[nowloc1]); else nowrao1=bestrao; /* the middle one is the best, we call it quits */ if(bestrao>=nowrao2 && bestrao>=nowrao1) loloc=uploc; else{ /* the lower search point is the best */ if(nowrao1>bestrao){ uploc=bestloc; bestloc=nowloc1; bestrao=nowrao1; } /* the upper search point is the best */ else{ loloc=bestloc; bestloc=nowloc2; bestrao=nowrao2; } } } }while(sorted[uploc]>sorted[loloc]); /* failure */ if(bestloc<0)return bestloc; /* done record the new knot in its correct position */ if(besti==(*spc).nk){ (*spc).knots[(*spc).nk]=sorted[bestloc]; (*spc).iknots[(*spc).nk]=bestloc; } else{ for(i=(*spc).nk;i>besti;i=i-1){ (*spc).knots[i]=(*spc).knots[i-1]; (*spc).iknots[i]=(*spc).iknots[i-1]; } (*spc).knots[besti]=sorted[bestloc]; (*spc).iknots[besti]=bestloc; } ((*spc).nk)++; ((*spc).ndim)++; if(silent==1) (void)Rprintf("add(%.2f), rao=%.2f ",sorted[bestloc],bestrao); /* get (*spc).ips (*spc).nip (*data).idatx */ /* get (*spc).basis.c1 (*spc).basis.c2 (*spc).basis.c3 (*spc).basis.sumunc */ setupspace(spc,data); /* get (*spc).basis.beta */ betaadd(spc,spc2,besti); return 1; } /******************************************************************************/ /* finds location in an interval (l,b) - l might not have been tested yet */ static int findyl(u,l,x) int l,u; double *x; { int i; if(x[l]==x[u])return -1; i=(u+l-1)/2; if(x[i]!=x[u])return i; i=(i+l)/2; if(x[i]!=x[u])return i; return l; } /******************************************************************************/ /* finds location in an interval (b,u) - u might not have been tested yet */ static int findyr(u,l,x) int l,u; double *x; { int i; if(x[l]==x[u])return -1; i=(u+l+1)/2; if(x[i]!=x[l])return i; i=(i+u)/2; if(x[i]!=x[l])return i; return u; } /******************************************************************************/ /* Finds a possible location for a knot on the interval (0,knot1) ll - lowest number we can search on in the future uu - highest number we can search on in the future mind minimum distance between knots x - data nx - length of data knt- knot */ static int findl(ll,uu,mind,x,nx,knt) double *x,knt; int nx,*ll,*uu,mind; { /* dlocation - finds uu */ int i; (*uu)=dlocation(0,x,nx,knt); if((*uu)k)return 0; if(x[nx-1]<=k)return nx-1; for(i=0;ik && x[i]<=k) return i; } if(x[nx-1]=k)return 0; for(i=1;i=k && x[i-1]besti;i=i-1) v1[i+2]=v1[i+1]; v1[besti+2]=0.; for(i=0;i0.01 && (*xxa)-logl > 100){ /* try alternate starting values */ lnew=logl; for(j=0;j<(*spc).ndim;j++){ tmp1[j]=(*spc).score[j]; tmp2[j]=(*spc).basis[j].beta; (*spc).basis[j].beta=0.;; for(i=0;i<(*spc).ndim;i++)tmp3[i][j]=(*spc).info[i][j]; } startnow(spc,data); logl=pompall(spc,data,2,&i2); if(lnew>logl ){ logl=lnew; for(j=0;j<(*spc).ndim;j++){ (*spc).score[j]=tmp1[j]; (*spc).basis[j].beta=tmp2[j]; for(i=0;i<(*spc).ndim;i++)(*spc).info[i][j]=tmp3[i][j]; } } else i1=i2; } /* serious ctheta problems */ if(i1==1)return 7; /* solve the system */ j=lusolve2((*spc).info,(*spc).ndim,(*spc).score); /* return 2 - something wrong with system */ if(j==0) return 2; /* adjust the tail shifts */ if((*spc).ilow==1){ (*spc).score[0]= -(*spc).score[0]/(*spc).basis[0].beta; if((*spc).score[0]<-100)(*spc).score[0]=-100; } if((*spc).iupp==1){ (*spc).score[1]= -(*spc).score[1]/(*spc).basis[1].beta; if((*spc).score[1]<-100)(*spc).score[1]=-100; } /* find the right step size */ factor= -1.; /* tail check */ if((*spc).ilow==1 && (*spc).iupp==1 && (*spc).basis[0].beta==0 && (*spc).basis[1].beta==0)return 6; if((*spc).ilow==1 && (*spc).basis[0].beta>=0)return 4; if((*spc).iupp==1 && (*spc).basis[1].beta>=0)return 3; /* adjust beta */ if((*spc).ilow==0)(*spc).basis[0].beta-=factor*(*spc).score[0]; else (*spc).basis[0].beta= -myexp(factor*(*spc).score[0]+mylog(-(*spc).basis[0].beta)); if((*spc).iupp==0)(*spc).basis[1].beta-=factor*(*spc).score[1]; else (*spc).basis[1].beta= -myexp(factor*(*spc).score[1]+mylog(-(*spc).basis[1].beta)); for(j=2;j<(*spc).ndim;j++)(*spc).basis[j].beta-=factor*(*spc).score[j]; do{ /* new logl */ if((*spc).ilow==1 && (*spc).iupp==1 && (*spc).basis[0].beta==0 && (*spc).basis[1].beta==0)return 6; if((*spc).ilow==1 && (*spc).basis[0].beta>=0)return 4; if((*spc).iupp==1 && (*spc).basis[1].beta>=0)return 3; lnew=pompall(spc,data,0,&i); /* did we win? */ kk=0; if((lnew-logl)< -zerror)kk=1; if((lnew-logl)< -zerror * 100 && (*spc).ilow==1 && (*spc).basis[0].beta> -1.e8 )kk=1; if((lnew-logl)< -zerror * 100 && (*spc).iupp==1 && (*spc).basis[1].beta> -1.e8 )kk=1; if(kk==1 || (i==1 && fabs(factor)>0.1)){ /* adjust the stepsize */ i=0; factor=factor/2.; if((*spc).ilow==0)(*spc).basis[0].beta+=factor*(*spc).score[0]; else (*spc).basis[0].beta= -myexp(-factor*(*spc).score[0]+mylog(-(*spc).basis[0].beta)); if((*spc).iupp==0)(*spc).basis[1].beta+=factor*(*spc).score[1]; else (*spc).basis[1].beta= -myexp(-factor*(*spc).score[1]+mylog(-(*spc).basis[1].beta)); for(j=2;j<(*spc).ndim;j++) (*spc).basis[j].beta+=factor*(*spc).score[j]; if(fabs(factor)< 0.00001 && (((*spc).iupp==1 && (*spc).basis[1].beta> -1.e8) || ((*spc).ilow==1 && (*spc).basis[0].beta> -1.e8))) return 5; if(fabs(factor)< 0.00001) return 8; /* return 5/8 - too much step-halving */ } if(i==1)return 7; } while(kk==1); /* convergence */ if(fabs(lnew-logl) 0.96 )iter=maxiter+1000; if(fabs(lnew-logl) -1.e8 )iter=maxiter+1000; if(fabs(lnew-logl) -1.e8 )iter=maxiter+1000; } if(iter0)(*xp)=0; else{ (*xp)=1.; return 0.; } ctheta=mylog(ctheta); /* logl - uncensored */ logl=0.; for(i=0;i<(*data).ndata;i++){ if((*data).same[i]==0) f=pol3(coef[(*data).idata[i]],(*data).data[i])-ctheta; logl+=f; } ctheta=myexp(-ctheta); if(what==0){ return logl; } /* get ctheta-j and ctheta-jk */ initk(0,ndim,(*spc).score,(*spc).info,cy,cyy); (void)savecoden(spc,0,nip-1,(*spc).score,(*spc).info); /* score and hessian - basic */ for(i=0;i=(*spc).basis[k].c3[0]&&j<=(*spc).basis[k].c3[1]){ cz[k]+=inp3(what,(*spc).basis[k].c2[j]); for(j2=0;j2<=k;j2++){ if(j>=(*spc).basis[j2].c3[0]&&j<=(*spc).basis[j2].c3[1]) czz[k][j2]+= mat3(what,(*spc).basis[k].c2[j],(*spc).basis[j2].c2[j]); } } } return; } /******************************************************************************/ static int savecoden(spc,i0,i1,cz,czz) int i0,i1; struct space *spc; double *cz,**czz; { int j; for(j=i0;j=0)for(i=0;i<7;i++)int2ext[i]=kints[j0ext][i]-intext[i]; /* get ctheta-j and ctheta-jk */ for(j=0;j<=ndim;j++) iext[j]=0.; sext=save22coden(spc,iext,bb,int2ext,j0ext,c2ext); for(j=0;j<=ndim;j++) iext[j]= (*data).ndata*iext[j]*ctheta; sext= -(*data).ndata*sext*ctheta; for(j=0;j=t[j]){ ii[j]=i; i=(*spc).nip; } } (*bb).c3[0]=ii[0]-1; if(ii[1]=ii[j1]){ (*bb).c2[j][3]+=cc[j1]; (*bb).c2[j][2]-=3.*cc[j1]*t[j1]; (*bb).c2[j][1]+=3.*cc[j1]*t[j1]*t[j1]; (*bb).c2[j][0]-=cc[j1]*t[j1]*t[j1]*t[j1]; } /* get j0ext */ j0ext=(*spc).nip+100; if(t[0]<(*spc).ips[1])j0ext=0; else for(i=1;i<(*spc).nip-2;i++){ if(t[0]==(*spc).ips[i])j0ext= -1; else if(t[0]<(*spc).ips[i+1])j0ext=i; if(j0ext<(*spc).nip+50)i=(*spc).nip; } if(j0ext>(*spc).nip+50)j0ext=(*spc).nip-2; /* get c2ext */ for(i=0;i<4;i++)c2ext[i]=0.; for(j1=0;j1<3;j1++) if(t[j1]<=t[0]){ c2ext[3]+=cc[j1]; c2ext[2]-=3.*cc[j1]*t[j1]; c2ext[1]+=3.*cc[j1]*t[j1]*t[j1]; c2ext[0]-=cc[j1]*t[j1]*t[j1]*t[j1]; } /* get intext */ if(j0ext>=0){ for(j=0;j<4;j++){ coef[j]=0.; for(k=0;k<(*spc).ndim;k++) coef[j]+=(*spc).basis[k].beta*(*spc).basis[k].c2[j0ext][j]; } if(j0ext==0){ if((*spc).ilow==1) l1int(rrr,t[0],coef,1,1); else l2int(rrr,(*spc).low,t[0],coef,1); } if(j0ext==((*spc).nip)-2) l2int(rrr,(*spc).ips[j0ext],t[0],coef,1); if(j0ext>0&&j0ext<((*spc).nip)-2) m1int(rrr,(*spc).ips[j0ext],t[0],1,coef,0); for(i=0;i<7;i++)intext[i]=rrr[i]; } /* get (*spc).basis.sumunrc */ (*bb).sumunc=0.; for(j1=0;j1<(*data).ndata;j1++){ j0=(*data).idata[j1]; if(j0>=(*bb).c3[0]&&j0<=(*bb).c3[1]){ if(j0!=j0ext || t[0]>(*data).data[j1]) (*bb).sumunc+=pol3((*bb).c2[j0],(*data).data[j1]); else (*bb).sumunc+=pol3(c2ext,(*data).data[j1]); } } return j0ext; } /******************************************************************************/ /* integrates all steps for score and hessian */ static double save22coden(spc,czz,bb,int2ext,j0ext,c2ext) int j0ext; struct basisfunct *bb; struct space *spc; double *czz,int2ext[7],c2ext[4]; { int j,k,i1=((*spc).nip)-1; double cz=0; /* correct the new one */ if(j0ext>=0 && j0ext=(*bb).c3[0]&&j<=(*bb).c3[1]){ for(k=0;k<(*spc).ndim;k++) if(j>=(*spc).basis[k].c3[0]&&j<=(*spc).basis[k].c3[1]) czz[k]+=mat3(kints[j],(*spc).basis[k].c2[j],(*bb).c2[j]); cz+=inp3(kints[j],(*bb).c2[j]); czz[(*spc).ndim]+=mat3(kints[j],(*bb).c2[j],(*bb).c2[j]); } } /* correct the new one part II */ if(j0ext>=0 && j0ext=(*spc).basis[k].c3[0]&&j0ext<=(*spc).basis[k].c3[1]) if(j0ext>=(*bb).c3[0]&&j0ext<=(*bb).c3[1]) czz[k]+=mat3(int2ext,(*spc).basis[k].c2[j0ext],c2ext); cz+=inp3(int2ext,c2ext); czz[(*spc).ndim]+=mat3(int2ext,c2ext,c2ext); for(k=0;k<7;k++)kints[j0ext][k]+=int2ext[k]; } return cz; } /******************************************************************************/ static void remdim(spc,data,spc2,silent) struct space *spc,*spc2; struct datastruct *data; int silent; /* spc - model to be worked on spc2 - temporary copy of the space data - data silent- should info be printed? (1=yes) */ { double ratmax=0.,se,phi; int i,j,k,irmax=1,ndim=(*spc).ndim; /* ratmax - largest phi/se ratio phi - coefficient in power basis se - standard errors i,j,k - counters irmax - for which coefficient is ratmax attained getip - gets the setupspace - sets up a new space swapspace - copies a space betarem - new starting values */ /* invert the Hessian */ luinverse((*spc).info,ndim); /* copy for later use */ swapspace(spc2,spc); for(i=0;i<(*spc).nk;i++){ /* compute the coefficient */ phi = 0.; for(j=0;j phi * ratmax){ ratmax = se / phi; irmax = i; } } if(silent==1) (void)Rprintf("rem(%.2f), wald=%.2f ", (*spc).knots[irmax],1./(ratmax*ratmax)); /* get (*spc).nk and (spc).ndim */ (*spc).nk -= 1; (*spc).ndim -= 1; /* remove the knot */ for(i=irmax;i<(*spc).nk;i++){ (*spc).iknots[i]=(*spc).iknots[i+1]; (*spc).knots[i]=(*spc).knots[i+1]; } /* get (*spc).ips (*spc).nip (*data).idatx and (*spc).basis.iks */ /* get (*spc).basis.c1 (*spc).basis.c2 (*spc).basis.c3 (*spc).basis.sumunc */ setupspace(spc,data); /* get (*spc).basis.beta */ betarem(spc2,spc,irmax); } /******************************************************************************/ static void betarem(spc2,spc,irmax) struct space *spc,*spc2; int irmax; { int i,j,k; double **mm2,*r1,x,y; k=(*spc2).ndim; mm2=betaremm2; r1=betaremr1; /* find A, the restriction */ for(i=0;i=0 */ if(((*spc).ilow==1 && r1[0]>=0) ||( (*spc).iupp==1 && r1[1]>=0)){ /* only restrictions on the lower tail */ if((*spc).ilow==1 && (*spc).iupp==0){ if(irmax<=2){ for(i=0;i<((*spc2).nk)+2;i++){ r1[i] = 0.; for(j=0;j<(*spc2).ndim;j++) r1[i]+=(*spc2).basis[j].beta*(*spc2).basis[j].c1[i]; } redo1(spc2,irmax,k); for(i=0;i=k-2){ for(i=0;i<((*spc2).nk)+2;i++){ r1[i] = 0.; for(j=0;j<(*spc2).ndim;j++) r1[i]+=(*spc2).basis[j].beta*(*spc2).basis[j].c1[i]; } redo2(spc2,irmax,(*spc2).nk); for(i=0;ik-3 || irmax<=2){ for(i=0;i<((*spc2).nk)+2;i++){ r1[i] = 0.; for(j=0;j<(*spc2).ndim;j++) r1[i]+=(*spc2).basis[j].beta*(*spc2).basis[j].c1[i]; } if(irmax<=2)redo1(spc2,irmax,k); if(irmax>k-3) redo2(spc2,irmax,(*spc2).nk); for(i=0;i2) (*bn).c3[1]=(*bn).iks[4]+1; /* get (*spc).basis.c2 */ for(j=0;j<(*spc).nip;j++) for(k=0;k<4;k++)(*bn).c2[j][k]=0.; for(j=(*bn).c3[0];j<=(*bn).c3[1];j++){ l=5; if(i==0||i==1)l=3; if(i==2)l=4; if(i==0){ (*bn).c2[j][0]+=(*bn).c1[0]; (*bn).c2[j][1]+=(*bn).c1[1]; } for(n=0;n2)m=i+n-3; a=(*spc).knots[m]; b=(*bn).c1[2+m]; if(j>=(*bn).iks[n]){ (*bn).c2[j][3]+=b; b=a*b; (*bn).c2[j][2]-=3.*b; b=a*b; (*bn).c2[j][1]+=3.*b; b=a*b; (*bn).c2[j][0]-=b; } } } /* get (*spc).basis.sumunc */ (*bn).sumunc=0.; for(m=0;m<(*data).ndata;m++){ l=(*data).idata[m]; if(l>=(*bn).c3[0]&&l<=(*bn).c3[1]) (*bn).sumunc+=pol3((*bn).c2[l],(*data).data[m]); } } return; } /******************************************************************************/ /* get c1 - the power basis representation - for a basisfunction */ static void getc1(t,c,i,k) double *c,*t; int i,k; { /* get (*spc).basis.c1 */ double a,b,d[10],r; int j; for(j=0;j<=k+1;j++)c[j]=0.; if(i==0){ a=t[2]-t[0]; b=t[2]-t[1]; c[2]= 1.; c[3]= -a/b; c[4]= -c[2]-c[3]; c[1]= -3.*(t[0]*t[0]+c[3]*t[1]*t[1]+c[4]*t[2]*t[2]); c[0]= -t[2]*c[1]-c[2]*a*a*a-c[3]*b*b*b; } if(i==1){ c[k-1]=1.; c[k]=(t[k-3]-t[k-1])/(t[k-1]-t[k-2]); c[k+1]= -c[k]-c[k-1]; } if(i==2) getonec1(c,k-2,t,k-4); if(i>2){ getonec1(c,i-1,t,i-3); getonec1(d,0,t,i-2); a=0.; b=0.; for(j=0;j<4;j++){ r=(t[k-1]-t[i+j-2]); a+=d[j]*r*r*r; r=(t[k-1]-t[i+j-3]); b+=c[i+j-1]*r*r*r; } for(j=0;j<4;j++)c[i+j]-=d[j]*b/a; } } /******************************************************************************/ static void getonec1(c,i,t,j) double *c,*t; int i,j; { c[i]=1.; c[i+3]=(t[j+2]-t[j])*(t[j]-t[j+1])/((t[j+2]-t[j+3])*(t[j+1]-t[j+3])); c[i+2]=(c[i+3]*(t[j+1]-t[j+3])+t[j+1]-t[j])/(t[j+2]-t[j+1]); c[i+1]=-1.-c[i+3]-c[i+2]; return; } /******************************************************************************/ static void setupspace(spc,data) struct space *spc; struct datastruct *data; { int i; /* get (*spc).ips (*spc).nip (*data).idatx and (*spc).basis.iks */ getip(spc,data); /* get (*spc).basis.c1 */ for(i=0;i<(*spc).ndim;i++)getc1((*spc).knots,(*spc).basis[i].c1,i,(*spc).nk); /* get (*spc).basis.c2 (*spc).basis.c3 and (*spc).basis.sumunc */ getc2(spc,data); return; } /******************************************************************************/ static int startspace(spc,data,strt,silent) int silent,strt; struct space *spc; struct datastruct *data; { int i,k,l=0,ok; double r,s; /* place the knots */ k=(*data).ndata; ok=1; if(strt==0){ (*spc).iknots[0]=0; (*spc).iknots[1]=(int)(k/2); (*spc).iknots[2]=k-1; for(i=0;i<3;i++) (*spc).knots[i]=(*data).data[(*spc).iknots[i]]; (*spc).nk=3; if(silent==1)(void)Rprintf("Starting knots at %.2f, %.2f and %.2f ", (*spc).knots[0],(*spc).knots[1],(*spc).knots[2]); (*spc).ndim=2; } if(strt<0){ if(strt== -1){ l=((*spc).nk); r=l+2.; if(l>3){ s=(double)l/((double)l-3.); for(i=1;i3){ s=(double)(l+2)/((double)l-3.); for(i=1;i3) s=(double)(l)/((double)l-3.); for(i=1;i0)if((*spc).knots[i]<=(*spc).knots[i-1])ok=0; } (*spc).nk=l; if(ok==0)ok=rearrange(spc,data); if(ok==0)return ok; (*spc).ndim=l-1; if(silent==1){ (void)Rprintf("\nRestart: knots at "); for(i=0;ir1){ s1+= (*data).data[i]-r1; j1+=2; } } s0=2.*s0/(double)j0; s1=2.*s1/(double)j1; if((*spc).ilow==1) (*spc).basis[0].beta= -1./fabs(s0*(*spc).basis[0].c1[1]); if((*spc).iupp==1)(*spc).basis[1].beta= -1./fabs(s1*(*spc).basis[1].c2[(*spc).nip][1]); return; } /******************************************************************************/ static int rearrange(spc,data) struct space *spc; struct datastruct *data; { int i,k,*ix,jx[500],nk=(*spc).nk,is,j,l; double *sorted; sorted=rearsorted; ix=rearix; for(i=0;i<(*data).ndata;i++){ sorted[i]=(*data).data[i]; ix[i]=i; } k=1; for(i=1;i<(*data).ndata;i++){ if(sorted[i]>sorted[k-1]){ sorted[k]=sorted[i]; ix[k]=ix[i]; k++; } } is=0; for(i=0;ijx[j])jx[j]++; for(j=nk-2;j>0;j--) if(jx[j]==jx[j+1]) if(jx[j-1]=0 && j<(*data).ndata) (*data).idata[j]=i; } /* get (*spc).basis.iks */ kips=iips; for(i=0;i<(*spc).nk;i++){ j=(*spc).iknots[i]; kips[i]=(*data).idata[j]; } for(i=0;i<3;i++)(*spc).basis[0].iks[i]=kips[i]; for(i=0;i<3;i++)(*spc).basis[1].iks[i]=kips[i-3+(*spc).nk]; if((*spc).ndim>2)for(i=0;i<4;i++)(*spc).basis[2].iks[i]=kips[i-4+(*spc).nk]; for(j=3;j<(*spc).ndim;j++)for(i=0;i<5;i++)(*spc).basis[j].iks[i]=kips[j+i-3]; return; } void rpqlsd(coef,knots,bnd,ipq,pq,lk,lp) double *coef,*knots,*pq,*bnd; int *ipq,*lk,*lp; { double *kpl,**cpl,*ppl,*pqx,r; double *zz,cor; int i,j,nk,fst,lst; /* Gaussian quadrature coefficients */ ww6[1 ]= 0.467913934572691; yy6[1 ]= 0.238619186083197; ww6[2 ]= 0.360761573048139; yy6[2 ]= 0.661209386466265; ww6[3 ]= 0.171324429379170; yy6[3 ]= 0.932469514203152; ww7[1 ]= 0.00178328072169643; yy7[1 ]= 0.99930504173577217; ww7[2 ]= 0.00414703326056247; yy7[2 ]= 0.99634011677195533; ww7[3 ]= 0.00650445796897836; yy7[3 ]= 0.99101337147674429; ww7[4 ]= 0.00884675982636395; yy7[4 ]= 0.98333625388462598; ww7[5 ]= 0.01116813946013113; yy7[5 ]= 0.97332682778991098; ww7[6 ]= 0.01346304789671864; yy7[6 ]= 0.96100879965205377; ww7[7 ]= 0.01572603047602472; yy7[7 ]= 0.94641137485840277; ww7[8 ]= 0.01795171577569734; yy7[8 ]= 0.92956917213193957; ww7[9 ]= 0.02013482315353021; yy7[9 ]= 0.91052213707850282; ww7[10]= 0.02227017380838325; yy7[10]= 0.88931544599511414; ww7[11]= 0.02435270256871087; yy7[11]= 0.86599939815409277; ww7[12]= 0.02637746971505466; yy7[12]= 0.84062929625258032; ww7[13]= 0.02833967261425948; yy7[13]= 0.81326531512279754; ww7[14]= 0.03023465707240248; yy7[14]= 0.78397235894334139; ww7[15]= 0.03205792835485155; yy7[15]= 0.75281990726053194; ww7[16]= 0.03380516183714161; yy7[16]= 0.71988185017161088; ww7[17]= 0.03547221325688239; yy7[17]= 0.68523631305423327; ww7[18]= 0.03705512854024005; yy7[18]= 0.64896547125465731; ww7[19]= 0.03855015317861563; yy7[19]= 0.61115535517239328; ww7[20]= 0.03995374113272034; yy7[20]= 0.57189564620263400; ww7[21]= 0.04126256324262353; yy7[21]= 0.53127946401989457; ww7[22]= 0.04247351512365359; yy7[22]= 0.48940314570705296; ww7[23]= 0.04358372452932345; yy7[23]= 0.44636601725346409; ww7[24]= 0.04459055816375657; yy7[24]= 0.40227015796399163; ww7[25]= 0.04549162792741814; yy7[25]= 0.35722015833766813; ww7[26]= 0.04628479658131442; yy7[26]= 0.31132287199021097; ww7[27]= 0.04696818281621002; yy7[27]= 0.26468716220876742; ww7[28]= 0.04754016571483031; yy7[28]= 0.21742364374000708; ww7[29]= 0.04799938859645831; yy7[29]= 0.16964442042399283; ww7[30]= 0.04834476223480295; yy7[30]= 0.12146281929612056; ww7[31]= 0.04857546744150343; yy7[31]= 0.07299312178779904; ww7[32]= 0.04869095700913972; yy7[32]= 0.02435029266342443; /* allocation */ kpl=dsvector((*lk)*4); ppl=dsvector((*lk)*4); cpl=dsmatrix((*lk)*4,4); pqx=dsvector((*lp)); /* get the integration points: the knots */ nk=(*lk)+1; for(i=0;i<=nk;i++){ if(i0)kpl[i]=knots[i-1]; if(i==0){ kpl[0]=knots[0]-1; if(bnd[0]>0.5)kpl[0]=bnd[1]; else if(pq[0]0.5)kpl[nk]=bnd[3]; else if(pq[(*lp)-1]+1.>kpl[nk])kpl[nk]=pq[(*lp)-1]+1.; } /* get the coeffiecients */ cpl[i][0]=coef[0]; cpl[i][1]=coef[1]; cpl[i][2]=0.; cpl[i][3]=0.; for(j=0;i>j && j<(*lk);j++){ cpl[i][3]+=coef[j+2]; cpl[i][2]-=3.*coef[j+2]*knots[j]; cpl[i][1]+=3.*coef[j+2]*knots[j]*knots[j]; cpl[i][0]-=coef[j+2]*knots[j]*knots[j]*knots[j]; } if(i>=nk-1){ cpl[i][3]=0.; cpl[i][2]=0.; } } /* compute the density */ ppl[0]=0.; if(bnd[0]>0.5)ppl[1]=z2int(kpl[0],kpl[1],cpl[0]); else ppl[1]=z1int(kpl[1],cpl[0],1); for(i=1;i0.5) ppl[nk]=z2int(kpl[nk-1],kpl[nk],cpl[nk-1])+ppl[nk-1]; else ppl[nk]=z1int(kpl[nk-1],cpl[nk-1],-1)+ppl[nk-1]; /* higher precision needed */ if(ppl[nk]<0.99999 || ppl[nk]>1.00001){ /* integration points: knots times four */ nk=4*(*lk)-2; for(i=0;i<=nk;i++){ if(i0){ j=floor((double)(i-1)/4.); r=(double)i/4.-j-0.25; kpl[i]=(1.-r)*knots[j]+r*knots[j+1]; } if(i==0){ kpl[0]=knots[0]-1; if(bnd[0]>0.5)kpl[0]=bnd[1]; else if(pq[0]0.5)kpl[nk]=bnd[3]; else if(pq[(*lp)-1]+1>kpl[nk])kpl[nk]=pq[(*lp)-1]+1.; } /* get the coeffiecients */ cpl[i][0]=coef[0]; cpl[i][1]=coef[1]; cpl[i][2]=0.; cpl[i][3]=0.; for(j=0;i>j*4 && j<(*lk);j++){ cpl[i][3]+=coef[j+2]; cpl[i][2]-=3.*coef[j+2]*knots[j]; cpl[i][1]+=3.*coef[j+2]*knots[j]*knots[j]; cpl[i][0]-=coef[j+2]*knots[j]*knots[j]*knots[j]; } if(i>=nk-1){ cpl[i][3]=0.; cpl[i][2]=0.; } } /* compute the density */ if(bnd[0]>0.5)ppl[1]=z2int(kpl[0],kpl[1],cpl[0]); else ppl[1]=z1int(kpl[1],cpl[0],1); for(i=1;i0.5) ppl[nk]=z2int(kpl[nk-1],kpl[nk],cpl[nk-1])+ppl[nk-1]; else ppl[nk]=z1int(kpl[nk-1],cpl[nk-1],-1)+ppl[nk-1]; } /* correction factor */ cor=ppl[nk]; /* correct the density */ for(i=0;i<=nk;i++)ppl[i]=ppl[i]/ppl[nk]; j=0; /* initialize */ if((*ipq)==0)zz=ppl; else zz=kpl; /* before the first point */ for(j=0;j<(*lp) && pq[j]<=zz[0];j++){ if((*ipq)==0){ if(bnd[0]>0.5)pqx[j]=kpl[0]; else pqx[j]= -1.0e100; } else pqx[j]=0.; } /* before the first knot */ fst=j; lst=j-1; for(j=j;j<(*lp) && pq[j]<=zz[1];j++) lst=j; if(lst>=fst){ if((*ipq)==0) getq0(pq,pqx,fst,lst,cpl[0],kpl[0],bnd[0],cor); else getp0(pq,pqx,fst,lst,cpl[0],kpl[0],bnd[0],cor); } /* per interval between integration points */ for(i=1;i=fst){ if((*ipq)==0) getq1(pq,pqx,fst,lst,cpl[i],kpl[i],kpl[i+1],ppl[i],ppl[i+1]); else getp1(pq,pqx,fst,lst,cpl[i],kpl[i],kpl[i+1],ppl[i],ppl[i+1]); } } /* beyond the larst knot */ fst=j; lst=j-1; for(j=j;j<(*lp) && pq[j]=fst){ if((*ipq)==0) getq2(pq,pqx,fst,lst,cpl[nk-1],kpl[nk],bnd[2],cor); else getp2(pq,pqx,fst,lst,cpl[nk-1],kpl[nk],bnd[2],cor); } /* outside the range */ for(j=j;j<(*lp);j++){ if((*ipq)==0){ if(bnd[2]>0.5)pqx[j]=kpl[nk]; else pqx[j]= 1.0e100; } else pqx[j]=1.; } for(j=0;j<(*lp);j++)pq[j]=pqx[j]; } /******************************************************************************/ static void getp0(q,p,f,l,cf,k,b,cr) double *q,*p,*cf,k,b,cr; int f,l; { int i; if(b>0.5) for(i=f;i<=l;i++) p[i]=z2int(k,q[i],cf)/cr; else for(i=f;i<=l;i++) p[i]=z1int(q[i],cf,1)/cr; } /******************************************************************************/ static void getq0(p,q,f,l,cf,k,b,cr) double *q,*p,*cf,k,b,cr; int f,l; { int i; if(b>0.5)for(i=f;i<=l;i++) q[i]=pqexpi(2,k,p[i]/cr,cf); else for(i=f;i<=l;i++) q[i]=pqexpi(1,k,p[i]/cr,cf); } /******************************************************************************/ static void getp2(q,p,f,l,cf,k,b,cr) double *q,*p,*cf,k,b,cr; int f,l; { int i; if(b>0.5) for(i=f;i<=l;i++) p[i]=1.-z2int(q[i],k,cf)/cr; else for(i=f;i<=l;i++) p[i]=1.-z1int(q[i],cf,-1)/cr; } /******************************************************************************/ static void getq2(p,q,f,l,cf,k,b,cr) double *q,*p,*cf,k,b,cr; int f,l; { int i; if(b>0.5)for(i=f;i<=l;i++) q[i]=pqexpi(4,k,1.-p[i]/cr,cf); else for(i=f;i<=l;i++) q[i]=pqexpi(3,k,1.-p[i]/cr,cf); } /******************************************************************************/ static void getp1(q,p,f,l,cf,k0,k1,p0,p1) double *p,*q,*cf,k0,k1,p0,p1; int f,l; { int i,j=0; double r; if(l-f>5)j=1; p[f]=z3int(k0,q[f],cf,j); r=p[f]+z3int(q[l],k1,cf,j); for(i=f+1;i<=l;i++) p[i]=z3int(q[i-1],q[i],cf,j)+p[i-1]; r=p[l]+z3int(q[l],k1,cf,j); r=(p1-p0)/r; for(i=f;i<=l;i++)p[i]=p0+p[i]*r; } /******************************************************************************/ static void getq1(p,q,f,l,cf,k0,k1,p0,p1) double *p,*q,*cf,k0,k1,p0,p1; int f,l; { int i,j; double y[51],f1[101],r,s; r=(k1-k0)/100.; for(i=0;i<101;i++) f1[i]=getf(cf,(double)(k0+r*i)); y[0]=0.; for(i=1;i<=50;i++)y[i]=y[i-1]+r*(f1[2*(i-1)]+4*f1[2*i-1]+f1[2*i])/3.; s=(p1-p0)/y[50]; for(i=0;i<=50;i++)y[i]=p0+y[i]*s; i=0; s=2.*r; for(j=f;j<=l;j++){ q[j]=k0-1.; do{ if(p[j]>=y[i] && p[j]<=y[i+1]) q[j]=k0+s*i+s*(p[j]-y[i])/(y[i+1]-y[i]); else i++; } while (q[j]600.) f1=600.; return (double)(j*myexp(f1)); } /******************************************************************************/ /* computes integrals from t1 to t2 of exp(polynomial(c0)) */ static double z2int(t1,t2,c0) double t1,t2,*c0; { int i1=1; double f1,f2; if(t2==t1)return 0.; if(c0[1]!=0){ if(c0[1]<0) i1 = -1; f1 = mylog(fabs(1./c0[1])) + c0[1]*t1+c0[0]; f2 = f1 + c0[1]*(t2-t1); if(f1>600.) f1=600.; if(f2>600.) f2=600.; return (double)(i1*myexp(f2)-i1*myexp(f1)); } else return (t2-t1)*myexp(c0[0]); } /******************************************************************************/ /* computes integrals from t1 to t2 of exp(polynomial(coef)) */ static double z3int(k1,k2,coef,accuracy) double k1,k2,*coef; int accuracy; { double r1,r2,x,y,v,vv=0.; int i1; if(k2==k1)return 0.; r1 = ((k2 - k1) / 2); r2 = ((k2 + k1) / 2); if(accuracy==1){ for(i1=1;i1<4;i1++){ y=yy6[i1]*r1; v=r1*ww6[i1]; x=r2-y; vv+=v*myexp(coef[0]+x*(coef[1]+x*(coef[2]+x*coef[3]))); x=r2+y; vv+=v*myexp(coef[0]+x*(coef[1]+x*(coef[2]+x*coef[3]))); } } else{ for(i1=1;i1<33;i1++){ y=yy7[i1]*r1; v=r1*ww7[i1]; x=r2-y; vv+=v*myexp(coef[0]+x*(coef[1]+x*(coef[2]+x*coef[3]))); x=r2+y; vv+=v*myexp(coef[0]+x*(coef[1]+x*(coef[2]+x*coef[3]))); } } return vv; } /******************************************************************************/ /* 1: -inf -> x / 2: t -> x / 3: x -> inf / 4: x -> t */ static double pqexpi(version,t,p,cf) int version; double t,p,*cf; { if(cf[1]!=0. || version == 1 || version == 3){ p=p*cf[1]; if(version == 1 && p < 0)return myexp((double)600.); if(version == 3 && p > 0)return -myexp((double)600.); if(version==2 || version ==4)t=myexp(t*cf[1]+cf[0]); if(version == 2 && t+p < 0)return myexp((double)600.); if(version == 4 && t-p < 0)return -myexp((double)600.); if(version==1)return (mylog(p)-cf[0])/cf[1]; if(version==2)return (mylog(t+p)-cf[0])/cf[1]; if(version==3)return (mylog(-p)-cf[0])/cf[1]; return (mylog(t-p)-cf[0])/cf[1]; } if(version==2)return t+p/myexp(cf[0]); return t-p/myexp(cf[0]); } /******************************************************************************/ static double *dsvector(l) int l; /* allocate a double vector with subscript range v[0...l] */ { double *v; int i; v=(double *)Salloc(l+1,double); for(i=0;i<=l;i++)v[i]=0.; return v; } /******************************************************************************/ static double getf(c,x) double *c,x; { return exp(c[0]+x*(c[1]+x*(c[2]+x*c[3]))); } /******************************************************************************/ static double mylog(x) double x; { if(x < 10.e-250)return (double)(-575.64627); else return log(x); } /******************************************************************************/ static double myexp(x) double x; { if(x > 576.)return exp((double)576.); else return exp(x); } /******************************************************************************/ /* allocate an short vector with subscript range v[0...l] */ static short *issvector(l) int l; { int i; short *v; v=(short *)Salloc(l+1,short); for(i=0;i<=l;i++)v[i]=0; return v; } /******************************************************************************/ /* allocate an int vector with subscript range v[0...l] */ static int *isvector(l) int l; { int *v,i; v=(int *)Salloc(l+1,int); for(i=0;i<=l;i++)v[i]=0; return v; } /******************************************************************************/ /* computes integrals from t1 to t2 (numerically) of x^i (i<1, what=0; i<7 o.w.) times exp(polynomial(coef)) */ static void m1int(vv,k1,k2,what,coef,accuracy) /* accuracy - accuracy r1 and r2 - from (k1,k2) to (-1,1) */ double k1,k2,*vv,*coef; int accuracy,what; { double r1,r2,x,y,z,v; int i1,i2,j; r1 = ((k2 - k1) / 2); r2 = ((k2 + k1) / 2); for(i1=0;i1<7;i1++)vv[i1]=0.; if(k2==k1)return; j=7; if(what==0)j=1; if(accuracy==1){ for(i1=1;i1<4;i1++){ y=yy6[i1]*r1; v=r1*ww6[i1]; x=r2-y; z=v*myexp(coef[0]+x*(coef[1]+x*(coef[2]+x*coef[3]))); vv[0]+=z; for(i2=1;i2600.) f1=600.; return (double)(j*myexp(f1)); } /******************************************************************************/ static double fctf2(b0,b1,t1,t2,f1,f2) double b0,b1,t1,t2,f1,f2; { int i1=1,i2=1; if(f1<0) i1 = -1; f1 = mylog(fabs(f1)) + b1*t1+b0; if(f1>600.) f1=600.; if(f2<0) i2 = -1; f2 = mylog(fabs(f2)) + b1*t2+b0; if(f2>600.) f2=600.; return (double)(i2*myexp(f2)-i1*myexp(f1)); } /******************************************************************************/ static double pol3(coef,x) double *coef,x; { return coef[0]+x*(coef[1]+x*(coef[2]+x*coef[3])); } /******************************************************************************/ static double inp3(c1,c2) double *c1,*c2; { return c1[0]*c2[0]+c1[1]*c2[1]+c1[2]*c2[2]+c1[3]*c2[3]; } /******************************************************************************/ static double mat3(c1,c2,c3) double *c1,*c2,*c3; { double x=0.; int i,j; for(i=0;i<4;i++)for(j=0;j<4;j++)x+=c1[i+j]*c2[i]*c3[j]; return x; } /******************************************************************************/ /* copies one space into another space */ static void swapspace(s1,s2) struct space *s1,*s2; { int i,j,k; (*s1).ndim=(*s2).ndim; (*s1).nk=(*s2).nk; (*s1).cth=(*s2).cth; (*s1).nip=(*s2).nip; (*s1).aic=(*s2).aic; (*s1).low=(*s2).low; (*s1).upp=(*s2).upp; (*s1).ilow=(*s2).ilow; (*s1).iupp=(*s2).iupp; for(i=0;i<(*s1).nip;i++) (*s1).ips[i]=(*s2).ips[i]; for(i=0;i<(*s1).nk;i++){ (*s1).knots[i]=(*s2).knots[i]; (*s1).iknots[i]=(*s2).iknots[i]; } for(i=0;i<(*s1).ndim;i++){ for(j=0;j<5;j++)(*s1).basis[i].iks[j]=(*s2).basis[i].iks[j]; (*s1).score[i]=(*s2).score[i]; for(j=0;j<(*s1).ndim;j++) (*s1).info[i][j]=(*s2).info[i][j]; (*s1).basis[i].beta=(*s2).basis[i].beta; for(j=0;j<2;j++)(*s1).basis[i].c3[j]=(*s2).basis[i].c3[j]; (*s1).basis[i].sumunc=(*s2).basis[i].sumunc; for(j=0;j<(*s1).nk+2;j++)(*s1).basis[i].c1[j]=(*s2).basis[i].c1[j]; for(j=0;j<4;j++)for(k=0;k<(*s1).nip;k++) (*s1).basis[i].c2[k][j]=(*s2).basis[i].c2[k][j]; } return; } /******************************************************************************/ static void quadalloc() { /* Gaussian quadrature coefficients */ ww6[1 ]= 0.467913934572691; yy6[1 ]= 0.238619186083197; ww6[2 ]= 0.360761573048139; yy6[2 ]= 0.661209386466265; ww6[3 ]= 0.171324429379170; yy6[3 ]= 0.932469514203152; ww7[1 ]= 0.00178328072169643; yy7[1 ]= 0.99930504173577217; ww7[2 ]= 0.00414703326056247; yy7[2 ]= 0.99634011677195533; ww7[3 ]= 0.00650445796897836; yy7[3 ]= 0.99101337147674429; ww7[4 ]= 0.00884675982636395; yy7[4 ]= 0.98333625388462598; ww7[5 ]= 0.01116813946013113; yy7[5 ]= 0.97332682778991098; ww7[6 ]= 0.01346304789671864; yy7[6 ]= 0.96100879965205377; ww7[7 ]= 0.01572603047602472; yy7[7 ]= 0.94641137485840277; ww7[8 ]= 0.01795171577569734; yy7[8 ]= 0.92956917213193957; ww7[9 ]= 0.02013482315353021; yy7[9 ]= 0.91052213707850282; ww7[10]= 0.02227017380838325; yy7[10]= 0.88931544599511414; ww7[11]= 0.02435270256871087; yy7[11]= 0.86599939815409277; ww7[12]= 0.02637746971505466; yy7[12]= 0.84062929625258032; ww7[13]= 0.02833967261425948; yy7[13]= 0.81326531512279754; ww7[14]= 0.03023465707240248; yy7[14]= 0.78397235894334139; ww7[15]= 0.03205792835485155; yy7[15]= 0.75281990726053194; ww7[16]= 0.03380516183714161; yy7[16]= 0.71988185017161088; ww7[17]= 0.03547221325688239; yy7[17]= 0.68523631305423327; ww7[18]= 0.03705512854024005; yy7[18]= 0.64896547125465731; ww7[19]= 0.03855015317861563; yy7[19]= 0.61115535517239328; ww7[20]= 0.03995374113272034; yy7[20]= 0.57189564620263400; ww7[21]= 0.04126256324262353; yy7[21]= 0.53127946401989457; ww7[22]= 0.04247351512365359; yy7[22]= 0.48940314570705296; ww7[23]= 0.04358372452932345; yy7[23]= 0.44636601725346409; ww7[24]= 0.04459055816375657; yy7[24]= 0.40227015796399163; ww7[25]= 0.04549162792741814; yy7[25]= 0.35722015833766813; ww7[26]= 0.04628479658131442; yy7[26]= 0.31132287199021097; ww7[27]= 0.04696818281621002; yy7[27]= 0.26468716220876742; ww7[28]= 0.04754016571483031; yy7[28]= 0.21742364374000708; ww7[29]= 0.04799938859645831; yy7[29]= 0.16964442042399283; ww7[30]= 0.04834476223480295; yy7[30]= 0.12146281929612056; ww7[31]= 0.04857546744150343; yy7[31]= 0.07299312178779904; ww7[32]= 0.04869095700913972; yy7[32]= 0.02435029266342443; } /******************************************************************************/ static double **dsmatrix(r,c) int r,c; /* allocate a double matrix with subscript range m[0..r][0..c] */ { int i; double **m; m=(double **) Salloc(r+1,double*); for(i=0;i<=r;i++) m[i]=dsvector(c); return m; } logspline/src/lsdall.c0000644000176200001440000034325612654166601014500 0ustar liggesusers/* * * Copyright [1993-2016] [Charles Kooperberg] * * Licensed under the Apache License, Version 2.0 (the "License"); * you may not use this file except in compliance with the License. * You may obtain a copy of the License at * * http://www.apache.org/licenses/LICENSE-2.0 * * Unless required by applicable law or agreed to in writing, software * distributed under the License is distributed on an "AS IS" BASIS, * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. * See the License for the specific language governing permissions and * limitations under the License. * Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. * */ #include #include #define NC 50 #include "R.h" void F77_NAME(xdsifa)(double[][NC], int *, int *, int *, int *); void F77_NAME(xdsisl)(double[][NC], int *, int *, int *, double *); void F77_NAME(xdsidi)(double[][NC], int *, int *, int *, double *, int *, double *, int *); void F77_NAME(xssort)(double *, double *, int *, int *); static double knots[NC],coef[NC][4][NC],zheta[NC],czheta,xg[NC],dfunpar[6]; static int nknots,ng3[NC],ng4[NC],piecedens(),where(); static int removeknot(),knotnumber(),numbertester(); static double liter(),erroradjust(),middle(),error2(),likeli(),linsearch(); static void fits(),setbounds(); static void coeff() ,start1() ,start2() ,suffstat1() ,suffstat2() ,knotplace(); static double dens3(),numint(),expin(),dens33(),onesearch(); static double fun2(),tails(),fun48(),numints(),expin2(); static void intnum2(),intnum3(),intnum4(); static void qtop(),ptoq(); static double pqexp(),pqnum(),lpqexpi(),pqdens(); /******************************************************************************/ /* this is the main program */ /* remove follows at the end */ int logcensor(idelete,iknotauto,sample,nsample,bound, SorC,ynknots,yknots,ycoef,alpha,wk,wk2,logl) int *idelete,*iknotauto,nsample[],SorC[],*ynknots; double bound[],sample[],yknots[],wk[],wk2[],ycoef[],*alpha,logl[]; /* these quantities are defined in the file where they originated and lhead.h */ { int itrouble,accuracy=0,xnknots=0.; double qt[2]; /* functions - see the functions themselves */ double info[NC][NC],loglikelihood,sufficient[NC][2],coef2[NC][NC],xczheta=0.; /* stuf used in iter info - the information matrix loglikelihood sufficient - sufficient statistics coef,coef2 - 2 matrices defining the splines as a function of the knots, see lcoef.c for the exact definitions. */ double derivatives[NC],crossprods[NC][NC],suffcombine[NC][2],xzheta[NC]; /* derivative crossprods used to compute the starting values - see lstart.c suffcombine used to compute the sufficient statistics - see lsuff.c */ double aic,aicmin,r1,rknots[NC],xcoef2[NC][NC]; /* local double stuff: r1 - utility aic - akaike information criterion aicmin - minimum aic encountered alpha - alpha value in aic rknots - copy of knots */ int i,j,nkstart,iremove=0,iknots2[NC],iknots[NC],xiknots[NC]; /* local integers i,j,k - counter, utility nkstart - number of knots at the beginning of the algorithm iknots2 - copy of iknots iremove - number of the knot that is removed */ /******************************************************************************/ /* compute the number of knots (to start) */ for(i=0;i0){ if(*idelete == 0){ xczheta = czheta; xnknots = nknots; for(i=0; i= aicmin) nknots = 0; } /* If there were more than 4 knots, we should remove one. */ if(nknots >= 4){ /* Select the one to remove. */ iremove = removeknot(info,coef2); /* Remove its remainders from all sort of arrays. That is, shift the ends of the array 1 closer to 0, crossprods gets shifted in 2 directions */ for(i=iremove; i=iremove);i++) crossprods[i+1][j+1] = crossprods[i+2][j+2]; for(i=iremove;(i=iremove);i++) crossprods[i+1][j+1] = crossprods[i+1][j+2]; } } /* this takes care that we stop */ else if(nknots == 3)nknots=2; }} } while(nknots>=3 && *idelete >0); /* Now write the solution down. This prints the density */ nknots = nkstart; fits(xcoef2,xzheta,xczheta,ycoef,xiknots,xnknots); *ynknots = nkstart; bound[2]=(bound[2]-qt[0])/qt[1]; bound[4]=(bound[4]-qt[0])/qt[1]; for(i=0;i0){ se[i] = sqrt(se[i]); /* Select for which knot se/phi takes it maximal value */ if(se[i] > phi[i] * ratmax){ ratmax = se[i] / phi[i]; irmax = i; }} } nknots = nknots-1; return irmax; } /*****************************************************************************/ static void fits(xcoef2,xzheta,xczheta,ycoef,xiknots,xnknots) double xzheta[],xczheta,ycoef[],xcoef2[][NC]; int xiknots[],xnknots; { int i,j; for(i=0;i< NC;i++)ycoef[i]=0.; ycoef[0]=-log(xczheta); for(i=0;i< xnknots;i++){ ycoef[xiknots[i]+2] = 0.; for(j=0;j< xnknots-1;j++) ycoef[xiknots[i]+2] = ycoef[xiknots[i]+2] + xzheta[j] * xcoef2[j][i+2]; } for(j=0;j< xnknots-1;j++){ ycoef[0]=ycoef[0] + xzheta[j] * xcoef2[j][0]; ycoef[1]=ycoef[1] + xzheta[j] * xcoef2[j][1]; } } /******************************************************************************/ /* this is the main iteration loop */ /* setbounds follows at the end */ static double liter(info,sufficient,bound,SorC,nsample,sample,accuracy,itrouble) double info[][NC],sufficient[][2],bound[],sample[]; int SorC[],accuracy,nsample[],*itrouble; { int counter=0,infol,i1,i2,i3,kpvt[NC],jaja1,i4,iii[4],ithere,i7,nrc=0,nrc2=0; double zerror=0.,oldlikelihood,cbound[7],shift[NC],dd[2]; double candidate[NC],newlikelihood=0.,work[NC][NC]; double one,rvr[100],zerrorx; /* local i1 i2 i3 - counters oldlikelihood - loglikelihood previous iteration newlikelihood - loglikelihood present iteration infol,kpvt - for linpack work - for linpack shift - used for the shift and score zerror - stop criterion cbound - see below candidate - candidate for new zheta counter - number of iterations since last reset of boundaries */ one=0.99999; /* sets integration bounds */ setbounds(bound,cbound,nsample); /* accuracy = 0 means that we approximate censoring */ if(accuracy == 0 && nsample[0]==nsample[1])accuracy=1; /* start of the iteration */ if(SorC[0] == 0) (void)Rprintf("%d \n",nknots); for(i1=1; i1<500; i1++){ /* if we go extremely far out in the tails, and zheta[first] or zheta[last] still doesn't have the right sign, we fix the bounds at the max value */ ithere = 0.; if(bound[3]<0.5||bound[3]>1.5)ithere=5; else{ if(bound[4]>=25*knots[nknots-1]-24*knots[0]){ if(SorC[0]==0&&SorC[24]==0)(void)Rprintf("a very long right tail"); SorC[24]=nknots; *itrouble=17; for(i2=1;i2<5;i2++)bound[i2]=cbound[i2]; return 0.; } } if(bound[1]<0.5||bound[1]>1.5)ithere=ithere+5; else{ if(bound[2]<=-24*knots[nknots-1]+25*knots[0]){ if(SorC[0]==0&&SorC[23]==0)(void)Rprintf("a very long left tail"); SorC[23]=nknots; *itrouble=17; for(i2=1;i2<5;i2++)bound[i2]=cbound[i2]; return 0.; } } /* after 250 iterations we do the censoring exact */ if(accuracy == 0 && i1==250){ accuracy=1; counter = 0; } jaja1=0; counter++; /* if something changed in the bounds since last time counter = 0, and we have to recompute czheta and the loglikelihood */ i7=0; do{ if(counter==1){ do{ czheta = middle(info,shift,sufficient,bound,accuracy, nsample,sample,zheta,0); /* check against overflow and NAs */ i2=-1; if(czheta>0.0)i2=i2+1; if(czheta<2.0)i2=i2+1; if(numbertester(czheta)==1)i2=i2-4; if(i2<0){ for(i2=0;i27 && *itrouble == 0){ *itrouble = 2; for(i2=1;i2<5;i2++)bound[i2]=cbound[i2]; return 0.; } i2=-6; i7++; if(i7==200){ *itrouble=5; return 1.; } } }while(i2<0); newlikelihood=likeli(zheta,nsample,sample,bound,accuracy); } i2=1000*nknots+i1; /* compute score (stored in shift), info and czheta */ czheta = middle(info,shift,sufficient,bound,accuracy, nsample,sample,zheta,2); /* store the loglikelihood of the previous iteration */ oldlikelihood = newlikelihood; /* copy info */ for(i2=0;i27 && *itrouble == 0){ *itrouble = 2; for(i3=1;i3<5;i3++)bound[i3]=cbound[i3]; return 0.; } i7++; if(i7==200){ *itrouble = 5; return 1.; } } }while(infol!=0); iii[1]=0; iii[2]=0; if(nsample[2]+nsample[3]+nsample[4] >0) F77_CALL(xdsidi)(work,&i2,&i3,kpvt,dd,iii,rvr,&i4); for(i4=0;i40&&nrc+nrc2>=5&&nrc>=2){ nrc2++; if(nrc2==15 && *itrouble == 0){ *itrouble = 2; for(i3=1;i3<5;i3++)bound[i3]=cbound[i3]; return 0.; } if(nrc2==48 && *itrouble != 0){ *itrouble = 5; for(i3=1;i3<5;i3++)bound[i3]=cbound[i3]; return 1.; } iii[2]=0; iii[1]=0; nrc=0; } if(iii[2]+iii[1]==0){ F77_CALL(xdsisl)(work,&i2,&i3,kpvt,shift); /* compute the stop criterion and adjust stepsize, if too large */ i7=0; do{ zerrorx=error2(shift,rvr); zerrorx=zerrorx*100.; zerror = erroradjust(shift); if(iii[3]==0)zerror=zerrorx; i2=-1; if(zerror>0.0)i2=i2+2; if(zerror<2.0)i2=i2+2; if(numbertester(zerror)==1)i2=i2-4; if(i2<0){ for(i2=0;i27 && *itrouble == 0){ *itrouble = 2; for(i3=1;i3<5;i3++)bound[i3]=cbound[i3]; return 0.; } i7++; if(i7==200){ *itrouble = 5; return 1.; } i2=-7; } }while(i2<0); /* counter is the number of iterations since the last adjustment of integration boundaries. Thus if we find an zerror, we put it to 0 and start all over. Temporarily we deduct 10000 from it if we have to half the step size first */ i7=0; do{ if(counter<-1000)counter=counter+10000; /* We should check whether zheta's that should be negative (the ones for tail basis functions if we are integrating to plus/minus infinity) stay negative. If counter become 0 we essentially leave the loop here..................... We then go from case A to case B...........................................*/ if(zheta[0] + shift[0] >= 0. && bound[1] < 0.5){ cbound[5] = -cbound[5]; bound[2] = cbound[5] * (knots[0] - knots[1]) + knots[0]; bound[1] = 1; counter = 0; } if(zheta[nknots-2] + shift[nknots-2] >= 0. && bound[3] < 0.5){ cbound[6] = -cbound[6]; bound[4] = cbound[6] * (knots[nknots-1] - knots[nknots-2]) + knots[nknots-1]; bound[3] = 1.; counter = 0; } /* Compute the C(zheta) for the candidate zheta-hat. We can then compute the new log-likelihood. */ if(counter >0){ for(i2=0;i20.0)i2=i2+1; if(czheta<2.0)i2=i2+1; if(numbertester(czheta)==1)i2=i2-4; if(i2>0){ newlikelihood=likeli(candidate,nsample,sample,bound,accuracy); /* If the loglikelihood really decreases, we step size and go back a bit */ if(newlikelihood < oldlikelihood && ((newlikelihood/oldlikelihood < one) || (oldlikelihood/newlikelihood < one)) && zerror > 0.00001){ jaja1++; if(jaja1<12 || i1<3){ for(i2=0;i2 7 && *itrouble == 0){ *itrouble = 2; for(i3=1;i3<5;i3++)bound[i3]=cbound[i3]; return 0.; } i7++; if(i7==200){ *itrouble = 5; return 1.; } for(i2=0;i20){ nrc++; for(i2=0;i2-6.||zheta[0]+shift[0]>0)){ cbound[5] = -cbound[5]; bound[2] = cbound[5] * (knots[0] - knots[1]) + knots[0]; bound[1] = 1; counter = 0; } if(cbound[6]<0. && bound[3] < 0.5 && (cbound[6]>-6.||zheta[nknots-2]+shift[nknots-2]>0)){ cbound[6] = -cbound[6]; bound[4] = cbound[6] * (knots[nknots-1] - knots[nknots-2]) + knots[nknots-1]; bound[3] = 1.; counter = 0; } if(counter ==0){ czheta = middle( info,shift,sufficient,bound,accuracy,nsample,sample,zheta,0); (void) middle(info,shift,sufficient,bound,accuracy,nsample,sample,zheta,1); oldlikelihood=likeli(zheta,nsample,sample,bound,accuracy); for(i2=0;i2 0){ for(i2=0;i29){ if(accuracy == 5){ for(i3=1;i3<5;i3++)bound[i3]=cbound[i3]; rvr[99] = middle( info,shift,sufficient,bound,5,nsample,sample,zheta,0); if(iii[1]+iii[2]!=0) rvr[99] = middle( info,shift,sufficient,bound,5,nsample,sample,zheta,0); i2=0; if(rvr[99]>0.0)i2=i2+1; if(rvr[99]<2.0)i2=i2+1; if(numbertester(rvr[99])==1)i2=i2-4; if(i2>0){ czheta=rvr[99]; newlikelihood=likeli(zheta,nsample,sample,bound,5); } return newlikelihood; } else { accuracy = 5; counter = 0; } } else { /* If we were not integrating to +/- infinity, we either double the integration tails (if a tail zheta was possitive) or we go for it: +/- infinity (That means cbound[5] and cbound[6] become negative.) */ counter=0; /* Left tail */ if(cbound[5] < 0) /* case A */ cbound[5] = 2. * cbound[5]; else{ if(cbound[1] < 0.5 && zheta[0] >=0.){ /* case B */ cbound[5] = 2. * cbound[5]; bound[2] = cbound[5] * (knots[0] - knots[1]) + knots[0]; } if(cbound[1] < 0.5 && zheta[0] <0. ){ /* case B to A*/ cbound[5] = -2. * cbound[5]; bound[1] = 0; } if(cbound[1] > 0.5 && bound[1] > 0.5 && bound[1] < 1.5){ /*E*/ cbound[5] = 2. * cbound[5]; bound[2] = cbound[5] * (knots[0] - knots[1]) + knots[0]; if(bound[2] < cbound[2]){ /* goto C/D */ bound[2] = cbound[2]; bound[1] = 2.; } } } /* Right tail */ if(cbound[6] < 0) /* case A */ cbound[6] = 2. * cbound[6]; else{ if(cbound[3] < 0.5 && zheta[nknots-2] >=0.){ /* case B */ cbound[6] = 2. * cbound[6]; bound[4] = cbound[6] * (knots[nknots-1] - knots[nknots-2]) + knots[nknots-1]; } if(cbound[3] < 0.5 && zheta[nknots-2] <0. ){ /* case B to A*/ cbound[6] = -2. * cbound[6]; bound[3] = 0.; } if(cbound[3] > 0.5 && bound[3] > 0.5 && bound[3] < 1.5){ /* case E*/ cbound[6] = 2. * cbound[6]; bound[4] = cbound[6] * (knots[nknots-1] - knots[nknots-2]) + knots[nknots-1]; if(bound[4] > cbound[4]){ /* goto C/D */ bound[4] = cbound[4]; bound[3] = 2; } } } } } } } /* If we ended up here, there was no convergence in 300 iterations. */ if(SorC[0] == 0){ (void)Rprintf("no convergence was achieved with %d knots\n",nknots); SorC[0] = -647; } else SorC[0] = -SorC[0]; return newlikelihood; } static void setbounds(bound,cbound,nsample) double bound[],cbound[]; int nsample[]; { /* set the integration boundaries. O.k., this is quite complicated. There are 2 arrays that determine how far we are integrating in each tail. For the lower tail: bound[1] - is there a lower bound to which we should integrate (on entry) are we right now integrating to a lower bound (during) is there a lower bound to which we should integrate (on exit) (0 = -infinity; 1 = lower bound); cbound[1]- copies the begin value of bound[1] for during the iterations. bound[2] - if bound[1] == 1/2 the lower bound of integration (on entry) if bound[1] == 1/2 the lower bound of integration (during) if bound[1] == 1/2 the lower bound of integration (on exit) cbound[2]- copies the begin value of bound[2] for during the integration. cbound[5] - technical limit on the integration. If cbound[5] < 0 we can integrate to -infinity (if we want to), if cbound[5] > 0 the furthest we want to integrate is to cbound[5]*(knots[1]-knots[2])+knots[1]; if cbound[5] is smaller than 0 it is twice its last possitive value. For the upper tail: bound[3], bound[4], cbound[3], cbound[4], cbound[6] */ /* the lower tail */ cbound[2] = bound[2]; cbound[1] = bound[1]; cbound[5] = 1.; if(nsample[3]*3>nsample[1])cbound[5]=0.5; bound[2] = cbound[5] * (knots[0] - knots[1]) + knots[0]; /* there are 5 possible situations: A cbound[1]=0, zheta[0]<0 need: cbound[5]=-1, bound[1]=0 B zheta[0]>=0 need: cbound[5]=1, bound[1]=1 C cbound[1]=1, zheta[0]<0 need: cbound[5]=1, bound[1]=2, bound[2]=cbound[2] D zheta[0]>=0, bound[2]=cbound[2]: cbound[5]=1, bound[1]=1 */ if(zheta[0]<0. && cbound[1] < 0.5 && nsample[0] == nsample[1]) cbound[5] = -1.; if(cbound[1] < 0.5 && (zheta[0] >= 0. || nsample[0]!=nsample[1])) bound[1] = 1; if(cbound[1] > 0.5) bound[1] = 2; if(cbound[1] > 0.5 && zheta[1] >= 0. && bound[2] >= cbound[2]) bound[1] = 1; if(cbound[1] > 0.5 && (zheta[0]<0. || (zheta[0] >= 0. && bound[2] < cbound[2]))) bound[2] = cbound[2]; /* the upper tail almost similar */ cbound[4] = bound[4]; cbound[3] = bound[3]; cbound[6] = 1; if(nsample[4]*3>nsample[1])cbound[6]=0.5; bound[4] = cbound[6] * (knots[nknots-1] - knots[nknots-2]) + knots[nknots-1]; if(zheta[nknots-2]<0. && cbound[3] < 0.5 && nsample[0] == nsample[1]) cbound[6] = -cbound[6]; if(cbound[3] < 0.5 && (zheta[nknots-2] >=0. || nsample[0]!=nsample[1])) bound[3] = 1; if(cbound[3] > 0.5) bound[3] = 2; if(cbound[3] > 0.5 && zheta[nknots-2] >= 0. && cbound[4] >= bound[4]) bound[3] = 1; if(cbound[3] > 0.5 && (zheta[nknots-2]<0. || (zheta[nknots-2] >= 0. && bound[4] > cbound[4]))) bound[4] = cbound[4]; } /******************************************************************************/ /* this file contains a few miscelaneous routines erroradjust - computes the error criterion likeli - computes the loglikelihood linsearch - computes the winning stepsize for steepest decent onesearch - computes czheta and the loglikelihood for one zheta+shift */ /******************************************************************************/ /* this function computes the stopcriterion (zerror) and adjust the stepsize (shift) if this is too large. */ static double erroradjust(shift) double shift[]; { double r1,r2; int i; /* all utility numbers */ /* the zerror is the sum of (shift/zheta)^2, except where zheta is very small */ r1 = 0.; for(i=0; i 1000.;i++) shift[i]=shift[i] * 3. / r2; return r1; } static double error2(shift,rvr) double shift[],rvr[]; { int i,j; double r=0.; for(i=0;i=0.0)j++; if(numbertester(r)==1)j=j-2; if(j<0)r=1000; return r; } /******************************************************************************/ /* this routine computes the loglikelihood */ static double likeli(candidate,nsample,sample,bound,accuracy) double candidate[],sample[],bound[]; int nsample[],accuracy; { double r0,r1,likl,r3[NC+1],aa[6],bb[6]; double rtt; int i1,i2,i3,i4,iv,iw; r0=exp((double)(-740)); /* the function uses numint and dens33 - which always use zheta, but the routine doesn't always compute the likelihood in zheta, sometimes at another place - so we have to swap zheta and candidate */ for(i1=0;i1<(nknots-1);i1++){ r1=zheta[i1]; zheta[i1]=candidate[i1]; candidate[i1]=r1; } /* the stuff for the exact data is easy */ likl=0.; for(i1=0;i10.5)iv=4; else iv=3; if(bound[1]>0.5)iw=2; else iw=1; aa[1]=0.; aa[2]=0.; aa[3]=1.; aa[4]=zheta[nknots-2]*coef[nknots-2][1][nknots]; aa[5]=zheta[nknots-2]*coef[nknots-2][0][nknots] +zheta[nknots-3]*coef[nknots-3][0][nknots]-log(czheta); if(nknots<4) aa[5]=zheta[nknots-2]*coef[nknots-2][0][nknots]-log(czheta); r3[nknots]=expin(iv,knots[nknots-1],bound[4],aa); bb[1]=0.; bb[2]=0.; bb[3]=1.; bb[4]=zheta[0] * coef[0][1][0]; bb[5]=zheta[0] * coef[0][0][0]-log(czheta); r3[0]=expin(iw,knots[0],bound[2],bb); for(i1=1;i1r0) likl=likl+log(r1); else likl=likl-1000; } /* in the tail */ else likl=likl+log(expin(iv,sample[i2],bound[4],aa)); } /* the left censored data */ for(i1=0;i10){ r1=numint(knots[i3-1],sample[i2],dens3,0); for(i4=0;i4r0) likl=likl+log(r1); else likl=likl-1000; } /* in the tail */ else likl=likl+log(expin(iw,sample[i2],bound[2],bb)); } } else{ /* approximate, first right censored - essentially as above there are ng3 points at xg */ if(nsample[3]>0){ i1=0; for(i2=0;i20){ i1=i1+ng3[i2]; for(i3=0;knots[i3]r0) likl=likl+ng3[i2]*log(r1); else likl=likl-1000.*ng3[i2]; } else likl=likl+ng3[i2]*log(expin(iv,xg[i2],bound[4],aa)); if(i1==nsample[3])i2=NC+3; } } } /* approximate, now left censored - essentially as above there are ng4 points at xg */ if(nsample[4]>0){ i1=0; for(i2=0;i20){ i1=i1+ng4[i2]; for(i3=0;knots[i3]0){ r1=numint(knots[i3-1],xg[i2],dens3,0); for(i4=0;i4r0) likl=likl+ng4[i2]*log(r1); else likl=likl-1000.*ng4[i2]; } else likl=likl+ng4[i2]*log(expin(iw,xg[i2],bound[2],bb)); if(i1==nsample[4])i2=NC+3; } } } /* the interval censored stuff is easy */ if(nsample[2]>0){ for(i1=0;i10.5)rt=-2.; else rt=(double)floor(log(rr)/log((double)2))-2.; /* onesearch computes the loglikelihood for one rt (stepsize) */ ll=onesearch(rt,shift,accuracy,bound,&err,nsample,sample); /* if for the basis stepsize the likelihood goes up we try more */ if(err==0 && ll>maxll){ do{ maxrt=rt; maxll=ll; rt=rt+2.; ll=onesearch(rt,shift,accuracy,bound,&err,nsample,sample); }while(rt<8.5 && ll>maxll && err==0); } /* if for the basis stepsize the likelihood goes down we try less */ else { do{ rt=rt-2.; ll=onesearch(rt,shift,accuracy,bound,&err,nsample,sample); }while(rt>-14.1 && (ll < maxll || err==1)); } /* write down the winning combination */ if(err==0 && ll>maxll){ maxrt=rt; maxll=ll; } if(maxrt > -50.){ rt = maxrt + 1; ll=onesearch(rt,shift,accuracy,bound,&err,nsample,sample); if(err==0 && ll>maxll){ maxrt=rt; maxll=ll; } maxrt=pow(2.,maxrt); for(i=0;i200){ *err=1; return 0.; } j=0; if(czheta > -5)j++; if(czheta < 5)j++; if(j==0){ *err=1; return 0.; } /* compute likeli */ ll=likeli(rv,nsample,sample,bound,accuracy); return ll; } static int numbertester(aa) double aa; /* if aa = -Inf: 0 aa = +Inf: 1 aa = NaN: 2 otherwise: 3 */ { int i1=0,i2=0,i3=0,i4=0; if(aa< 2.){ i1=1; } if(aa> 0.){ i2=1; } if(aa< pow(10.,200.)){ i3=1; } if(aa> -pow(10.,200.)){ i4=1; } if(i1+i2+i3+i4>=3){ return 3; } if(i2==1 && i4==1){ return 1; } if(i1==1 && i3==1){ return 0; } return 2; } /******************************************************************************/ /* this file contains the following functions: expin - computes an exponential integral expin2 - computes another exponential integral dens3 - computes a logspline-density in one point dens33 - computes the log of a logspline-density in one point numint - computes a numerical integral numints- computes a vector of numerical integrals */ /******************************************************************************/ /* this function computes (analytical) the integral: t1 t1 inf t2 / / / / 2. a4*x+a5 | | | |(a1*x +a2*x+a3)*e dx / / / / -inf t2 t1 t1 1 2. 3 4 <==== version */ static double expin(version,t1,t2,a) /* input: a,b,c,d,e,t1,t2,version: see figure above local: a1,b1,c1: as a,b and c, but for the primitive. f1,f2 half-products */ int version; double t1,t2,a[]; /* this version does not contain much information - the best way to figure out what is happening is to compute the integrals above, and then check below */ { double a1,b1,c1,f1,f2; int i1,i2; /* if d=0 and version is 1 or 3 well........... */ if(a[4]!=0 || version == 1 || version ==3){ a1 = a[1]/a[4]; b1 = (a[2]-2*a1)/a[4]; c1 = (a[3]-b1)/a[4]; f1 = a1*t1*t1+b1*t1+c1; i1 = 1; if(f1<0) i1 = -1; f1 = log(fabs(f1)) + a[4]*t1+a[5]; if(f1>2000.) f1=2000.; if(version==2 || version == 4){ f2 = a1*t2*t2+b1*t2+c1; i2 = 1; if(f2<0) i2= -1; f2 = log(fabs(f2)) + a[4]*t2+a[5]; if(f2 > 2000.) f2=2000.; if(version == 2)return i1*exp(f1)-i2*exp(f2); return i2*exp(f2)-i1*exp(f1); } if(version==1) return i1*exp(f1); return -i1*exp(f1); } a1 = (((a[1]/3)*(t2-t1)+a[2]/2)*(t2-t1)+a[3])*(t2-t1)*exp(a[5]); if(version==4)return a1; return -a1; } /******************************************************************************/ /* This function computes a similar integral, but with a higher order leading polinomial */ static double expin2(version,t1,t2,aa,b1,b0) /* input: aa,b1,b0,t1,t2,version: see figure above local: u6,u5,u4,u3,u2,u1,u0: as a4,a3,a2,a1,a0, but for the primitive. f1,f2 half-products */ int version; double t1,t2,aa[],b1,b0; /* this version does not contain much information - the best way to figure out what is happening is to compute the integrals above, and then check below */ { double u6,u5,u4,u3,u2,u1,u0,f1,f2; int i1,i2; /* if b1=0 and version is 1 or 3 well........... */ if(b1!=0 || version ==1 || version == 3){ u6 = aa[6]/b1; u5 = (aa[5]-6*u6)/b1; u4 = (aa[4]-5*u5)/b1; u3 = (aa[3]-4*u4)/b1; u2 = (aa[2]-3*u3)/b1; u1 = (aa[1]-2*u2)/b1; u0 = (aa[0]-u1)/b1; f1 = (((((u6*t1+u5)*t1+u4)*t1+u3)*t1+u2)*t1+u1)*t1+u0; i1 = 1; if(f1<0) i1 = -1; f1 = log(fabs(f1)) + b1*t1+b0; if(f1>2000.) f1=2000.; if(version==2 || version == 4){ f2 = (((((u6*t2+u5)*t2+u4)*t2+u3)*t2+u2)*t2+u1)*t2+u0; i2 = 1; if(f2<0) i2= -1; f2 = log(fabs(f2)) + b1*t2+b0; if(f2 > 2000.) f2=2000.; if(version == 2)return i1*exp(f1)-i2*exp(f2); return i2*exp(f2)-i1*exp(f1); } if(version==1) return i1*exp(f1); return -i1*exp(f1); } u6 = (((aa[6]/7*(t2-t1)+aa[5]/6)*(t2-t1)+aa[4]/5)*(t2-t1)+aa[3]/4)*(t2-t1); u6 = (((u6 + aa[2]/3)*(t2-t1)+aa[1]/2)*(t2-t1)+aa[0])*(t2-t1)*exp(b0); if(version==4)return u6; return -u6; } /******************************************************************************/ /* this function return a value from a logspline density */ static double dens3(x) double x; /* point of interest */ { return exp(dens33(x)); } /******************************************************************************/ /* this function return the log of a value from a logspline density */ static double dens33(x) double x; /* point of interest */ { int j,k; double f; /* circle through the knots */ for(j=0; (j knots[j]); j++); f = -log(czheta); /* find in between which knots the point is, and compute the spline */ for(k=j-3; k=0 && k<=nknots){ f = f + zheta[k] * (coef[k][0][j] + x * (coef[k][1][j] + x * (coef[k][2][j] + x * coef[k][3][j]))); } } return f; } /******************************************************************************/ /* Numerical integration using gaussian quadrature. See Abromowitz and Stegun. k1 and k2: lower and upper integration bounds fun : function to be integrated */ static double numint(k1,k2,fun,accuracy) /* Intgerals using Gauss-Legendre quadrature with 12 points y1,y2,... - abisces w1,w2,... - weight accuracy - accuracy r1 and r2 - from (k1,k2) to (-1,1) */ double k1,k2,(*fun)(); int accuracy; { double r1,r2,w[33],y[33]; int i; r1 = ((k2 - k1) / 2); r2 = ((k2 + k1) / 2); if(accuracy == 0 || accuracy == 1){ w[1] = 0.467913934572691 * r1; y[1] = 0.238619186083197 * r1; w[2] = 0.360761573048139 * r1; y[2] = 0.661209386466265 * r1; w[3] = 0.171324429379170 * r1; y[3] = 0.932469514203152 * r1; r1 = 0.; for(i=1;i<4;i++)r1 = r1 + w[i]*(fun(r2-y[i])+fun(r2+y[i])); return r1; } w[ 1]= 0.00178328072169643 * r1; y[1 ]= 0.99930504173577217 * r1; w[ 2]= 0.00414703326056247 * r1; y[2 ]= 0.99634011677195533 * r1; w[ 3]= 0.00650445796897836 * r1; y[3 ]= 0.99101337147674429 * r1; w[ 4]= 0.00884675982636395 * r1; y[4 ]= 0.98333625388462598 * r1; w[ 5]= 0.01116813946013113 * r1; y[5 ]= 0.97332682778991098 * r1; w[ 6]= 0.01346304789671864 * r1; y[6 ]= 0.96100879965205377 * r1; w[ 7]= 0.01572603047602472 * r1; y[7 ]= 0.94641137485840277 * r1; w[ 8]= 0.01795171577569734 * r1; y[8 ]= 0.92956917213193957 * r1; w[ 9]= 0.02013482315353021 * r1; y[9 ]= 0.91052213707850282 * r1; w[10]= 0.02227017380838325 * r1; y[10]= 0.88931544599511414 * r1; w[11]= 0.02435270256871087 * r1; y[11]= 0.86599939815409277 * r1; w[12]= 0.02637746971505466 * r1; y[12]= 0.84062929625258032 * r1; w[13]= 0.02833967261425948 * r1; y[13]= 0.81326531512279754 * r1; w[14]= 0.03023465707240248 * r1; y[14]= 0.78397235894334139 * r1; w[15]= 0.03205792835485155 * r1; y[15]= 0.75281990726053194 * r1; w[16]= 0.03380516183714161 * r1; y[16]= 0.71988185017161088 * r1; w[17]= 0.03547221325688239 * r1; y[17]= 0.68523631305423327 * r1; w[18]= 0.03705512854024005 * r1; y[18]= 0.64896547125465731 * r1; w[19]= 0.03855015317861563 * r1; y[19]= 0.61115535517239328 * r1; w[20]= 0.03995374113272034 * r1; y[20]= 0.57189564620263400 * r1; w[21]= 0.04126256324262353 * r1; y[21]= 0.53127946401989457 * r1; w[22]= 0.04247351512365359 * r1; y[22]= 0.48940314570705296 * r1; w[23]= 0.04358372452932345 * r1; y[23]= 0.44636601725346409 * r1; w[24]= 0.04459055816375657 * r1; y[24]= 0.40227015796399163 * r1; w[25]= 0.04549162792741814 * r1; y[25]= 0.35722015833766813 * r1; w[26]= 0.04628479658131442 * r1; y[26]= 0.31132287199021097 * r1; w[27]= 0.04696818281621002 * r1; y[27]= 0.26468716220876742 * r1; w[28]= 0.04754016571483031 * r1; y[28]= 0.21742364374000708 * r1; w[29]= 0.04799938859645831 * r1; y[29]= 0.16964442042399283 * r1; w[30]= 0.04834476223480295 * r1; y[30]= 0.12146281929612056 * r1; w[31]= 0.04857546744150343 * r1; y[31]= 0.07299312178779904 * r1; w[32]= 0.04869095700913972 * r1; y[32]= 0.02435029266342443 * r1; r1 = 0.; for(i=1;i<33;i++)r1 = r1 + w[i]*(fun(r2-y[i])+fun(r2+y[i])); return r1; } /***************************************/ static double numints(vv,k1,k2,fun,accuracy,ip) /* Intgerals using Gauss-Legendre quadrature with 12 points y1,y2,... - abisces w1,w2,... - weight accuracy - accuracy r1 and r2 - from (k1,k2) to (-1,1) */ double k1,k2,(*fun)(),vv[]; int accuracy,ip; { double y[33],w[33],r1,r2; int i1; r1 = ((k2 - k1) / 2); r2 = ((k2 + k1) / 2); if(accuracy == 0 || accuracy == 1){ w[1 ]= 0.467913934572691 * r1; y[1 ]= 0.238619186083197 * r1; w[2 ]= 0.360761573048139 * r1; y[2 ]= 0.661209386466265 * r1; w[3 ]= 0.171324429379170 * r1; y[3 ]= 0.932469514203152 * r1; for(i1=0;i1= 4){ for(i=1; i= 5){ for(i=1; i 0 && j < nknots+1 && (i != 0 || j != 3)){ for(k=i+1; krr) rr=sample[i]; for(i=0;i0)for(j=0; jknots[j]){ derivatives[j+1] = derivatives[j+1] + 6 * (sample[i] - knots[j]); crossprods[j+1][0]=crossprods[j+1][0]+3*pow(sample[i]-knots[j],2.); for(k=0; k<=j; k++) crossprods[j+1][k+1] = crossprods[j+1][k+1] + 9 * pow(((sample[i] - knots[j]) * (sample[i] - knots[k])),2.); } } } /* The interval censored part - we take the midpoints of the intervals */ if(nsample[2]>0)for(j=0; jknots[j]){ derivatives[j+1] = derivatives[j+1] + 6 * (xs - knots[j]); crossprods[j+1][0]=crossprods[j+1][0]+3*pow(xs-knots[j],2.); for(k=0; k<=j; k++) crossprods[j+1][k+1] = crossprods[j+1][k+1] + 9 * pow(((xs - knots[j]) * (xs - knots[k])),2.); } } } /* The right censored part */ if(nsample[3]>0)for(j=0; jknots[j]){ derivatives[j+1] = derivatives[j+1] + 1.5 * (uuu - knots[j]); crossprods[j+1][0]=crossprods[j+1][0]+0.75*pow(uuu-knots[j],2.); for(k=0; k<=j; k++) crossprods[j+1][k+1] = crossprods[j+1][k+1] + 2.25 * pow(((uuu - knots[j]) * (uuu - knots[k])),2.); } } } /* The left censored part */ if(nsample[4]>0)for(j=0; jknots[j]){ derivatives[j+1] = derivatives[j+1] + 1.5 * (uuu - knots[j]); crossprods[j+1][0]=crossprods[j+1][0]+0.75*pow(uuu-knots[j],2.); for(k=0; k<=j; k++) crossprods[j+1][k+1] = crossprods[j+1][k+1] + 2.25 * pow(((uuu - knots[j]) * (uuu - knots[k])),2.); } } } /* symmetarize crossprods */ for(j=0; j4){ for(i=0; i2){ zheta[0]=r1; zheta[1]=r2; } if(iremove<3){ zheta[0]=r1/25.; zheta[1]=r2/25.; } if(iremovenknots-3){ zheta[nknots-3]=r3/25.; if(nknots==4&&iremove==3)zheta[1]=(r2+r3)/50.; zheta[nknots-2]=r4/25.; } } /* If the zhetas are too large, we are better of if we make them smaller */ else{ r1=0.; for(i=0;i10000) for(i=0;i knots[i-2]) suffcombine[i][0] = suffcombine[i][0] + pow(sample[j] - knots[i-2], 3.)/(double)nsample[0] ; } /* for the interval censored observations */ for(j=0; j knots[i-2]) suffcombine[i][1] = suffcombine[i][1] + pow(rr - knots[i-2], 3.)/(double)nsample[0] ; } } /******************************************************************************/ static void suffstat2(suffcombine,coef2,sufficient) double suffcombine[][2],coef2[][NC],sufficient[][2]; /* all defined in lhead.h and the file where they originate. suffcombine defined in suffstat1 */ { int i,j; /* counters */ /* over the basisfunctions */ for(i=0;i12){ qt[0]=knots[4]; qt[1]=knots[nknots-5]; } if(iknotauto == 0&&nknots>9 && nknots <13){ qt[0]=knots[3]; qt[1]=knots[nknots-4]; } if(iknotauto == 0&&nknots>6 && nknots <10){ qt[0]=knots[2]; qt[1]=knots[nknots-3]; } if(iknotauto == 0&&nknots==3){ qt[0]=(knots[0]+knots[1])/2.; qt[1]=(knots[2]+knots[1])/2.; } if(iknotauto == 0&&nknots>3 &&nknots<7){ qt[0]=knots[1]; qt[1]=knots[nknots-2]; } if(iknotauto == 1){ /* compute the piecewise density */ il = piecedens(sample,smp2,smp3,nsample); kk = floor((double)il/2+2.1); if(nknots>kk && nsample[5]==0){ nknots=kk; if(SorC[0] == 0) (void) Rprintf("running with maximum number of degrees of freedom"); else SorC[20] = 1; } if(nknots==nsample[5]+1)SorC[20]=1; /* Check whether there are not too many knots */ kk=0; ll=0; do{ ll=kk+ll; kk=0; if(bound[1] < 0.5 && bound[3] < 0.5){ /* all knots are a minimum of "five" apart */ if((nknots-1) * five >= nsample[0] - 1){ i = floor(1. + (nsample[0] - 1.) / five); if(SorC[0] == 0){ (void)Rprintf("too many knots, at most %d knots possible\n",i); SorC[0] = -647; } else { SorC[0] = -2; SorC[1] = i; } return; } /* place the 2 extreme knots */ rknots[0] = 1.; rknots[nknots-1] = nsample[0]; /* j and j2 are this way to deal both with odd and even situations */ j = ceil((nknots-1)/2.); j2 = floor((nknots-1)/2.); /* eps1 and eps2 are lower and upper bound on eps, eps is our first guess. */ eps1 = five - pow(((nsample[0] - 1) / five),(1. / (j - 1))); if(eps1 > 0.) eps1 = 0.; eps2 = five - 1.; /* s should become exactly (nsample[0]-1)/2: in that case the knots are symmetric and cover exactly the whole range. We here compute what s would be for the present value of eps s is the span of all the knots: i.e. the location of the middle knot if the first knot is at 1, nknots as specified and eps as guessed. */ do{ eps = (eps1 + eps2) / 2.; s = 1.; w = five; for(i=1; i<=j2; i++){ v = i; /* s is the location after adding another knot */ s = s + w; /* we store the rknots - in case they are good */ rknots[i] = s; rknots[nknots-i-1] = nsample[0] + 1 - s; v = five - v * eps; /* w is what is going to be the next gap */ if(v < 1.) v = 1.; w = w * v; } /* Are there an odd or even number of gaps? */ if(j * 2 == nknots) /* even - no more knots to place. */ s = s + w/2.; else /* odd - the last knot */ rknots[j] = (nsample[0] + 1.) / 2.; /* Is eps too large or too small? */ if(2. * s >= nsample[0]+1) eps1 = eps; else eps2 = eps; /* Are eps1 and eps2 close together */ } while(eps2 - eps1 > .001); } else{ /* if both sides there are finite limits we put them equidistant */ if(bound[1] > 0.5 && bound[3] > 0.5){ for(i=0;i 0.5) rknots[i] = s; else rknots[nknots-i-1]=nsample[0]+1.-s; v = five - v *eps; /* w is what is going to be the next gap */ if(v < 1.) v = 1.; w = w * v; } /* Is eps too large or too small? */ if(s + w >(double)nsample[0]) eps1 = eps; else eps2 = eps; /* Are eps1 and eps2 close together */ } while(eps2 - eps1 > .001); } } if(nknots==3)rknots[1]=nsample[0]/2.; /* Translate rknots in knots */ if(ll==0){ /* the first two knots are easy */ knots[0] = smp2[0]; knots[nknots-1] = smp2[il]; /* cycle through the endpoints, average */ k = 0; for(i=1;i=rknots[i]){ knots[i]=((rknots[i]-smp3[k-1])*smp2[k]+ (smp3[k]-rknots[i])*smp2[k-1])/(smp3[k]-smp3[k-1]); ia=k; k=k+4*il; } } k=ia; } } /* find the first and the third quartile */ for(i=1;i0.25*nsample[0]){ u3=smp2[i]; i=i+2*il; qt[0]=u3; } } for(i=1;i0.75*nsample[0]){ u4=smp2[i]; i=i+2*il; qt[1]=u4; } } /* knots that are close together at the end, are an indicator of a discontinuity we replace the knots if this happens. kk is an indicator that somthing like this is the case - we fix this by, temporarily, cheating and saying that there is a discontinuity (changing bound), ll reminds us to change back, by the way, u2 is the IQR of the data */ if(bound[1]<0.5){ u1=knots[2]-knots[0]; u2=u4-u3; if(u10); if(ll==1||ll==3)bound[1]=0.; if(ll==2||ll==3)bound[3]=0.; /* if after previous changes these knots are still to close together, the density might be real high at the end - we toss out knots in this case */ u1=knots[nknots-1]-knots[nknots-3]; u2=u4-u3; if(u1 knots[j]){ j++; knots[j]=knots[i]; } else { k++; if(SorC[0] == 8){ (void)Rprintf("===> warning: knot %d removed - double knot\n",i+1); if(k == 2){ (void) Rprintf("* several double knots suggests that your data is *\n"); (void) Rprintf("* strongly rounded: attention might be required. *\n"); } } else { SorC[0] = 2 + k; if(SorC[0] == 23)return; SorC[k] = i+1; } } } nknots = j+1; u3=2./(qt[1]-qt[0]); u4=1.-2.*qt[1]/(qt[1]-qt[0]); qt[0]=u4; qt[1]=u3; for(i=0;i=NC || (nknots > nsample[5]+1 && nsample[5]>1)){ if(SorC[0]==0) (void)Rprintf("can not run with that many knots\n"); else SorC[20]=1; nknots=NC-1; if(nknots > nsample[5]+1)nknots=nsample[5]+1; } if(nknots > 0) return nknots; r = 2.5*pow((double)nn,0.2); if(idelete > 0)r=1.6*r; if(idelete > 0 && nn < 51)r=(double)nn/6.; if(r>NC-1.1)r=NC-1.1; if(r<2.5)r=2.5; if(nsample[5]!=0 && r>nsample[5]+1)r=nsample[5]+0.1; return ceil(r); } /******************************************************************************/ static int piecedens(sample,smp2,smp3,nsample) double smp2[],smp3[],sample[]; int nsample []; { int i,j,il,k,m,n; if(nsample[1]>0){ i=1; j=nsample[1]; F77_CALL(xssort)(sample,smp3,&j,&i); } if(nsample[2]>0){ for(i=0;i0){ for(i=0;i0){ for(i=0;i0){ for(i=0;i=0;i=i-1){ if(smp3[i]>0){ smp3[i+1]=smp3[i+1]+0.5*smp3[i]; smp3[i]=0.5*smp3[i]; } } if(nsample[2]>0){ k=0; for(i=0;i=0 && i3 < nknots-1) dfunpar[i2]=dfunpar[i2]+coef[i3][i2-1][i1]*zheta[i3]; } } cth = cth + numint(knots[i1-1],knots[i1],fun2,accuracy); } return cth; } /* The integrals are computed numerically per interval between knots */ for(i1=1;i1=0 && i2 < nknots-1 && (i2!=0 || i1!=3)){ shift[i2] = shift[i2] + qolint[0][i1] * coef[i2][0][i1] + qolint[1][i1] * coef[i2][1][i1] + qolint[2][i1] * coef[i2][2][i1] + qolint[3][i1] * coef[i2][3][i1]; /* For the information matrix we need integrals of a basisfunction times a basisfunction times the density, this is a combination of qolints. Many combinations do not exist. */ if(what==2){ for(i3=i1-3;i3<=i2;i3++) if(i3>=0 && i3 < nknots-1 && (i3!=0 || i1!=3)) for(i5=0;i5<4;i5++) for(i4=0;i4<4;i4++) info[i2][i3] = info[i2][i3] + qolint[i5+i4][i1] * coef[i2][i5][i1] * coef[i3][i4][i1]; } } } } /* The following lines make the informationmatrix and score function from what is stored into score and info up to now. */ if(what==2){ for(i1=0;i1 0.5) version=4; version2=1; if(bound[1] > 0.5) version2=2; d1 = zheta[nknots-2] * coef[nknots-2][1][nknots]; d2 = zheta[0] * coef[0][1][0]; e2 = zheta[0] * coef[0][0][0] -log(czheta); if(nknots>3) e1 = zheta[nknots-2] * coef[nknots-2][0][nknots] + zheta[nknots-3] * coef[nknots-3][0][nknots]-log(czheta); else e1 = zheta[nknots-2] * coef[nknots-2][0][nknots]-log(czheta); for(i2=0;i2<7;i2++)aa[i2]=0.; for(i2=0;i2<7;i2++){ aa[i2]=1.; if(i2!=0)aa[i2-1]=0.; qolint[i2][nknots]=expin2(version,knots[nknots-1],bound[4],aa,d1,e1); } for(i2=0;i2<7;i2++)aa[i2]=0.; for(i2=0;i2<7;i2++){ aa[i2]=1.; if(i2!=0)aa[i2-1]=0.; qolint[i2][0]=expin2(version2,knots[0],bound[2],aa,d2,e2); } if(accuracy!=0){ if(nsample[3]>0){ k0=1; for(i2=0;i20){ k0=1; for(i2=0;i20){ k0=1; for(i2=0;i20){ i1=0; for(i2=0;i20){ i1=i1+ng3[i2]; intnum3(xg[i2],qolint,d1,e1,version,bound[4],shift,info, ng3[i2],nsample[0],what); if(i1==nsample[3])i2=NC+3; } } } if(nsample[4]>0){ i1=0; for(i2=0;i20){ i1=i1+ng4[i2]; intnum4(xg[i2],qolint,d2,e2,version2,bound[2],shift,info, ng4[i2],nsample[0],what); if(i1==nsample[4])i2=NC+3; } } } } } for(i1=0;i10) for(i1=0;i1jl && i1=0){ if(i1>jl && i1=0 && i1>jl && i1=0){ for(i2=0; i2<4; i2++) z1[i3] = z1[i3] + coef[i3][i2][jl] * y1[i2]; if(what == 2){ for(i4=jl-3; i4<=jl && i4=0) for(i2=0;i2<4;i2++) for(i5=0;i5<4;i5++) z2[i3][i4] = z2[i3][i4] + coef[i3][i2][jl] * y1[i2+i5] * coef[i4][i5][jl]; } } /* we now compute them for the interval in which the right endpoint is - since y2 = 0 if this interval is the same as the left one, we do not count double*/ for(i3=jr-3; i3<=jr && i3=0){ for(i2=0; i2<4; i2++) z1[i3] = z1[i3] + coef[i3][i2][jr] * y2[i2]; if(what == 2){ for(i4=jr-3; i4<=jr && i4=0) for(i2=0;i2<4;i2++) for(i5=0;i5<4;i5++) z2[i3][i4] = z2[i3][i4] + coef[i3][i2][jr] * y2[i2+i5] * coef[i4][i5][jr]; } } /* now we update shift and info */ if(z0>0.){ for(i3=0; i3jin) z0=z0+qolint[0][i1]; for(i3=i1-3; i3<=i1 && i3=0){ if(i1>jin) for(i2=0; i2<4; i2++) z1[i3]=z1[i3]+coef[i3][i2][i1]*qolint[i2][i1]; if(what==2){ for(i4=i1-3; i4<=i1 && i4=0 && i1>jin) for(i2=0; i2<4; i2++) for(i5=0; i5<4; i5++) z2[i3][i4] = z2[i3][i4] + coef[i3][i2][i1] * qolint[i2+i5][i1] * coef[i4][i5][i1]; } } } /* add the one in the interval in which the point is */ z0=z0+yy[0]; for(i3=jin-3; i3<=jin && i3=0){ for(i2=0; i2<4; i2++) z1[i3] = z1[i3] + coef[i3][i2][jin] * yy[i2]; if(what == 2){ for(i4=jin-3; i4<=jin && i4=0) for(i2=0; i2<4; i2++) for(i5=0; i5<4; i5++) z2[i3][i4] = z2[i3][i4] + coef[i3][i2][jin] * yy[i2+i5] * coef[i4][i5][jin]; } } /* update shift and info */ if(z0>0.){ for(i3=0; i30) (void)numints(yy,knots[jin-1],x,fun48,0,im); else{ for(i1=0; i1<7; i1++){ aa[i1]=1.; if(i1!=0) aa[i1-1]=0.; yy[i1]=expin2(vs,x,bd,aa,d1,e1); } } /* initialize */ z0=0.; for(i1=0; i1=0){ if(i1=0 && i1=0){ for(i2=0; i2<4; i2++) z1[i3] = z1[i3] + coef[i3][i2][jin] * yy[i2]; if(what == 2){ for(i4=jin-3; i4<=jin && i4=0) for(i2=0; i2<4; i2++) for(i5=0; i5<4; i5++) z2[i3][i4] = z2[i3][i4] + coef[i3][i2][jin] * yy[i2+i5] * coef[i4][i5][jin]; } } /* update shift and info */ if(z0>0.){ for(i3=0; i3=1){ for(i=0;i 0.5) version=2; /* The numbers a1,b1,c1,d1,e1 are constants in the integrals */ a[1] = 0.; a[4] = zheta[0] * coef[0][1][0]; a[5] = zheta[0] * coef[0][0][0]; if(what==0){ a[2] = 0.; a[3] = 1.; cth = expin(version,knots[0],bound[2],a); } else{ a[2] = coef[0][1][0]; a[3] = coef[0][0][0]; shift[0] = expin(version,knots[0],bound[2],a) /czheta; if(what==2){ a[1]=coef[0][1][0]*coef[0][1][0]; a[2]=coef[0][1][0]*coef[0][0][0]*2.; a[3]=coef[0][0][0]*coef[0][0][0]; info[0][0] =expin(version,knots[0],bound[2],a)/czheta; } } /* Now the right tail. Only the last 2 basisfunctions are not equal to 0 here. The last one has a linear and a constant term, the one but last one only a constant term. */ version=3; if(bound[3] > 0.5) version=4; a[1] = 0.; a[4] = zheta[nknots-2] * coef[nknots-2][1][nknots]; if(nknots>3) a[5] = zheta[nknots-2] * coef[nknots-2][0][nknots] + zheta[nknots-3] * coef[nknots-3][0][nknots]; else a[5] = zheta[nknots-2] * coef[nknots-2][0][nknots]; if(what == 0){ a[2] = 0.; a[3] = 1.; cth = cth + expin(version,knots[nknots-1],bound[4],a); } else { if(nknots>3){ a[2] = 0.; a[3] = coef[nknots-3][0][nknots]; shift[nknots-3] = expin(version,knots[nknots-1],bound[4],a)/czheta; } a[2] = coef[nknots-2][1][nknots]; a[3] = coef[nknots-2][0][nknots]; shift[nknots-2] = expin(version,knots[nknots-1],bound[4],a)/czheta; } if(what == 2 && nknots>3){ a[2] = 0.; a[3] = coef[nknots-3][0][nknots] * coef[nknots-3][0][nknots]; info[nknots-3][nknots-3]=expin(version,knots[nknots-1],bound[4],a)/czheta; a[2] = coef[nknots-3][0][nknots] * coef[nknots-2][1][nknots]; a[3] = coef[nknots-3][0][nknots] * coef[nknots-2][0][nknots]; info[nknots-2][nknots-3]=expin(version,knots[nknots-1],bound[4],a)/czheta; info[nknots-3][nknots-2] = info[nknots-2][nknots-3]; } if(what == 2){ a[1] = coef[nknots-2][1][nknots] * coef[nknots-2][1][nknots]; a[2] = coef[nknots-2][0][nknots] * coef[nknots-2][1][nknots] *2.; a[3] = coef[nknots-2][0][nknots] * coef[nknots-2][0][nknots]; info[nknots-2][nknots-2]=expin(version,knots[nknots-1],bound[4],a)/czheta; } return cth; } /******************************************************************************/ void pqlsd(coef,knots,bound,ipq,pp,qq,lk,lp) double coef[],knots[],pp[],bound[],qq[]; int *ipq,*lk,*lp; { double v1[2],v2[2]; int ij; if((*ipq)==1) qtop(coef,knots,bound,pp,qq,*lp,*lk); else{ v2[0]=knots[2]; ij=1; qtop(coef,knots,bound,v1,v2,ij,*lk); v2[0]=v2[0]; for(ij=0;ij<*lp;ij++)pp[ij]=pp[ij]*v2[0]; ptoq(coef,knots,bound,pp,qq,*lp,*lk,v2[0]); } } /******************************************************************************/ static void ptoq(coef,knots,bound,pp,qq,lp,lk,inp) double coef[],knots[],bound[],pp[],qq[],inp; int lp,lk; { double l0,l1,r0,r1, s1,s2,s3,s4,x1,x2,x3,sj,xj; int i,j,vr,vl,k; l0 = coef[0]; l1 = coef[1]; r0 = l0; r1 = l1; for(i=0;i=s3){ do{ s1 = s3; x1 = x3; k++; s3 = s3 + pqnum(x1,knots[k],k,knots,coef); x3 = knots[k]; }while(pp[i]>s3); } xj=(knots[k]-knots[k-1])/100.; if(k==1||k==lk-1) xj=xj/4.; if(pp[i]>=s2){ s2 = s1; x2 = x1; do{ x1 = x2; s1 = s2; x2 = x1 + xj; s2 = s2 + pqnum(x1,x2,k,knots,coef); }while(pp[i]>s2); } sj=(pp[i]-s1)/(s2-s1); qq[i]=(1.-sj)*x1+sj*x2; } else qq[i]=lpqexpi(vr,bound[3],(1.-pp[i]),r1,r0); } } /******************************************************************************/ static void qtop(coef,knots,bound,pp,qq,lp,lk) double coef[],knots[],bound[],pp[],qq[]; int lp,lk; { double l0,l1,r0,r1,s2; int i,j,k,vr,vl,ko=0; l0 = coef[0]; l1 = coef[1]; r0 = l0; r1 = l1; for(i=0;iko+1) for(j=ko+1;jko+1) for(j=ko+1;jko+1) for(j=ko+1;j2000.) f1 = 2000; if(version == 1)return i1*exp(f1); if(version == 3)return -i1*exp(f1); i2 = 1; if(d<0) i2 = -1; f2 = log(fabs(1./d)) + d*t2+e; if(f2>2000.) f2 = 2000; if(version==2)return i1*exp(f1)-i2*exp(f2); return i2*exp(f2)-i1*exp(f1); } if(version==4) return (t2-t1)*exp(e); return (t1-t2)*exp(e); } /******************************************************************************/ static double pqnum(x1,x2,k,knots,coef) double x1,x2,knots[],coef[]; int k; { double y[32],w[32],r1,r2; int i; r1 = (x2-x1)/2.; r2 = (x2+x1)/2.; y[0] = 0.125233408511469 * r1; y[1] = 0.367831498998180 * r1; y[2] = 0.587317954286617 * r1; y[3] = 0.769902674194305 * r1; y[4] = 0.904117256370475 * r1; y[5] = 0.981560634246719 * r1; w[0] = 0.249147045813403 * r1; w[1] = 0.233492536538355 * r1; w[2] = 0.203167426723066 * r1; w[3] = 0.160078328543346 * r1; w[4] = 0.106939325995318 * r1; w[5] = 0.047175336386512 * r1; /* w[ 1]= 0.00178328072169643 * r1; y[1 ]= 0.99930504173577217 * r1; w[ 2]= 0.00414703326056247 * r1; y[2 ]= 0.99634011677195533 * r1; w[ 3]= 0.00650445796897836 * r1; y[3 ]= 0.99101337147674429 * r1; w[ 4]= 0.00884675982636395 * r1; y[4 ]= 0.98333625388462598 * r1; w[ 5]= 0.01116813946013113 * r1; y[5 ]= 0.97332682778991098 * r1; w[ 6]= 0.01346304789671864 * r1; y[6 ]= 0.96100879965205377 * r1; w[ 7]= 0.01572603047602472 * r1; y[7 ]= 0.94641137485840277 * r1; w[ 8]= 0.01795171577569734 * r1; y[8 ]= 0.92956917213193957 * r1; w[ 9]= 0.02013482315353021 * r1; y[9 ]= 0.91052213707850282 * r1; w[10]= 0.02227017380838325 * r1; y[10]= 0.88931544599511414 * r1; w[11]= 0.02435270256871087 * r1; y[11]= 0.86599939815409277 * r1; w[12]= 0.02637746971505466 * r1; y[12]= 0.84062929625258032 * r1; w[13]= 0.02833967261425948 * r1; y[13]= 0.81326531512279754 * r1; w[14]= 0.03023465707240248 * r1; y[14]= 0.78397235894334139 * r1; w[15]= 0.03205792835485155 * r1; y[15]= 0.75281990726053194 * r1; w[16]= 0.03380516183714161 * r1; y[16]= 0.71988185017161088 * r1; w[17]= 0.03547221325688239 * r1; y[17]= 0.68523631305423327 * r1; w[18]= 0.03705512854024005 * r1; y[18]= 0.64896547125465731 * r1; w[19]= 0.03855015317861563 * r1; y[19]= 0.61115535517239328 * r1; w[20]= 0.03995374113272034 * r1; y[20]= 0.57189564620263400 * r1; w[21]= 0.04126256324262353 * r1; y[21]= 0.53127946401989457 * r1; w[22]= 0.04247351512365359 * r1; y[22]= 0.48940314570705296 * r1; w[23]= 0.04358372452932345 * r1; y[23]= 0.44636601725346409 * r1; w[24]= 0.04459055816375657 * r1; y[24]= 0.40227015796399163 * r1; w[25]= 0.04549162792741814 * r1; y[25]= 0.35722015833766813 * r1; w[26]= 0.04628479658131442 * r1; y[26]= 0.31132287199021097 * r1; w[27]= 0.04696818281621002 * r1; y[27]= 0.26468716220876742 * r1; w[28]= 0.04754016571483031 * r1; y[28]= 0.21742364374000708 * r1; w[29]= 0.04799938859645831 * r1; y[29]= 0.16964442042399283 * r1; w[30]= 0.04834476223480295 * r1; y[30]= 0.12146281929612056 * r1; w[31]= 0.04857546744150343 * r1; y[31]= 0.07299312178779904 * r1; w[0]= 0.04869095700913972 * r1; y[0]= 0.02435029266342443 * r1; */ r1 = 0.; for(i=0;i<6;i++) r1 = r1 + w[i]*(pqdens(r2-y[i],knots,coef,k)+ pqdens(r2+y[i],knots,coef,k)); return r1; } /******************************************************************************/ static int where(x,knots,lk) double x,knots[]; int lk; { int i; if(x=knots[lk-1])return lk; for(i=1;i0) for(j=0;j 0)return -exp(100000000.); if(version == 2 && exp(d*t+e)+p*d < 0)return exp(100000000.); if(version == 4 && exp(d*t+e)-p*d < 0)return -exp(100000000.); if(version==1)return (log(p*d)-e)/d; if(version==2)return (log(exp(d*t+e)+p*d)-e)/d; if(version==3)return (log(-p*d)-e)/d; return (log(exp(d*t+e)-p*d)-e)/d; } if(version==2)return t+p/exp(e); if(version==4)return t-p/exp(e); return t-p/exp(e); } /******************************************************************************/ logspline/NAMESPACE0000644000176200001440000000055012653771314013476 0ustar liggesusers# Remove the previous line if you edit this file useDynLib(logspline) # Export all names exportPattern(".") S3method(plot, logspline) S3method(plot, oldlogspline) S3method(print, logspline) S3method(print, oldlogspline) S3method(summary, logspline) S3method(summary, oldlogspline) importFrom("graphics", "lines", "par", "plot") importFrom("stats", "runif") logspline/R/0000755000176200001440000000000012654156350012456 5ustar liggesuserslogspline/R/logspline.R0000644000176200001440000006034112654156350014601 0ustar liggesusers# # Copyright [1993-2016] [Charles Kooperberg] # # Licensed under the Apache License, Version 2.0 (the "License"); # you may not use this file except in compliance with the License. # You may obtain a copy of the License at # # http://www.apache.org/licenses/LICENSE-2.0 # # Unless required by applicable law or agreed to in writing, software # distributed under the License is distributed on an "AS IS" BASIS, # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. # See the License for the specific language governing permissions and # limitations under the License. # unstrip <- function(x) { dd <- dim(x) y <- x if(length(dd)==2){ dd2 <- dd[2] if(dd2==1) y<- c(x[,1]) if(dd2==2) y<- cbind(c(x[,1]),c(x[,2])) if(dd2>2) y<- cbind(c(x[,1]),c(x[,2]),c(x[,3])) if(dd2>3)for(i in 4:dd2) y <- cbind(y,c(x[,i])) y } if(length(dd)==1 || length(dd)==0){ y <- c(unlist(c(unlist(x)))) names(y) <- NULL } y } oldlogspline.to.logspline <- function(obj,data) { nobj <- list() nobj$call <- obj$call if(is.null(obj$call))nobj$call <- "translated from oldlogspline" nobj$knots <- sum(obj$coef[-(1:2)]!=0) nobj$coef.pol <- obj$coef[1:2] nobj$coef.kts <- obj$coef[-(1:2)] nobj$coef.kts <- nobj$coef.kts[nobj$coef.kts!=0] nobj$knots <- obj$knots[obj$coef[-(1:2)]!=0] nobj$maxknots <- length(obj$coef)-2 nobj$penalty <- obj$penalty nobj$bound <- obj$bound nobj$samples <- obj$sample nobj$logl <- obj$logl[obj$logl!=0] lx <- length(nobj$logl) nobj$logl <- cbind(nobj$maxknots+1-(lx:1),c(rep(2,lx-1),1),nobj$logl) if(!missing(data))nobj$range <- obj$range else { lx <- 1/(nobj$samples+1) nobj$range <- qoldlogspline(c(lx,1-lx),obj) } nobj$mind class(nobj) <- "logspline" nobj } poldlogspline <- function(q, fit) { if(class(fit)!="oldlogspline") stop("fit is not an oldlogspline object") q <- unstrip(q) sq <- rank(q) q <- sort(q) z <- .C("pqlsd", as.double(fit$coef), as.double(fit$knots), as.double(fit$bound), as.integer(1), pp = as.double(q), as.double(q), as.integer(length(fit$knots)), as.integer(length(q)), PACKAGE = "logspline") zz <- z$pp[sq] if(fit$bound[1] > 0) zz[q 0) zz[q>fit$bound[4]] <- 1 zz } qoldlogspline <- function(p, fit) { if(class(fit)!="oldlogspline") stop("fit is not an oldlogspline object") p <- unstrip(p) sp <- rank(p) p <- sort(p) z <- .C("pqlsd", as.double(fit$coef), as.double(fit$knots), as.double(fit$bound), as.integer(0), as.double(p), qq = as.double(p), as.integer(length(fit$knots)), as.integer(length(p)), PACKAGE = "logspline") zz <- z$qq[sp] zz[p<0] <- NA zz[p>1] <- NA zz } roldlogspline <- function(n, fit) { if(class(fit)!="oldlogspline") stop("fit is not an oldlogspline object") pp <- runif(n) qoldlogspline(pp, fit) } doldlogspline <- function(q, fit) { x <- q if(class(fit)!="oldlogspline") stop("fit is not an oldlogspline object") q <- unstrip(q) y <- fit$coef[1] + x * fit$coef[2] for(i in 1:length(fit$knots)) { if(fit$coef[i+2] != 0) y <- y + fit$coef[i+2] * ((abs(x - fit$knots[i]) + x - fit$knots[i])/2)^3 } y <- exp(y) if(fit$bound[1] > 0) y[x < fit$bound[2]] <- 0 if(fit$bound[3] > 0) y[x > fit$bound[4]] <- 0 y } plot.oldlogspline <- function(x, n = 100, what = "d", xlim, xlab = "", ylab = "", type = "l", add = FALSE, ...) { fit <- x if(class(fit)!="oldlogspline") stop("fit is not an oldlogspline object") if(missing(xlim)) { u1 <- qoldlogspline(0.01, fit) u2 <- qoldlogspline(0.99, fit) u3 <- 1.1 * u1 - 0.1 * u2 u4 <- 1.1 * u2 - 0.1 * u1 } else { u3 <- xlim[1] u4 <- xlim[2] } xx <- (0:(n - 1))/(n - 1) * (u4 - u3) + u3 if(what == "d" || what == "D") yy <- doldlogspline(xx, fit) if(what == "f" || what == "F" || what == "p" || what == "P") yy <- poldlogspline(xx, fit) if(what == "s" || what == "S") yy <- 1 - poldlogspline(xx, fit) if(what == "h" || what == "H") yy <- doldlogspline(xx, fit)/(1 - poldlogspline(xx, fit)) if(missing(xlab)) xlab <- "" if(missing(ylab)) ylab <- "" if(missing(type)) type <- "l" if(add==FALSE)plot(xx, yy, xlab = xlab, ylab = ylab, type = type, ...) else lines(xx,yy, type = type, ...) } print.oldlogspline <- function(x,...) { summary.oldlogspline(x) } summary.oldlogspline <- function(object,...) { if(class(object)!="oldlogspline") stop("fit is not an oldlogspline object") fit <- object if(fit$delete==FALSE)stop(paste("summary.oldlogspline can only provide", "information if delete in oldlogspline is TRUE")) ul <- fit$penalty um <- fit$sample ll <- fit$logl kk <- (1:length(ll)) kk <- kk[ll != 0] + 2 ll <- ll[ll != 0] error<-FALSE rr <- ll[1:(length(ll)-1)]-ll[2:length(ll)] if(length(ll)>1 && max(rr)>0)error<-TRUE bb <- -2 * ll + ul * kk cc1 <- bb cc2 <- bb cc2[1] <- 5/0 cc1[length(bb)] <- 0 if(length(bb) > 1) { for(i in 1:(length(bb) - 1)) { cc1[i] <- max((ll[(i + 1):(length(bb))] - ll[i])/( kk[(i + 1):(length(bb))] - kk[i])) cc2[i + 1] <- min((ll[1:i] - ll[i + 1])/(kk[1:i] - kk[i + 1])) } } c3 <- cc2 - cc1 cc1[c3 < 0] <- NA cc2[c3 < 0] <- NA uu <- cbind(kk, ll, bb, 2 * cc1, 2 * cc2) ww <- rep("", length(bb)) if(error){ cat("Warning - imprecision in loglikelihood (possibly due to heavy tails)\n") cat("the output of summary.oldlogspline might not be correct\n") } dimnames(uu) <- list(ww, c("knots", "loglik", "AIC", "minimum penalty", "maximum penalty")) print(round(uu, 2)) cat(paste("the present optimal number of knots is ", kk[bb== min(bb)],"\n")) if(ul == log(um)) cat(paste("penalty(AIC) was the default: BIC=log(samplesize): log(", um, ")=", round(ul, 2),"\n")) else cat(paste("penalty(AIC) was ", round(ul, 2),", the default (BIC) ", "would have been", round(log(um), 2),"\n")) if(min(kk) > 3 && fit$delete==TRUE){ cat(paste( "models with fewer than", kk[1],"knots ", "can be fitted, but they are not optimal for\n")) cat(paste("the present choice of penalty - choose penalty in", "oldlogspline larger\nto see these fits\n")) } if(min(kk) > 3 && fit$delete==3) cat(paste("models with fewer than", kk[1],"knots ", "were not fitted because of convergence problems\n")) invisible() } oldlogspline <- function(uncensored, right, left, interval, lbound, ubound, nknots, knots, penalty, delete = TRUE) { nsample <- rep(0, 6) # interval is the nterval censored data - a matrix with two columns if(!missing(uncensored))uncensored <- unstrip(uncensored) if(!missing(right))right <- unstrip(right) if(!missing(left))left <- unstrip(left) if(!missing(interval))interval <- unstrip(interval) if(!missing(knots))knots <- unstrip(knots) if(!missing(interval)) { if(length(interval[1, ]) != 2) stop("interval must have two columns") if(min(abs(interval[, 1] - interval[, 2])) < 0) stop( "not all lower bounds smaller than upper bounds") nsample[3] <- length(interval)/2 nsample[1] <- length(interval)/2 # grouping boundaries can not be beyond the boundaries of the density if(!missing(lbound)) interval[interval[, 1] < lbound, 1] <- lbound if(!missing(ubound)) interval[interval[, 2] > ubound, 2] <- ubound sample <- as.vector(t(interval)) ror <- order(interval[,1],interval[,2]) if(nsample[3]>1){ ro1 <- interval[ror[(1:(nsample[3]-1))],1]==interval[ror[2:nsample[3]],1] ro2 <- interval[ror[(1:(nsample[3]-1))],2]==interval[ror[2:nsample[3]],2] nsample[6] <- nsample[3]-sum(ro1+ro2==2) } else nsample[6] <- 1 } # uncensored is the uncensored data if(!missing(uncensored)) { uncensored2 <- uncensored[!is.na(uncensored)] u2 <- length(uncensored) - length(uncensored2) if(u2 > 0) print(paste("***", u2, " NAs ignored in uncensored")) uncensored <- uncensored2 if(nsample[1] > 0) sample <- c(uncensored, sample) if(nsample[1] == 0) sample <- uncensored nsample[1] <- length(uncensored) + nsample[1] nsample[2] <- length(uncensored) uncensored <- sort(uncensored) if(nsample[2]>1) nsample[6] <- sum(uncensored[2:nsample[2]] != uncensored[1:(nsample[2]-1)]) + 1 + nsample[6] else nsample[6] <- nsample[6]+1 } # we can not run on only right or left censored data if(nsample[1] == 0) stop("you either need uncensored or interval censored data") # right is the right censored data if(!missing(right)) { if(nsample[1] > 0) sample <- c(sample, right) if(nsample[1] == 0) sample <- right nsample[1] <- length(right) + nsample[1] nsample[4] <- length(right) right <- sort(right) if(nsample[4]>1){ nsample[6] <- sum(right[2:nsample[4]]!=right[1:(nsample[4]-1)])+ 1 + nsample[6] } else nsample[6] <- nsample[6]+1 } # left is the left censored data if(!missing(left)) { if(nsample[1] > 0) sample <- c(sample, left) if(nsample[1] == 0) sample <- left nsample[1] <- length(left) + nsample[1] nsample[5] <- length(left) left <- sort(left) if(nsample[5]>1){ nsample[6] <- sum(left[2:nsample[5]]!=left[1:(nsample[5]-1)])+ 1 + nsample[6] } else nsample[6] <- nsample[6]+1 } # the default for penalty is bic: log(length(sample)) if(missing(penalty)) penalty <- log(nsample[1]) n1 <- 4 * nsample[1]^0.2 + 1 if(!missing(nknots)) n1 <- nknots + 1 if(!missing(knots)) n1 <- length(knots) + 1 # user provides knots if(!missing(knots)) { nknots <- length(knots) knots <- sort(knots) iautoknot <- 0 if(knots[1] > min(sample)) stop("first knot must be smaller than smallest sample") if(knots[nknots] < max(sample)) stop("last knot should be larger than largest sample") } else { if(missing(nknots)) nknots <- 0 knots <- vector(mode = "double", length = max(nknots, 50)) iautoknot <- 1 } xbound <- c(1, 0, 0, 0, 0) if(!missing(lbound)) { xbound[2] <- 1 xbound[3] <- lbound if(lbound > min(sample)) stop("lbound should be smaller than smallest sample") } if(!missing(ubound)) { xbound[4] <- 1 xbound[5] <- ubound if(ubound < max(sample)) stop("ubound should be larger than largest sample") } # SorC will carry the error messages - in code form SorC <- vector(mode = "integer", length = 35) SorC[1] <- 1 # the actual function call nsample[6] <- nsample[6]-1 z <- .C("logcensor", as.integer(delete), as.integer(iautoknot), as.double(sample), as.integer(nsample), bd = as.double(xbound), SorC = as.integer(SorC), nk = as.integer(nknots), kt = as.double(knots), cf = as.double(c(knots, 0, 0)), as.double(penalty), as.double(sample), as.double(sample), logl = as.double(rep(0, n1 + 1)), PACKAGE = "logspline") bound <- c(z$bd[2], z$bd[3], z$bd[4], z$bd[5]) SorC <- z$SorC # error messages if(abs(SorC[1]) > 2) { for(i in 3:abs(SorC[1])) cat(paste("===> warning: knot ", SorC[i - 1], " removed - double knot\n")) if(SorC[1] < 0) SorC[1] <- -1 if(SorC[1] == 23) SorC[1] <- -3 } if(abs(SorC[1]) > 3) { cat("* several double knots suggests that your data is *\n") cat("* strongly rounded, attention might be required *\n") SorC[1] <- 1 } if(SorC[1] == -3) stop("* too many double knots") if(SorC[1] == -1 && SorC[28] == 0) stop("* no convergence") if(SorC[28] > 0) cat(paste("* convergence problems, smallest number of knots", " tried is ", SorC[28] + 1," *\n")) if(SorC[1] == 2) stop("* sample is too small") if(SorC[1] == -2) stop(paste("* too many knots, at most ", SorC[2], "knots possible")) if(SorC[22] == 1) { cat("possible discontinuity at lower end\n") cat(paste("consider rerunning with lbound=", z$kt[1], "\n")) } if(SorC[22] == 3) { cat("possible infinite density at lower end\n") cat("running program with fewer knots\n") } if(SorC[21] == 1) cat("running with maximum degrees of freedom\n") if(SorC[25] >0) cat("* problems are possibly due to a very heavy right tail *\n") if(SorC[24] >0) cat("* problems are possibly due to a very heavy left tail *\n") if(SorC[23] == 3) { cat("possible infinite density at upper end\n") cat("running program with fewer knots\n") } if(SorC[23] == 1) { cat("possible discontinuity at upper end\n") cat(paste("consider rerunning with ubound=", z$kt[z$nk], "\n")) } if(delete && SorC[28]>0)delete<-3 coef <- z$cf[1:(z$nk + 2)] uu <- 3:z$nk if(delete == FALSE)uu <- 1 fit <- list(coef = coef, knots = z$kt[1:z$nk], bound = bound, logl = z$logl[ uu], penalty = penalty, sample = nsample[1], delete = delete) class(fit) <- "oldlogspline" fit } logspline <- function(x, lbound, ubound, maxknots=0, knots, nknots=0, penalty= -1, silent = TRUE,mind= -1, error.action=2) { call <- match.call() if(!missing(x))x <- unstrip(x) data <- x ilx <- 0; iux <- 0 if(!missing(lbound)){ilx <- 1;jlx <- lbound} if(!missing(ubound)){iux <- 1;jux <- ubound} u2 <- length(data) data <- data[!is.na(data)] nsample <- length(data) if(nsample<10)stop("not enough data") if(u2 !=nsample) print(paste("***", u2-nsample, " NAs ignored in data")) data <- sort(data) # data can not be beyond the boundaries of the density if(!missing(lbound)) if(data[1] < lbound) stop("data below lbound") if(!missing(ubound)) if(data[nsample] > ubound) stop("data above ubound") mm <- range(data) if(!missing(lbound)) mm <- range(c(mm, lbound)) if(!missing(ubound)) mm <- range(c(mm, ubound)) # boundaries ilow <- (!missing(lbound)) * 1 iupp <- (!missing(ubound)) * 1 low <- 0 upp <- 0 if(ilow == 1) low <- lbound if(iupp == 1) upp <- ubound # get the maximal dimension intpars <- c(-100, rep(0, 9)) z <- .C("nlogcensorx", z = as.integer(intpars), PACKAGE = "logspline") maxp <- z$z[1] # organize knots kts <- vector(mode = "double", length = max(maxp)) if(maxknots > maxp - 5) warning(paste("maxknots reduced to", maxp)) nknots <- -nknots if(!missing(knots)) { nknots <- length(knots) knots <- sort(knots) if(!missing(lbound)) if(min(knots) < lbound) stop("data (knots) below lbound") if(!missing(ubound)) if(max(knots) > ubound) stop("data (knots) above ubound") if(nknots < 3) stop("need at least three starting knots") if(nknots > maxp - 5) stop(paste("at most", maxp - 5, "knots possible")) kts[1:nknots] <- knots } silent <- (silent == FALSE) # group parameters intpars <- c(nsample, maxknots, nknots, silent, 1-ilow, 1-iupp,mind) dpars <- c(penalty, low, upp) data <- c(data, rep(0, maxp)) # do it z <- .C("nlogcensor", ip = as.integer(intpars), coef = as.double(data), dp = as.double(dpars), logl = as.double(rep(0, maxp)), ad = as.integer(rep(0, maxp)), kts = as.double(kts), PACKAGE = "logspline") # error messages if(z$ip[1] != 0 && z$ip[1]<100) { if(z$ip[1] == 17) warning("too many knots beyond data") if(z$ip[1] == 18) warning("too many knots before data") if(z$ip[1] == 39) warning("too much data close together") if(z$ip[1] == 40) warning("no model could be fitted") if(z$ip[1] == 2) warning("error while solving system") if(z$ip[1] == 8) warning("too much step-halving") if(z$ip[1] == 5) warning("too much step-halving") if(z$ip[1] == 7) warning("numerical problems, likely tail related. Try lbound/ubound") if(z$ip[1] == 1) warning("no convergence") i <- 0 if(missing(knots))i<- 1 if(z$ip[1] == 3 && i==1) warning("right tail extremely heavy, try running with ubound") if(z$ip[1] == 4 && i==1) warning("left tail extremely heavy, try running with lbound") if(z$ip[1] == 6 && i==1) warning("both tails extremely heavy, try running with lbound and ubound") if(z$ip[1] == 3 && i==0) warning("right tail too heavy or not enough knots in right tail") if(z$ip[1] == 4 && i==0) warning("left tail too heavy or not enough knots in left tail") if(z$ip[1] == 6 && i==0) warning("both tails too heavy or not enough knots in both tail") if(error.action==0) stop("fatal error") if(error.action==1) { print("no object returned") invisible() } if(error.action==2) { if(ilx==0 && iux==0)z <- oldlogspline(x) if(ilx==0 && iux==1)z <- oldlogspline(x,ubound=jux) if(ilx==1 && iux==0)z <- oldlogspline(x,lbound=jlx) if(ilx==1 && iux==1)z <- oldlogspline(x,lbound=jlx,ubound=jux) z <- oldlogspline.to.logspline(z,x) z$call <- call warning("re-ran with oldlogspline") z } } else{ if(z$ip[1]>100) { warning(" Not all models could be fitted") } # organize logl logl <- cbind(z$ad, z$logl) logl <- cbind(2+(1:z$ip[3]),logl[1+(1:z$ip[3]), ]) kk <- (1:length(logl[,1])) kk <- kk[logl[, 2] == 0 ] if(length(kk)>0)logl <- logl[-kk,] # bye bye fit <- list(call = call, nknots = z$ip[2], coef.pol = z$coef[1:2], coef.kts = z$coef[2 + (1:z$ip[2])], knots = z$kts[1:z$ip[2]], maxknots = z$ip[3]+2, penalty = z$dp[1], bound = c(ilow, low, iupp, upp), samples = nsample, logl = logl, range = mm, mind = z$ip[7]) class(fit) <- "logspline" fit} } plogspline <- function(q, fit) { if(class(fit)!="logspline") stop("fit is not a logspline object") if(!missing(q))q <- unstrip(q) sq <- rank(q) q <- sort(q) z <- .C("rpqlsd", as.double(c(fit$coef.pol, fit$coef.kts)), as.double(fit$knots), as.double(fit$bound), as.integer(1), pp = as.double(q), as.integer(length(fit$knots)), as.integer(length(q)), PACKAGE = "logspline") zz <- z$pp[sq] if(fit$bound[1] > 0) zz[q 0) zz[q>fit$bound[4]] <- 1 zz } qlogspline <- function(p, fit) { if(class(fit)!="logspline") stop("fit is not a logspline object") if(!missing(p))p <- unstrip(p) sp <- rank(p) p <- sort(p) z <- .C("rpqlsd", as.double(c(fit$coef.pol, fit$coef.kts)), as.double(fit$knots), as.double(fit$bound), as.integer(0), qq = as.double(p), as.integer(length(fit$knots)), as.integer(length(p)), PACKAGE = "logspline") zz <- z$qq[sp] zz[p<0] <- NA zz[p>1] <- NA zz } rlogspline <- function(n, fit) { if(class(fit)!="logspline") stop("fit is not a logspline object") pp <- runif(n) qlogspline(pp, fit) } dlogspline <- function(q, fit) { if(class(fit)!="logspline") stop("fit is not a logspline object") if(!missing(q))q <- unstrip(q) x <- q y <- fit$coef.pol[1] + x * fit$coef.pol[2] for(i in 1:length(fit$knots)) y <- y + fit$coef.kts[i] * ((abs(x - fit$knots[i]) +x- fit$knots[i])/2)^3 y <- exp(y) if(fit$bound[1] > 0) y[x < fit$bound[2]] <- 0 if(fit$bound[3] > 0) y[x > fit$bound[4]] <- 0 y } plot.logspline <-function(x, n = 100, what = "d", add = FALSE, xlim, xlab = "", ylab = "", type = "l", ...) { fit <- x if(class(fit)!="logspline") stop("fit is not a logspline object") if(add){ plim <- (par()$usr)[1:2] u4 <- plim[1] u3 <- plim[2] if(!missing(xlim)) { u4 <- max(xlim[1], plim[1]) u3 <- min(xlim[2], plim[2]) } } else{ if(missing(xlim)) { u1 <- qlogspline(0.01, fit) u2 <- qlogspline(0.99, fit) u3 <- 1.1 * u1 - 0.1 * u2 u4 <- 1.1 * u2 - 0.1 * u1 } else { u3 <- xlim[1] u4 <- xlim[2] }} xx <- (0:(n - 1))/(n - 1) * (u4 - u3) + u3 if(what == "d" || what == "D") yy <- dlogspline(xx, fit) if(what == "f" || what == "F" || what == "p" || what == "P") yy <- plogspline(xx, fit) if(what == "s" || what == "S") yy <- 1 - plogspline(xx, fit) if(what == "h" || what == "H") yy <- dlogspline(xx, fit)/(1 - plogspline(xx, fit)) if(missing(xlab)) xlab <- "" if(missing(ylab)) ylab <- "" if(missing(type)) type <- "l" if(add)lines(xx,yy, ...) else plot(xx, yy, xlab = xlab, ylab = ylab, type = type, ...) invisible() } print.logspline <- function(x,...) { summary.logspline(x) } summary.logspline <- function(object,...) { fit <- object if(class(fit)!="logspline") stop("fit is not a logspline object") ul <- fit$penalty um <- fit$samples[1] if(length(fit$samples)>1) um <- fit$samples[1]+ fit$samples[4] else um <- fit$samples kk <- fit$logl[fit$logl[,2] != 0,1] ad <- fit$logl[fit$logl[,2] != 0,2] ll <- fit$logl[fit$logl[,2] != 0,3] bb <- -2 * ll + ul * (kk-1) cc1 <- bb cc2 <- bb cc2[1] <- Inf cc1[length(bb)] <- 0 if(length(bb) > 1) { for(i in 1:(length(bb) - 1)) { cc1[i] <- max((ll[(i + 1):(length(bb))] - ll[i])/(kk[(i + 1): (length(bb))] - kk[i])) cc2[i + 1] <- min((ll[1:i] - ll[i + 1])/(kk[1:i] - kk[i + 1])) } } c3 <- cc2 - cc1 cc1[c3 < 0] <- NA cc2[c3 < 0] <- NA uu <- cbind(kk, ad, ll, bb, 2 * cc1, 2 * cc2) ww <- rep("", length(bb)) dimnames(uu) <- list(ww, c("knots", "A(1)/D(2)", "loglik", "AIC", "minimum penalty", "maximum penalty")) print(round(uu, 2)) cat(paste("the present optimal number of knots is ",kk[bb== min(bb)],"\n")) if(ul == log(um)) cat(paste("penalty(AIC) was the default: BIC=log(samplesize): log(", um, ")=", round(ul, 2), "\n")) else cat(paste("penalty(AIC) was ", round(ul, 2), ", the default (BIC) ", "would have been", round(log(um), 2), "\n")) invisible() } logspline/MD50000644000176200001440000000171512654243261012567 0ustar liggesusers4dd8e8f0d49a03888c4135fa3883adf3 *DESCRIPTION 4a653206f0b058e399f40562e9449249 *INDEX 9ed89ae264cb6adf6563a680edbb7431 *NAMESPACE 058393f025c217ad9deb7a05afe38747 *R/logspline.R e5937390332be13e210110b2f5030d8d *man/dlogspline.Rd 1905f0e1bc2347092ee3a4d6fc806b08 *man/doldlogspline.Rd 0e63737114e136fef7ed9e2b893d8372 *man/logspline.Rd 85aef4792b0f000ec0cf45e3e64e700d *man/oldlogspline.Rd 08c579c346e1f7b79c687bf6dc674269 *man/oldlogspline.to.logspline.Rd 2e949c8c19d43e17f545406546f9ef55 *man/plot.logspline.Rd 32a1ccb884955ec4e85b2a199fda8825 *man/plot.oldlogspline.Rd eabaae5f996c1402466f5a54717a3121 *man/summary.logspline.Rd 81559b9592ebd654c3d138a0c9eef802 *man/summary.oldlogspline.Rd d9d2d511c4cec309ecc1c2f05d87b121 *man/unstrip.Rd 8290d2e9740414e315237f0d5d4024bb *src/Makevars 157084291a6fa50c11e5d7ae2325507f *src/allpack.f 08ec5922327358575ea46e2fe28e4d3f *src/lsdall.c baecd678233af49d9e3174f53caab65b *src/nlsd.c 782c6ba6b56e9842d5854775ce3653e3 *src/x2c.h logspline/DESCRIPTION0000644000176200001440000000130412654243261013757 0ustar liggesusersPackage: logspline Version: 2.1.9 Date: 2016-02-01 Title: Logspline Density Estimation Routines Author: Charles Kooperberg Maintainer: Charles Kooperberg Description: Routines for the logspline density estimation. oldlogspline() uses the same algorithm as the logspline 1.0.x package - the Kooperberg and Stone (1992) algorithm (with an improved interface). The recommended routine logspline() uses an algorithm from Stone et al (1997). Imports: stats, graphics License: Apache License 2.0 Packaged: 2016-02-02 17:55:13 UTC; clk NeedsCompilation: yes Repository: CRAN Date/Publication: 2016-02-03 01:15:45 logspline/man/0000755000176200001440000000000012653771314013032 5ustar liggesuserslogspline/man/summary.oldlogspline.Rd0000644000176200001440000000452412653771314017515 0ustar liggesusers\name{summary.oldlogspline} \alias{summary.oldlogspline} \alias{print.oldlogspline} \title{ Logspline Density Estimation - 1992 version } \description{ This function summarizes both the stepwise selection process of the model fitting by \code{\link{oldlogspline}}, as well as the final model that was selected using AIC/BIC. A \code{logspline} object was fit using the 1992 knot deletion algorithm (\code{\link{oldlogspline}}). The 1997 algorithm using knot deletion and addition is available using the \code{\link{logspline}} function. } \usage{\method{summary}{oldlogspline}(object, ...) \method{print}{oldlogspline}(x, ...)} \arguments{ \item{object,x}{ \code{oldlogspline} object, typically the result of \code{\link{oldlogspline}} } \item{...}{ other arguments are ignored.} } \details{ These function produces the same printed output. The main body is a table with five columns: the first column is a possible number of knots for the fitted model; the second column is the log-likelihood for the fit; the third column is \code{-2 * loglikelihood + penalty * (number of knots - 1)}, which is the AIC criterion; \code{\link{logspline}} selected the model with the smallest value of AIC; the fourth and fifth columns give the endpoints of the interval of values of penalty that would yield the model with the indicated number of knots. (\code{NA}s imply that the model is not optimal for any choice of \code{penalty}.) At the bottom of the table the number of knots corresponding to the selected model is reported, as is the value of penalty that was used. } \references{Charles Kooperberg and Charles J. Stone. Logspline density estimation for censored data (1992). \emph{Journal of Computational and Graphical Statistics}, \bold{1}, 301--328. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{logspline}}, \code{\link{oldlogspline}}, \code{\link{plot.oldlogspline}}, \code{\link{doldlogspline}}, \code{\link{poldlogspline}},\cr \code{\link{qoldlogspline}}, \code{\link{roldlogspline}}.} \examples{ y <- rnorm(100) fit <- oldlogspline(y) summary(fit) } \keyword{distribution} \keyword{smooth} logspline/man/unstrip.Rd0000644000176200001440000000161712653771314015032 0ustar liggesusers\name{unstrip} \alias{unstrip} \title{Reformat data as vector or matrix} \description{This function tries to convert a date.frame or a matrix to a no-frills matrix without labels, and a vector or time-series to a no-frills vector without labels.} \usage{unstrip(x) } \arguments{ \item{x}{ one- or two-dimensional object.} } \value{If \code{x} is two-dimensional a matrix without names, if \code{x} is one-dimensional a numerical vector} \details{Many of the functions for \code{\link{logspline}}, \code{\link{oldlogspline}}, were written in the ``before data.frame'' era; \code{unstrip} attempts to keep all these functions useful with more advanced input objects. In particular, many of these functions call \code{unstrip} before doing anything else.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \examples{ data(co2) unstrip(co2) data(iris) unstrip(iris) } \keyword{utilities} \keyword{classes} logspline/man/logspline.Rd0000644000176200001440000001435112653771314015321 0ustar liggesusers\name{logspline} \alias{logspline} \title{ Logspline Density Estimation } \description{Fits a \code{logspline} density using splines to approximate the log-density using the 1997 knot addition and deletion algorithm (\code{\link{logspline}}). The 1992 algorithm is available using the \code{\link{oldlogspline}} function. } \usage{logspline(x, lbound, ubound, maxknots = 0, knots, nknots = 0, penalty, silent = TRUE, mind = -1, error.action = 2) } \arguments{ \item{x}{ data vector. The data needs to be uncensored. \code{\link{oldlogspline}} can deal with right- left- and interval-censored data. } \item{lbound,ubound}{ lower/upper bound for the support of the density. For example, if there is a priori knowledge that the density equals zero to the left of 0, and has a discontinuity at 0, the user could specify \code{lbound = 0}. However, if the density is essentially zero near 0, one does not need to specify \code{lbound}. } \item{maxknots}{ the maximum number of knots. The routine stops adding knots when this number of knots is reached. The method has an automatic rule for selecting maxknots if this parameter is not specified. } \item{knots}{ ordered vector of values (that should cover the complete range of the observations), which forces the method to start with these knots. Overrules knots. If \code{knots} is not specified, a default knot-placement rule is employed. } \item{nknots}{ forces the method to start with \code{nknots} knots. The method has an automatic rule for selecting \code{nknots} if this parameter is not specified. } \item{penalty}{ the parameter to be used in the AIC criterion. The method chooses the number of knots that minimizes \code{-2 * loglikelihood + penalty * (number of knots - 1)}. The default is to use a penalty parameter of \code{penalty = log(samplesize)} as in BIC. The effect of this parameter is summarized in \code{\link{summary.logspline}}. } \item{silent}{ should diagnostic output be printed? } \item{mind}{ minimum distance, in order statistics, between knots. } \item{error.action}{how should \code{logspline} deal with non-convergence problems? Very-very rarely in some extreme situations \code{logspline} has convergence problems. The only two situations that I am aware of are when there is effectively a sharp bound, but this bound was not specified, or when the data is severly rounded. \code{logspline} can deal with this in three ways. If \code{error.action} is 2, the same data is rerun with the slightly more stable, but less flexible \code{oldlogspline}. The object is translated in a \code{logspline} object using \code{oldlogspline.to.logspline}, so this is almost invisible to the user. It is particularly useful when you run simulation studies, as he code can seemlessly continue. Only the \code{lbound} and \code{ubound} options are passed on to \code{oldlogspline}, other options revert to the default. If \code{error.action} is 1, a warning is printed, and \code{logspline} returns nothing (but does not crash). This is useful if you run a simulation, but do not like to revert to \code{oldlogspline}. If \code{error.action} is 0, the code crashes using the \code{stop} function.} } \value{Object of the class \code{logspline}, that is intended as input for \code{\link{plot.logspline}} (summary plots), \code{\link{summary.logspline}} (fitting summary), \code{\link{dlogspline}} (densities), \code{\link{plogspline}} (probabilities), \code{\link{qlogspline}} (quantiles), \code{\link{rlogspline}} (random numbers from the fitted distribution). The object has the following members: \item{call}{the command that was executed.} \item{nknots}{the number of knots in the model that was selected.} \item{coef.pol}{coefficients of the polynomial part of the spline. The first coefficient is the constant term and the second is the linear term.} \item{coef.kts}{coefficients of the knots part of the spline. The \code{k}-th element is the coefficient of \eqn{(x-t(k))^3_+} (where \eqn{x^3_+} means the positive part of the third power of \eqn{x}, and \eqn{t(k)} means knot \code{k}).} \item{knots}{vector of the locations of the knots in the \code{logspline} model.} \item{maxknots}{the largest number of knots minus one considered during fitting (i.e. with \code{maxknots = 6} the maximum number of knots is 5).} \item{penalty}{the penalty that was used. } \item{bound}{ first element: 0 - \code{lbound} was \eqn{-\inf}{-infinity,} 1 it was something else; second element: \code{lbound}, if specified; third element: 0 - \code{ubound} was \eqn{\inf}{infinity}, 1 it was something else; fourth element: \code{ubound}, if specified. } \item{samples}{the sample size.} \item{logl}{matrix with 3 columns. Column one: number of knots; column two: model fitted during addition (1) or deletion (2); column 3: log-likelihood.} \item{range}{range of the input data.} \item{mind}{minimum distance in order statistics between knots required during fitting (the actual minimum distance may be much larger).} } \references{Charles Kooperberg and Charles J. Stone. Logspline density estimation for censored data (1992). \emph{Journal of Computational and Graphical Statistics}, \bold{1}, 301--328. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{plot.logspline}}, \code{\link{summary.logspline}}, \code{\link{dlogspline}}, \code{\link{plogspline}}, \code{\link{qlogspline}}, \cr \code{\link{rlogspline}}, \code{\link{oldlogspline},} \code{\link{oldlogspline.to.logspline}}.} \examples{ y <- rnorm(100) fit <- logspline(y) plot(fit) # # as (4 == length(-2, -1, 0, 1, 2) -1), this forces these initial knots, # and does no knot selection fit <- logspline(y, knots = c(-2, -1, 0, 1, 2), maxknots = 4, penalty = 0) # # the following example give one of the rare examples where logspline # crashes, and this shows the use of error.action = 2. # set.seed(118) zz <- rnorm(300) zz[151:300] <- zz[151:300]+5 zz <- round(zz) fit <- logspline(zz) # # you could rerun this with # fit <- logspline(zz, error.action=0) # or # fit <- logspline(zz, error.action=1) } \keyword{distribution} \keyword{smooth} logspline/man/summary.logspline.Rd0000644000176200001440000000436312653771314017017 0ustar liggesusers\name{summary.logspline} \alias{summary.logspline} \alias{print.logspline} \title{Logspline Density Estimation } \description{ This function summarizes both the stepwise selection process of the model fitting by \code{\link{logspline}}, as well as the final model that was selected using AIC/BIC. A \code{logspline} object was fit using the 1997 knot addition and deletion algorithm. The 1992 algorithm is available using the \code{\link{oldlogspline}} function. } \usage{\method{summary}{logspline}(object, ...) \method{print}{logspline}(x, ...) } \arguments{ \item{object,x}{\code{logspline} object, typically the result of \code{\link{logspline}}} \item{...}{ other arguments are ignored.} } \details{These function produce identical printed output. The main body is a table with five columns: the first column is a possible number of knots for the fitted model; the second column is the log-likelihood for the fit; the third column is \code{-2 * loglikelihood + penalty * (number of knots - 1)}, which is the AIC criterion; \code{\link{logspline}} selected the model with the smallest value of AIC; the fourth and fifth columns give the endpoints of the interval of values of penalty that would yield the model with the indicated number of knots. (\code{NA}s imply that the model is not optimal for any choice of \code{penalty}.) At the bottom of the table the number of knots corresponding to the selected model is reported, as is the value of penalty that was used. } \references{Charles Kooperberg and Charles J. Stone. Logspline density estimation for censored data (1992). \emph{Journal of Computational and Graphical Statistics}, \bold{1}, 301--328. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{logspline}}, \code{\link{plot.logspline}}, \code{\link{dlogspline}}, \code{\link{plogspline}}, \code{\link{qlogspline}}, \code{\link{rlogspline}},\cr \code{\link{oldlogspline}}.} \examples{ y <- rnorm(100) fit <- logspline(y) summary(fit) } \keyword{distribution} \keyword{smooth} logspline/man/oldlogspline.to.logspline.Rd0000644000176200001440000000350512653771313020432 0ustar liggesusers\name{oldlogspline.to.logspline} \alias{oldlogspline.to.logspline} \title{Logspline Density Estimation - 1992 to 1997 version } \description{Translates an \code{oldlogspline} object in an \code{logspline} object. This routine is mostly used in \code{logspline}, as it allows the routine to use \code{oldlogspline} for some situations where \code{logspline} crashes. The other use is when you have censored data, and thus have to use \code{oldlogspline} to fit, but wish to use the auxiliary routines from \code{logspline}.} \usage{oldlogspline.to.logspline(obj, data) } \arguments{ \item{obj}{ object of class \code{logspline} } \item{data}{ the original data. Used to compute the \code{range} component of the new object. if \code{data} is not available, the 1/(n+1) and n/(n+1) quantiles of the fitted distribution are used for \code{range}. } } \value{ object of the class \code{logspline}. The \code{call} component of the new object is not useful. The \code{delete} component of the old object is ignored.} \references{Charles Kooperberg and Charles J. Stone. Logspline density estimation for censored data (1992). \emph{Journal of Computational and Graphical Statistics}, \bold{1}, 301--328. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{logspline}}, \code{\link{oldlogspline}}.} \examples{ x <- rnorm(100) fit.old <- oldlogspline(x) fit.translate <- oldlogspline.to.logspline(fit.old,x) fit.new <- logspline(x) plot(fit.new) plot(fit.old,add=TRUE,col=2) # # should look almost the same, the differences are the # different fitting routines # } \keyword{distribution} \keyword{smooth} logspline/man/oldlogspline.Rd0000644000176200001440000001263312653771314016021 0ustar liggesusers\name{oldlogspline} \alias{oldlogspline} \title{ Logspline Density Estimation - 1992 version } \description{Fits a \code{logspline} density using splines to approximate the log-density using the 1992 knot deletion algorithm (\code{\link{oldlogspline}}). The 1997 algorithm using knot deletion and addition is available using the \code{\link{logspline}} function. } \usage{oldlogspline(uncensored, right, left, interval, lbound, ubound, nknots, knots, penalty, delete = TRUE) } \arguments{ \item{uncensored}{ vector of uncensored observations from the distribution whose density is to be estimated. If there are no uncensored observations, this argument can be omitted. However, either \code{uncensored} or \code{interval} must be specified. } \item{right}{ vector of right censored observations from the distribution whose density is to be estimated. If there are no right censored observations, this argument can be omitted. } \item{left}{ vector of left censored observations from the distribution whose density is to be estimated. If there are no left censored observations, this argument can be omitted. } \item{interval}{ two column matrix of lower and upper bounds of observations that are interval censored from the distribution whose density is to be estimated. If there are no interval censored observations, this argument can be omitted. } \item{lbound,ubound}{ lower/upper bound for the support of the density. For example, if there is a priori knowledge that the density equals zero to the left of 0, and has a discontinuity at 0, the user could specify \code{lbound = 0}. However, if the density is essentially zero near 0, one does not need to specify \code{lbound}. The default for \code{lbound} is \code{-inf} and the default for \code{ubound} is \code{inf}. } \item{nknots}{ forces the method to start with nknots knots (\code{delete = TRUE}) or to fit a density with nknots knots (\code{delete = FALSE}). The method has an automatic rule for selecting nknots if this parameter is not specified. } \item{knots}{ ordered vector of values (that should cover the complete range of the observations), which forces the method to start with these knots (\code{delete = TRUE}) or to fit a density with these knots \code{delete = FALSE}). Overrules \code{nknots}. If \code{knots} is not specified, a default knot-placement rule is employed. } \item{penalty}{ the parameter to be used in the AIC criterion. The method chooses the number of knots that minimizes \code{-2 * loglikelihood + penalty * (number of knots - 1)}. The default is to use a penalty parameter of \code{penalty = log(samplesize)} as in BIC. The effect of this parameter is summarized in \code{\link{summary.oldlogspline}}. } \item{delete}{ should stepwise knot deletion be employed? } } \value{Object of the class \code{oldlogspline}, that is intended as input for \code{\link{plot.oldlogspline}}, \code{\link{summary.oldlogspline}}, \code{\link{doldlogspline}} (densities), \code{\link{poldlogspline}} (probabilities),\cr \code{\link{qoldlogspline}} (quantiles), \code{\link{roldlogspline}} (random numbers from the fitted distribution). The function \code{\link{oldlogspline.to.logspline}} can translate an object of the class \code{oldlogspline} to an object of the class \code{logspline}. The object has the following members: \item{call}{ the command that was executed. } \item{knots }{ vector of the locations of the knots in the \code{oldlogspline} model. old } \item{coef}{ coefficients of the spline. The first coefficient is the constant term, the second is the linear term and the k-th \eqn{(k>2)} is the coefficient of \eqn{(x-t(k-2))^3_+} (where \eqn{x^3_+} means the positive part of the third power of \eqn{x}, and \eqn{t(k-2)} means knot \eqn{k-2}). If a coefficient is zero the corresponding knot was deleted from the model. } \item{bound}{ first element: 0 - \code{lbound} was \eqn{-\inf}{-infinity,} 1 it was something else; second element: \code{lbound}, if specified; third element: 0 - \code{ubound} was \eqn{\inf}{infinity}, 1 it was something else; fourth element: \code{ubound}, if specified. } \item{logl}{ the \code{k}-th element is the log-likelihood of the fit with \code{k+2} knots. } \item{penalty}{ the penalty that was used. } \item{sample}{ the sample size that was used. } \item{delete}{ was stepwise knot deletion employed? } } \references{Charles Kooperberg and Charles J. Stone. Logspline density estimation for censored data (1992). \emph{Journal of Computational and Graphical Statistics}, \bold{1}, 301--328. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{logspline}}, \code{\link{oldlogspline}}, \code{\link{plot.oldlogspline}}, \code{\link{summary.oldlogspline}},\cr \code{\link{doldlogspline}}, \code{\link{poldlogspline}}, \code{\link{qoldlogspline}}, \code{\link{roldlogspline}}, \code{\link{oldlogspline.to.logspline}}.} \examples{ # A simple example y <- rnorm(100) fit <- oldlogspline(y) plot(fit) # An example involving censoring and a lower bound y <- rlnorm(1000) censoring <- rexp(1000) * 4 delta <- 1 * (y <= censoring) y[delta == 0] <- censoring[delta == 0] fit <- oldlogspline(y[delta == 1], y[delta == 0], lbound = 0) } \keyword{distribution} \keyword{smooth} logspline/man/doldlogspline.Rd0000644000176200001440000000505112653771314016161 0ustar liggesusers\name{doldlogspline} \alias{doldlogspline} \alias{poldlogspline} \alias{qoldlogspline} \alias{roldlogspline} \title{Logspline Density Estimation - 1992 version } \description{Probability density function (\code{doldlogspline}), distribution function (\code{poldlogspline}), quantiles (\code{qoldlogspline}), and random samples (\code{roldlogspline}) from a logspline density that was fitted using the 1992 knot deletion algorithm (\code{\link{oldlogspline}}). The 1997 algorithm using knot deletion and addition is available using the \code{\link{logspline}} function. } \usage{doldlogspline(q, fit) poldlogspline(q, fit) qoldlogspline(p, fit) roldlogspline(n, fit) } \arguments{ \item{q}{ vector of quantiles. Missing values (NAs) are allowed. } \item{p}{ vector of probabilities. Missing values (NAs) are allowed. } \item{n}{ sample size. If \code{length(n)} is larger than 1, then \code{length(n)} random values are returned. } \item{fit}{ \code{oldlogspline} object, typically the result of \code{\link{oldlogspline}}. } } \value{ Densities (\code{doldlogspline}), probabilities (\code{poldlogspline}), quantiles (\code{qoldlogspline}), or a random sample (\code{roldlogspline}) from an \code{oldlogspline} density that was fitted using knot deletion. } \details{ Elements of \code{q} or \code{p} that are missing will cause the corresponding elements of the result to be missing. } \references{Charles Kooperberg and Charles J. Stone. Logspline density estimation for censored data (1992). \emph{Journal of Computational and Graphical Statistics}, \bold{1}, 301--328. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{logspline}}, \code{\link{oldlogspline}}, \code{\link{plot.oldlogspline}}, \code{\link{summary.oldlogspline}}} \examples{ x <- rnorm(100) fit <- oldlogspline(x) qq <- qoldlogspline((1:99)/100, fit) plot(qnorm((1:99)/100), qq) # qq plot of the fitted density pp <- poldlogspline((-250:250)/100, fit) plot((-250:250)/100, pp, type = "l") lines((-250:250)/100, pnorm((-250:250)/100)) # asses the fit of the distribution dd <- doldlogspline((-250:250)/100, fit) plot((-250:250)/100, dd, type = "l") lines((-250:250)/100, dnorm((-250:250)/100)) # asses the fit of the density rr <- roldlogspline(100, fit) # random sample from fit } \keyword{distribution} \keyword{smooth} logspline/man/plot.logspline.Rd0000644000176200001440000000421512653771314016274 0ustar liggesusers\name{plot.logspline} \alias{plot.logspline} \title{Logspline Density Estimation } \description{Plots a \code{logspline} density, distribution function, hazard function or survival function from a logspline density that was fitted using the 1997 knot addition and deletion algorithm (\code{\link{logspline}}). The 1992 algorithm is available using the \code{\link{oldlogspline}} function. } \usage{\method{plot}{logspline}(x, n = 100, what = "d", add = FALSE, xlim, xlab = "", ylab = "", type = "l", ...) } \arguments{ \item{x}{\code{logspline} object, typically the result of \code{\link{logspline}}.} \item{n}{the number of equally spaced points at which to plot the density. } \item{what}{what should be plotted: \code{"d"} (density), \code{"p"} (distribution function), \code{"s"} (survival function) or \code{"h"} (hazard function). } \item{add}{should the plot be added to an existing plot.} \item{xlim}{ range of data on which to plot. Default is from the 1th to the 99th percentile of the density, extended by 10\% on each end.} \item{xlab,ylab}{labels plotted on the axes. } \item{type}{type of plot.} \item{...}{other plotting options, as desired} } \details{This function produces a plot of a \code{\link{logspline}} fit at \code{n} equally spaced points roughly covering the support of the density. (Use \code{xlim = c(from, to)} to change the range of these points.) } \references{Charles Kooperberg and Charles J. Stone. Logspline density estimation for censored data (1992). \emph{Journal of Computational and Graphical Statistics}, \bold{1}, 301--328. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{logspline}}, \code{\link{summary.logspline}}, \code{\link{dlogspline}}, \code{\link{plogspline}}, \code{\link{qlogspline}}, \code{\link{rlogspline}}, \code{\link{oldlogspline}}.} \examples{ y <- rnorm(100) fit <- logspline(y) plot(fit) } \keyword{distribution} \keyword{smooth} logspline/man/dlogspline.Rd0000644000176200001440000000466612653771313015474 0ustar liggesusers\name{dlogspline} \alias{dlogspline} \alias{plogspline} \alias{qlogspline} \alias{rlogspline} \title{Logspline Density Estimation} \description{Density (\code{dlogspline}), cumulative probability (\code{plogspline}), quantiles (\code{qlogspline}), and random samples (\code{rlogspline}) from a logspline density that was fitted using the 1997 knot addition and deletion algorithm (\code{\link{logspline}}). The 1992 algorithm is available using the \code{\link{oldlogspline}} function. } \usage{dlogspline(q, fit) plogspline(q, fit) qlogspline(p, fit) rlogspline(n, fit) } \arguments{ \item{q}{ vector of quantiles. Missing values (NAs) are allowed. } \item{p}{ vector of probabilities. Missing values (NAs) are allowed. } \item{n}{ sample size. If \code{length(n)} is larger than 1, then \code{length(n)} random values are returned. } \item{fit}{ \code{logspline} object, typically the result of \code{\link{logspline}}. } } \value{Densities (\code{dlogspline}), probabilities (\code{plogspline}), quantiles (\code{qlogspline}), or a random sample (\code{rlogspline}) from a \code{logspline} density that was fitted using knot addition and deletion. } \details{ Elements of \code{q} or \code{p} that are missing will cause the corresponding elements of the result to be missing. } \references{Charles Kooperberg and Charles J. Stone. Logspline density estimation for censored data (1992). \emph{Journal of Computational and Graphical Statistics}, \bold{1}, 301--328. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{logspline}}, \code{\link{plot.logspline}}, \code{\link{summary.logspline}}, \code{\link{oldlogspline}}.} \examples{ x <- rnorm(100) fit <- logspline(x) qq <- qlogspline((1:99)/100, fit) plot(qnorm((1:99)/100), qq) # qq plot of the fitted density pp <- plogspline((-250:250)/100, fit) plot((-250:250)/100, pp, type = "l") lines((-250:250)/100,pnorm((-250:250)/100)) # asses the fit of the distribution dd <- dlogspline((-250:250)/100, fit) plot((-250:250)/100, dd, type = "l") lines((-250:250)/100, dnorm((-250:250)/100)) # asses the fit of the density rr <- rlogspline(100, fit) # random sample from fit } \keyword{distribution} \keyword{smooth} logspline/man/plot.oldlogspline.Rd0000644000176200001440000000425112653771314016773 0ustar liggesusers\name{plot.oldlogspline} \alias{plot.oldlogspline} \title{Logspline Density Estimation - 1992 version } \description{Plots an \code{oldlogspline} density, distribution function, hazard function or survival function from a logspline density that was fitted using the 1992 knot deletion algorithm. The 1997 algorithm using knot deletion and addition is available using the \code{\link{logspline}} function. } \usage{\method{plot}{oldlogspline}(x, n = 100, what = "d", xlim, xlab = "", ylab = "", type = "l", add = FALSE, ...) } \arguments{ \item{x}{\code{logspline} object, typically the result of \code{\link{logspline}}.} \item{n}{the number of equally spaced points at which to plot the density. } \item{what}{what should be plotted: \code{"d"} (density), \code{"p"} (distribution function), \code{"s"} (survival function) or \code{"h"} (hazard function). } \item{xlim}{ range of data on which to plot. Default is from the 1th to the 99th percentile of the density, extended by 10\% on each end.} \item{xlab,ylab}{labels plotted on the axes. } \item{type}{type of plot.} \item{add}{should the plot be added to an existing plot.} \item{...}{other plotting options, as desired} } \details{This function produces a plot of a \code{\link{oldlogspline}} fit at \code{n} equally spaced points roughly covering the support of the density. (Use \code{xlim=c(from,to)} to change the range of these points.) } \references{Charles Kooperberg and Charles J. Stone. Logspline density estimation for censored data (1992). \emph{Journal of Computational and Graphical Statistics}, \bold{1}, 301--328. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{logspline}}, \code{\link{oldlogspline}}, \code{\link{summary.oldlogspline}}, \code{\link{doldlogspline}}, \code{\link{poldlogspline}},\cr \code{\link{qoldlogspline}}, \code{\link{roldlogspline}}.} \examples{ y <- rnorm(100) fit <- oldlogspline(y) plot(fit) } \keyword{distribution} \keyword{smooth} logspline/INDEX0000644000176200001440000000104512653771314013051 0ustar liggesusersdlogspline Logspline Density Estimation doldlogspline Logspline Density Estimation - 1992 version logspline Logspline Density Estimation oldlogspline Logspline Density Estimation - 1992 version plot.logspline Logspline Density Estimation plot.oldlogspline Logspline Density Estimation - 1992 version summary.logspline Logspline Density Estimation summary.oldlogspline Logspline Density Estimation - 1992 version unstrip Reformat data as vector or matrix