void free_problem_data(problem_data_t *pdat)
{
if (pdat->matX1) dmat_free(pdat->matX1);
if (pdat->matX2) dmat_free(pdat->matX2);
if (pdat->ac) free(pdat->ac);
if (pdat->ar) free(pdat->ar);
if (pdat->avg_x) free(pdat->avg_x);
if (pdat->std_x) free(pdat->std_x);
/* pdat->b shoud not be freed */
/* pdat->lambda should not be freed */
}
void free_temporaries(double *tm1, double *tn1, double *tn2, double *tn3,
double *tn4, double *tx1, double *precond,
dmatrix *B, dmatrix *BB)
{
if (tm1) {free(tm1); tm1 = NULL;};
if (tn1) {free(tn1); tn1 = NULL;};
if (tn2) {free(tn2); tn2 = NULL;};
if (tn3) {free(tn3); tn3 = NULL;};
if (tn4) {free(tn4); tn4 = NULL;};
if (tx1) {free(tx1); tx1 = NULL;};
if (precond) free(precond);
if (B ) dmat_free(B);
if (BB) dmat_free(BB);
}
/** \brief Returns the maximum value of the regularization parameter lambda
* that gives a non-zero solution.
*
* @param X feature matrix
* @param b class vector
* @param sflag standardization flag
* - If sflag is 0, compute the maximum value of lambda
* without standardization.
* - If sflag is 1, given matrix is standardized first and
* then the maximum value of lambda is computed.
*
* @return maximum value of lambda
*/
double find_lambdamax(const dmatrix *X, const double *b, const int sflag)
{
double ret;
int i, m, n;
int mp, mn;
double r1, r2;
double *ar, *ac;
double *tmp_m, *tmp_n;
double *avg_x, *std_x;
dmatrix *A;
m = X->m;
n = X->n;
dmat_duplicate(X, &A);
dmat_copy(X, A);
tmp_m = malloc(m*sizeof(double));
tmp_n = malloc(n*sizeof(double));
if (sflag == TRUE)
{
standardize_data(A, b, &avg_x, &std_x, &ac, &ar);
}
else
{
dmat_diagscale(A, b, FALSE, NULL, TRUE);
avg_x = std_x = ac = ar = NULL;
}
/* number of positive class examples */
mp = 0;
for (i = 0; i < m; i++)
{
mp += (b[i]>0 ? 1:0);
}
mn = m - mp;
r1 = (double)mn/m;
r2 = (double)mp/m;
for (i = 0; i < m; i++)
{
tmp_m[i] = (b[i] > 0 ? r1 : r2);
}
dmat_yAmpqTx( A, ac, ar, tmp_m, tmp_n);
ret = dmat_norminf(n, tmp_n) / m;
free(tmp_n);
free(tmp_m);
dmat_free(A);
if (avg_x) free(avg_x);
if (std_x) free(std_x);
if (ac) free(ac);
if (ar) free(ar);
return ret;
}
void drawprice()
{
int cls,h,my,rws;
if (Kex!=NULL){drawpricesym();return;}
rws=Data->r;
cls=Data->c;
PDate=dvec_dup(Date);
PData=dmat_new(rws,cls);
DO(Data->n,PData->v[i]=Data->v[i]);
if (Split) {
h=roundint(Rh/4);
setsxywh(Rx,(Ry+Rh-h),Rw,h-Ly);
setrxywh(Rx,Ry,Rw,Rh-(1+h+Ly));
}
my=(int) My;
setgxywh(Rx,Ry+my,Rw,Rh-(my+LabelHit+Ly));
getdateaxis(0);
drawpre(-1);
drawprices();
drawpost();
drawkeys();
if (!Split) return;
dmat_free(PData);
PData=dmat_new(1,cls);
DO(cls,PData->v[i]=Size->v[i]);
setrxywh(Sx,Sy,Sw,Sh);
setgxywh(Sx,Sy+my,Sw,Sh-(my+LabelHit+Ly));
drawpre(-1);
drawvolumes();
drawpost();
}
SEXP classifyR(SEXP pm, SEXP pn, SEXP pnz, SEXP pval, SEXP pjdx,
SEXP prdx, SEXP pb, SEXP psolution, SEXP ptflag, SEXP ppflag,
SEXP pqflag)
#endif
{
/* test data */
dmatrix *matX; /**< feature matrix */
double *b; /**< class vector */
/* solution buffer */
double *solution; /* entry 1 : intercept, */
/* entries 2~n+1: coefficients */
/* commandline argument */
char *ifile_model, *ifile_x, *ifile_y, *ofile;
int pflag; /* probability flag */
int tflag; /* test flag */
int qflag; /* quiet flag */
clock_t clock_pre, clock_sol, clock_wri, clock_end;
int error_count;
double *res; /**< result [+1,-1] */
int model_m, model_n, model_nz, ret;
char line[BUFFER_SIZE];
char name[BUFFER_SIZE];
clock_pre = clock();
#ifndef Rpackage
parse_command_line_args(argc, argv, &tflag, &pflag, &qflag,
&ifile_x, &ifile_y, &ifile_model, &ofile);
/* read data */
if (!qflag) fprintf(stderr,"\nReading data...\n\n");
read_mm_new_matrix(ifile_x, &matX);
if (ifile_y != NULL)
read_mm_new_vector(ifile_y, &b);
else
b = NULL;
#else
convert_Rdata(pm,pn,pnz,pval,pjdx,prdx,pb,psolution,ptflag,ppflag,pqflag,
&pflag,&qflag,&tflag,&matX,&b);
#endif
if (!qflag) summary_prob(matX, tflag);
#ifndef Rpackage
get_mm_info(ifile_model, &model_m, &model_n, &model_nz);
if (matX->n != model_m-1)
{
/* test examples : n = coefficients,
model : m = intercept+coefficients. */
fprintf(stderr, "ERROR: number of features are different\n");
fprintf(stderr, " %d features in test examples, but %d in model.\n",
matX->n, model_m-1);
exit(1);
}
if (model_n == 1) /* model for one lambda */
{
read_mm_new_vector(ifile_model, &solution);
/* run classifier */
if (!qflag) fprintf(stderr,"Running classifier...\n");
clock_sol = clock();
res = malloc(sizeof(double)*(matX->m));
ret = l1_logreg_classify(matX, b, solution, pflag, res, &error_count);
if (!qflag) summary_result(matX, res, error_count);
/*
* write solution
*/
clock_wri = clock();
if (ofile != NULL)
{
sprintf(line, comment1, ifile_x, PACKAGE_NAME, VERSION);
if (pflag == TRUE)
write_mm_vector(ofile, matX->m, res, line, TYPE_E);
else
write_mm_vector(ofile, matX->m, res, line, TYPE_G);
}
clock_end = clock();
if (!qflag) summary_time(clock_pre, clock_sol, clock_wri, clock_end);
dmat_free(matX);
free(b);
free(solution);
free(res);
return EXIT_SUCCESS;
}
else /* model for multiple lambdas */
{
int i;
double *lambda_vec, *error_vec;
dmatrix *mat_model;
clock_sol = clock();
/* read lambda vector */
sprintf(name, "%s_lambda", ifile_model);
read_mm_new_vector(name, &lambda_vec);
read_mm_new_matrix_transpose(ifile_model, &mat_model);
/* each row is intercept+coefficients */
res = malloc(sizeof(double)*(matX->m));
error_vec = malloc(sizeof(double)*mat_model->m);
solution = malloc(sizeof(double)*mat_model->n);
for (i = 0; i < mat_model->m; i++)
{
if (!qflag) fprintf(stderr," lambda = %e\n",lambda_vec[i]);
dmat_get_row(mat_model, i, solution);
ret = l1_logreg_classify(matX, b, solution, pflag,
res, &error_count);
if (!qflag) summary_result(matX, res, error_count);
error_vec[i] = error_count;
}
/* write solution */
clock_wri = clock();
if (ofile != NULL)
{
sprintf(line, comment2, ifile_x, PACKAGE_NAME, VERSION);
write_mm_vector(ofile, mat_model->m, error_vec, line, TYPE_G);
}
clock_end = clock();
if (!qflag) summary_time(clock_pre, clock_sol, clock_wri, clock_end);
dmat_free(matX);
dmat_free(mat_model);
free(b);
free(res);
free(solution);
free(error_vec);
free(lambda_vec);
return EXIT_SUCCESS;
}
#else
if (TYPEOF(psolution)==REALSXP) /* model for one lambda */
{
SEXP Rres;
solution = REAL(psolution);
/* run classifier */
if (!qflag) fprintf(stderr,"Running classifier...\n");
//clock_sol = clock();
PROTECT(Rres = allocVector(REALSXP,matX->m));
res = REAL(Rres);
ret = l1_logreg_classify(matX, b, solution, pflag, res, &error_count);
if (!qflag) summary_result(matX, res, error_count);
if (matX->nz >= 0) {
free(matX->idx);
free(matX->jdx);
free(matX->rdx);
}
free(matX);
UNPROTECT(1);
return Rres;
}
else /* model for multiple lambdas */
{
int i;
SEXP Rerror_vec;
double *lambda_vec, *error_vec;
dmatrix *mat_model;
mat_model = malloc(sizeof(dmatrix));
mat_model->m = *INTEGER(VECTOR_ELT(psolution,0));
mat_model->n = *INTEGER(VECTOR_ELT(psolution,1));
mat_model->nz = *INTEGER(VECTOR_ELT(psolution,2));
mat_model->val = REAL(VECTOR_ELT(psolution,3));
mat_model->idx = malloc(sizeof(int)*mat_model->nz);
mat_model->jdx = malloc(sizeof(int)*mat_model->nz);
mat_model->rdx = malloc(sizeof(int)*(mat_model->m+1));
lambda_vec = REAL(VECTOR_ELT(psolution,6));
if (mat_model->nz >= 0)
{
int *pjdx, *prdx;
pjdx = INTEGER(VECTOR_ELT(psolution,4));
prdx = INTEGER(VECTOR_ELT(psolution,5));
/* C uses zero-based indexing while R uses one-based indexing */
for (i = 0; i < mat_model->nz; i++) {
mat_model->jdx[i] = pjdx[i]-1;
}
for (i = 0; i < mat_model->m+1; i++) {
mat_model->rdx[i] = prdx[i]-1;
}
/* build idx from rdx and jdx */
dmat_build_idx(mat_model);
}
/* each row is intercept+coefficients */
res = malloc(sizeof(double)*(matX->m));
//error_vec = malloc(sizeof(double)*mat_model->m);
PROTECT(Rerror_vec = allocVector(REALSXP,mat_model->m));
error_vec = REAL(Rerror_vec);
solution = malloc(sizeof(double)*mat_model->n);
for (i = 0; i < mat_model->m; i++)
{
if (!qflag) fprintf(stderr," lambda = %e\n",lambda_vec[i]);
dmat_get_row(mat_model, i, solution);
ret = l1_logreg_classify(matX, b, solution, pflag, res,
&error_count);
if (!qflag) summary_result(matX, res, error_count);
error_vec[i] = error_count;
}
free(mat_model->idx);
free(mat_model->jdx);
free(mat_model->rdx);
free(mat_model);
free(res);
free(solution);
if (matX->nz >= 0) {
free(matX->idx);
free(matX->jdx);
free(matX->rdx);
}
free(matX);
UNPROTECT(1);
return Rerror_vec;
}
#endif
}
SEXP trainR(SEXP pm, SEXP pn, SEXP pnz, SEXP pval, SEXP pjdx, SEXP prdx,
SEXP pb, SEXP plambda, SEXP pqflag, SEXP prflag, SEXP psflag,
SEXP phflag, SEXP pvval, SEXP ptol, SEXP pktol)
#endif
{
/* problem data */
dmatrix *matX; /* feature matrix */
double *b; /* class vector */
double lambda; /* regularization parameter */
train_opts to; /* training options */
double *solution; /* entry 1 : intercept, */
/* entries 2~n+1 : coefficients */
char *ifile_x, *ifile_y, *ofile;
int rflag; /* relative lambda flag */
int hflag; /* histogram & threshold flag */
double lambda_max;
clock_t clock_pre, clock_sol, clock_wri, clock_end;
int total_nt, total_pcg, ret;
clock_pre = clock();
#ifndef Rpackage
parse_command_line_args(argc, argv, &lambda, &to, &rflag, &hflag,
&ifile_x, &ifile_y, &ofile);
/* read data file */
if (to.verbose_level>=2) fprintf(stderr,"\nReading data...\n\n");
read_mm_new_matrix(ifile_x, &matX);
read_mm_new_vector(ifile_y, &b);
#else
convert_Rdata(pm,pn,pnz,pval,pjdx,prdx,pb,plambda,pqflag,prflag,psflag,
phflag,pvval,ptol,pktol,&matX,&b,&lambda,&to,&hflag,&rflag);
#endif
lambda_max = find_lambdamax(matX, b, to.sflag);
if (rflag) lambda = lambda*lambda_max;
if (to.verbose_level>=2)
summary_prob(matX, to.sflag, lambda_max, lambda);
/* intercept(1) + coefficients(2..n+1) */
solution = malloc(sizeof(double)*(matX->n+1));
/* run solver */
if (to.verbose_level>=2) fprintf(stderr,"Running solver...\n");
clock_sol = clock();
ret = l1_logreg_train(matX, b, lambda, to, NULL, NULL,
solution, &total_nt, &total_pcg);
//dmat_profile();
/* show status */
if (matX->nz < 0) total_pcg = -1;
show_status(to.verbose_level, ret, total_nt, total_pcg);
/* write solution */
clock_wri = clock();
if (hflag == TRUE) /* manual thresholding */
{
show_histogram(matX->n, solution+1);
thresholding(matX->n, solution+1, userinput_threshold());
show_histogram(matX->n, solution+1);
}
#ifndef Rpackage
if (ofile != NULL)
{
char linebf[BUFFER_SIZE];
sprintf(linebf, comment1,ifile_x, PACKAGE_NAME, VERSION);
write_mm_vector(ofile, matX->n+1, solution, linebf, TYPE_E);
}
/* print info */
clock_end = clock();
if (to.verbose_level>=2)
summary_time(clock_pre,clock_sol,clock_wri,clock_end);
if (to.verbose_level==1)
summary_all(matX->m, matX->n, lambda, lambda_max, clock_wri-clock_sol,
total_nt, total_pcg, solution+1);
free(solution);
free(b);
dmat_free(matX);
return EXIT_SUCCESS;
#else
{
SEXP res;
res = create_Rdata_to_return(matX->n, lambda, solution);
if (matX->nz >= 0) {
free(matX->idx);
free(matX->jdx);
free(matX->rdx);
}
free(matX);
free(solution);
return res;
}
#endif
}
