/* Print all months for the period in the range [ before .. y-m .. after ]. */
void
monthrangeb(int y, int m, int jd_flag, int before, int after)
{
struct monthlines year[12];
struct weekdays wds;
char s[MAX_WIDTH], t[MAX_WIDTH];
wchar_t ws[MAX_WIDTH], ws1[MAX_WIDTH];
const char *wdss;
int i, j;
int mpl;
int mw;
int m1, m2;
int printyearheader;
int prevyear = -1;
mpl = jd_flag ? 2 : 3;
mw = jd_flag ? MONTH_WIDTH_B_J : MONTH_WIDTH_B;
wdss = (mpl == 2) ? " " : "";
while (before != 0) {
DECREASEMONTH(m, y);
before--;
after++;
}
m1 = y * 12 + m - 1;
m2 = m1 + after;
mkweekdays(&wds);
/*
* The year header is printed when there are more than 'mpl' months
* and if the first month is a multitude of 'mpl'.
* If not, it will print the year behind every month.
*/
printyearheader = (after >= mpl - 1) && (M2M(m1) - 1) % mpl == 0;
m = m1;
while (m <= m2) {
int count = 0;
for (i = 0; i != mpl && m + i <= m2; i++) {
mkmonthb(M2Y(m + i), M2M(m + i) - 1, jd_flag, year + i);
count++;
}
/* Empty line between two rows of months */
if (m != m1)
printf("\n");
/* Year at the top. */
if (printyearheader && M2Y(m) != prevyear) {
sprintf(s, "%d", M2Y(m));
printf("%s\n", center(t, s, mpl * mw));
prevyear = M2Y(m);
}
/* Month names. */
for (i = 0; i < count; i++)
if (printyearheader)
wprintf(L"%-*ls ",
mw, wcenter(ws, year[i].name, mw));
else {
swprintf(ws, sizeof(ws), L"%-ls %d",
year[i].name, M2Y(m + i));
wprintf(L"%-*ls ", mw, wcenter(ws1, ws, mw));
}
printf("\n");
/* Day of the week names. */
for (i = 0; i < count; i++) {
wprintf(L"%s%ls%s%ls%s%ls%s%ls%s%ls%s%ls%s%ls ",
wdss, wds.names[6], wdss, wds.names[0],
wdss, wds.names[1], wdss, wds.names[2],
wdss, wds.names[3], wdss, wds.names[4],
wdss, wds.names[5]);
}
printf("\n");
/* And the days of the month. */
for (i = 0; i != 6; i++) {
for (j = 0; j < count; j++)
printf("%-*s ",
MW(mw, year[j].extralen[i]),
year[j].lines[i]+1);
printf("\n");
}
m += mpl;
}
}
int glm_fit(int family, int link, int N, int M, int S,
const double *y, const double *prior, const double * offset, const double *X,
const int *stratum, int maxit, double conv, int init,
int *rank, double *Xb,
double *fitted, double *resid, double *weights,
double *scale, int *df_resid, double theta) {
const double eta = 1.e-8; /* Singularity threshold */
int i = 0, j=0;
int Nu, dfr, irls;
int empty = 0;
//TO DO
//need to add condition to ensure theta>0
//trim code, remove unneeded if statements
//add way to handle intercept only models well in R entry
/* Is iteration necessary? */
irls = ( ((offset) || (M>0)) && !((family==GAUSSIAN) && (link==IDENTITY)));
// if (family == BINOMIAL) cout<<"M "<<M<<endl;
// for (int i = 0; i != 1000; i++) {cout<<i<<"\t"<<prior[i]<<endl;}
if (!init || !irls) {
/* Fit intercept and/or strata part of model */
empty = wcenter(y, N, prior, stratum, S, 0, fitted);
}
Nu = 0;
int invalid = 0;
for (i=0; i<N; i++) {
double mu = fitted[i];
double ri, wi;
double pi = prior? prior[i] : 1.0;
if (!muvalid(family, mu, theta)) {
invalid = 1;
pi = 0.0;
}
if (!(pi)) {wi = ri = 0.0;}
else {
Nu ++;
double Vmu = varfun(family, mu, theta);
if (link == family) {
ri = (y[i] - mu)/Vmu;
wi = pi*Vmu;
}
else {
double D = dlink(link, mu);
ri = D*(y[i] - mu);
wi = pi/(D*D*Vmu);
}
}
weights[i] = wi;
resid[i] = ri;
if (weights[i] <= 0.) weights[i] = 0.;
}
/* If M>0, include covariates */
int x_rank = 0, convg = 0, iter = 0;
if ((M == 0) && !offset) convg = 1;
if (M> 0 || offset) { //maybe also where there is an offset?
convg = 0;
double wss_last = 0.0;
if (irls) {
/* IRLS algorithm */
double *yw = (double *) Calloc(N, double); //working y
while(iter<maxit && !convg) {
for (i=0; i<N; i++) {
yw[i] = resid[i] + linkfun(link, fitted[i]); //current estimate of eta + (y-mu)/gradient
}
if (offset) {for (i=0; i<N; i++) {yw[i] -= offset[i];}}
empty = wcenter(yw, N, weights, stratum, S, 1, resid); //removes the mean from yw
//////////// now it tries to fit the regression line (no intercept) to the residuals
const double *xi = X;
double *xbi = Xb;
x_rank = 0;
for (i=0; i<M; i++, xi+=N) {
double ssx = wssq(xi, N, weights);
wcenter(xi, N, weights, stratum, S, 1, xbi);
double *xbj = Xb;
for (j=0; j<x_rank; j++, xbj+=N) wresid(xbi, N, weights, xbj, xbi);
double ssr = wssq(xbi, N, weights);
if (ssr/ssx > eta) {
wresid(resid, N, weights, xbi, resid); //takes the residuals after fitting the regression line (no intercept) to the mean value per stratum
x_rank++;
xbi+=N;
}
}
double wss=0.0;
Nu = 0;
for (i=0; i<N; i++) {
double D, Vmu, ri, wi;
double mu = invlink(link, yw[i] - resid[i]); //ie. (yw - (yw - mean(yw))) = mean(yw)
if (offset) {mu = invlink(link, yw[i] + offset[i] - resid[i]);}
fitted[i] = mu;
double pi = prior? prior[i] : 1.0;
if (!(pi && (weights[i]>0.0))) {wi = ri = 0.0;} else {
if (!(muvalid(family, mu, theta))) {
if ((family == 4) && (mu > 5.0)) {mu = fitted[i] = 5.0;}
if ((family == 4) && (mu < 0.001)) {mu = fitted[i] = 0.001;}
}
Vmu = varfun(family, mu, theta);
Nu ++;
if (link == family) {
ri = (y[i] - mu)/Vmu;
wi = pi*Vmu;
}
else {
D = dlink(link, mu);
ri = D*(y[i] - mu);
wi = pi/(D*D*Vmu);
}
wss += wi*ri*ri;
weights[i] = wi;
resid[i] = ri;
if (weights[i] <= 0.) weights[i] = 0.;
}
}
convg =/* (family==2) ||*/ (Nu<=0) || (iter && (fabs(wss-wss_last)/wss_last < conv));
wss_last = wss;
iter ++;
}
Free(yw);
} else {
