1 /* cbayes - Lisp interface to laplace approximation stuff */
2 /* Copyright (c) 1990, by Luke Tierney */
4 #include <stdlib.h> /* for calloc/realloc */
13 extern void maximize_callback(size_t, PTR
, PTR
, PTR
, PTR
, PTR
);
14 extern void evalfront(char **, size_t *, double *, double *, double *,
15 double *, double *, double *);
17 extern void maxfront();
18 extern void bufputstr(char *);
20 /************************************************************************/
22 /** Definitions and Globals **/
24 /************************************************************************/
28 static char *mem
[MAXALLOC
], memcount
;
31 int n
, m
, k
, itnlimit
, backtrack
, verbose
, vals_suppl
, exptilt
;
36 double typf
, h
, gradtol
, steptol
, maxstep
, dflt
, tilt
, newtilt
, hessadd
;
49 /************************************************************************/
51 /** Fake Replacements for S Interface **/
53 /************************************************************************/
58 static int inited
= FALSE
;
62 for (i
= 0; i
< MAXALLOC
; i
++) mem
[i
] = nil
;
70 makespace(void **pptr
, size_t size
) /* why are we using **char? */
73 return(1); /* we've done, by default, what we asked for. */
76 *pptr
= calloc(size
, 1);
78 *pptr
= realloc(*pptr
, size
);
80 if (size
> 0 && *pptr
== nil
) {
81 return(0); /* xlfail("memory allocation failed"); FIXME:AJR xlfail redef. */
87 /************************************************************************/
89 /** Callback Function **/
91 /************************************************************************/
95 double *x
, double *fval
, double *grad
, double *hess
,
98 maximize_callback(n
, (PTR
) x
,
99 (PTR
) fval
, (PTR
) grad
, (PTR
) hess
, (PTR
) derivs
);
103 call_S(char *fun
, long narg
, char **args
, char **mode
, long *length
,char **names
,
104 long nvals
, char **values
)
106 long n
= length
[0], derivs
;
107 static double *fval
= nil
, *grad
= nil
, *hess
= nil
;
109 makespace((void **)&fval
, 1 * sizeof(double)); /* probably should test the
110 result of this and the next
111 2 to make sure that they are
113 makespace((void **)&grad
, n
* sizeof(double));
114 makespace((void **)&hess
, n
* n
* sizeof(double));
116 callLminfun(n
,(double *)args
[0], fval
, grad
, hess
, &derivs
);
118 values
[0] = (char *) fval
;
119 values
[1] = (derivs
> 0) ? (char *) grad
: nil
;
120 values
[2] = (derivs
> 1) ? (char *) hess
: nil
;
127 /* FIXME:AJR: xlfail(s); */
131 /************************************************************************/
133 /** Numerical Derivatives **/
135 /************************************************************************/
138 numgrad_front(size_t n
, PTR px
, PTR pgrad
, double h
, PTR pscale
)
143 evalfront((char **)&f
, &n
, (double *) px
,
144 &fval
, (double *) pgrad
, nil
, &h
, (double *) pscale
);
148 numhess_front(size_t n
, PTR px
, PTR pf
, PTR pgrad
, PTR phess
, double h
, PTR pscale
)
152 evalfront((char **)&f
, &n
, (double *) px
,
153 (double *) pf
, (double *) pgrad
, (double *) phess
,
154 &h
, (double *) pscale
);
157 /************************************************************************/
159 /** Maximization Interface **/
161 /************************************************************************/
163 /* internals array information */
178 static MaxIPars
getMaxIPars(int *ipars
)
185 ip
.itnlimit
= ipars
[3];
186 ip
.backtrack
= ipars
[4];
187 ip
.verbose
= ipars
[5];
188 ip
.vals_suppl
= ipars
[6];
189 ip
.exptilt
= ipars
[7];
191 ip
.termcode
= ipars
[9];
196 static MaxDPars
getMaxDPars(dpars
)
203 dp
.gradtol
= dpars
[2];
204 dp
.steptol
= dpars
[3];
205 dp
.maxstep
= dpars
[4];
208 dp
.newtilt
= dpars
[7];
209 dp
.hessadd
= dpars
[8];
215 minfo_maximize(PTR px
, PTR pfvals
, PTR pscale
, PTR pip
, PTR pdp
, int verbose
)
221 static double *dx
, *typx
, *fvals
;
225 typx
= (double *) pscale
;
226 fvals
= (double *) pfvals
;
228 ip
= getMaxIPars((int *) pip
);
229 dp
= getMaxDPars((double *) pdp
);
234 if (verbose
>= 0) ip
.verbose
= verbose
;
237 maxfront(&f
, nil
, nil
, dx
, typx
, fvals
, nil
, nil
, nil
,
238 &ip
, &dp
, nil
, &msg
);