mclMatrix* mclDiagOrdering
( const mclMatrix* M
, mclVector** vecp_attr
)
{ int n_cols = N_COLS(M)
; mclMatrix* diago = mclxAllocZero(NULL, NULL)
; long col
; if (*vecp_attr != NULL)
mclvFree(vecp_attr)
; *vecp_attr = mclvResize(NULL, n_cols)
; for (col=0;col<n_cols;col++)
{ ofs offset = -1
; double selfval = mclvIdxVal(M->cols+col, col, &offset)
; double center = mclvPowSum(M->cols+col, 2.0)
/* double maxval = mclvMaxValue(M->cols+col)
*/
; double bar = MCX_MAX(center, selfval) - dpsd_delta
; mclIvp* ivp = (*vecp_attr)->ivps+col
; ivp->idx = col
; ivp->val = center ? selfval / center : 0
; if (offset >= 0) /* take only higher valued entries */
mclvSelectGqBar(diago->cols+col, bar)
; }
; return diago
; }
void mcxDiagnosticsAttractor
( const char* ffn_attr
, const mclMatrix* clus2elem
, const mcxDumpParam dumpParam
)
{ int n_nodes = clus2elem->n_range
; int n_written = dumpParam->n_written
; mclMatrix* mtx_Ascore = mclxAllocZero(n_written, n_nodes)
; mcxIO* xfOut = mcxIOnew(ffn_atr, "w")
; dim d = 0
; if (mcxIOopen(xfOut, RETURN_ON_FAIL) == STATUS_FAIL)
{ mclxFree(&mtx_Ascore)
; mcxIOfree(&xfOut)
; return
; }
; for(d=0; d<n_written; d++)
{ mclMatrix* iterand = *(dumpParam->iterands+d)
; mclVector* vec_Ascore = NULL
; if (iterands->n_cols != n_nodes || iterand->n_range != n_nodes)
{ fprintf(stderr, "mcxDiagnosticsAttractor: dimension error\n")
; mcxExit(1)
; }
vec_Ascore = mcxAttractivityScale(iterand)
; mclvRenew((mtx_Ascore->cols+d), vec_Ascore->ivps, vec_Ascore->n_ivps)
; mclvFree(&vec_Ascore)
; }
mclxbWrite(mtx_Ascore, xfOut, RETURN_ON_FAIL)
; mclxFree(mtx_Ascore)
; }
CAMLprim value caml_mcl(value inflation, value arr)
{
CAMLparam2(inflation, arr);
int i, cols = Wosize_val(arr);
mclv *domc = mclvCanonical(NULL, cols, 1.0);
mclv *domr = mclvCanonical(NULL, cols, 1.0);
mclx *res_mat, *mx = mclxAllocZero(domc, domr);
mclAlgParam *mlp;
value res;
for (i = 0; i < cols; ++i) {
value col = Field(arr, i);
int j, rows = Wosize_val(col);
mclv *col_vec = &mx->cols[i];
if (!cols)
continue;
mclvResize(col_vec, rows);
for (j = 0; j < rows; ++j) {
value t = Field(col, j);
col_vec->ivps[j].idx = Int_val(Field(t, 0));
col_vec->ivps[j].val = Double_val(Field(t, 1));
}
}
mclAlgInterface(&mlp, NULL, 0, NULL, mx, 0);
/* Optionally set inflation */
if (inflation != Val_none) {
mlp->mpp->mainInflation = Double_val(Some_val(inflation));
}
mclAlgorithm(mlp);
res_mat = mlp->cl_result;
cols = res_mat->dom_cols->n_ivps;
res = caml_alloc(cols, 0);
for (i = 0; i < cols; ++i) {
mclv *col_vec = &res_mat->cols[i];
int j, rows = col_vec->n_ivps;
value row = caml_alloc(rows, 0);
for (j = 0; j < rows; ++j) {
Store_field(row, j, Val_int(col_vec->ivps[j].idx));
}
Store_field(res, i, row);
}
mclAlgParamFree(&mlp, TRUE);
CAMLreturn(res);
}
mclMatrix* mclDag
( const mclMatrix* A
, const mclInterpretParam* ipp
)
{ dim d
;
double w_selfval= ipp ? ipp->w_selfval: 0.999
;
double w_maxval = ipp ? ipp->w_maxval : 0.001
;
double delta = ipp ? ipp->delta : 0.01
;
mclMatrix* M = mclxAllocZero
( mclvCopy(NULL, A->dom_cols)
, mclvCopy(NULL, A->dom_rows)
)
;
for (d=0; d<N_COLS(A); d++) /* thorough clean-up */
{ mclVector* vec = A->cols+d
;
mclVector* dst = M->cols+d
;
double selfval = mclvIdxVal(vec, vec->vid, NULL)
;
double maxval = mclvMaxValue(vec)
;
double bar = selfval < maxval
? ( (w_selfval * selfval)
+ (w_maxval * maxval)
)
: delta
? selfval / (1 + delta)
: selfval
;
int n_bar = mclvCountGiven(vec, mclpGivenValGQ, &bar)
;
mclvCopyGiven(dst, vec, mclpGivenValGQ, &bar, n_bar)
;
}
if (0)
{ dim ne = mclxNrofEntries(M)
;
fprintf(stderr, "nroff entries %u\n", (unsigned) ne)
;
}
return M
;
}
int main
( int argc
, const char* argv[]
)
{ mcxIO* xfmx = mcxIOnew("-", "r"), *xfout = mcxIOnew("-", "w")
; mclx* mx = NULL
; mclv* mx_diag = NULL
; mcxstatus parseStatus = STATUS_OK
; mcxOption* opts, *opt
; dim N_edge = 0
; dim* offsets
; dim template_n_nodes = 0
; mcxbool plus = FALSE
; double e_min = 1.0
; double e_max = 0.0
; double skew = 0.0
; double radius = 0.0
; double n_sdev = 0.5
; double n_range = 2.0
; double g_radius = 0.0
; double g_mean = 0.0
; double g_sdev = 0.0
; double g_min = 1.0
; double g_max = 0.0
; mcxbool do_gaussian = FALSE
; dim i = 0
; dim N_remove = 0
; dim N_add = 0
; dim N_shuffle = 0
; unsigned long random_ignore = 0
; srandom(mcxSeed(2308947))
; mcxOptAnchorSortById(options, sizeof(options)/sizeof(mcxOptAnchor) -1)
; if
(!(opts = mcxOptParse(options, (char**) argv, argc, 1, 0, &parseStatus)))
exit(0)
; mcxLogLevel =
MCX_LOG_AGGR | MCX_LOG_MODULE | MCX_LOG_IO | MCX_LOG_GAUGE | MCX_LOG_WARN
; mclxIOsetQMode("MCLXIOVERBOSITY", MCL_APP_VB_YES)
; mclx_app_init(stderr)
; for (opt=opts;opt->anch;opt++)
{ mcxOptAnchor* anch = opt->anch
; switch(anch->id)
{ case MY_OPT_HELP
: case MY_OPT_APROPOS
: mcxOptApropos(stdout, me, syntax, 20, MCX_OPT_DISPLAY_SKIP, options)
; return 0
;
case MY_OPT_VERSION
: app_report_version(me)
; return 0
;
case MY_OPT_SKEW
: skew = atof(opt->val)
; break
;
case MY_OPT_GEN
: template_n_nodes = atoi(opt->val)
; break
;
case MY_OPT_IMX
: mcxIOrenew(xfmx, opt->val, NULL)
; break
;
case MY_OPT_PLUS
: case MY_OPT_WB
: plus = TRUE
; break
;
case MY_OPT_OUT
: mcxIOrenew(xfout, opt->val, NULL)
; break
;
case MY_OPT_E_MAX
: if (!strcmp(opt->val, "copy"))
e_max = -DBL_MAX
; else
e_max = atof(opt->val)
; break
;
case MY_OPT_E_MIN
: e_min = atof(opt->val)
; break
;
case MY_OPT_G_MIN
: g_min = atof(opt->val)
; break
;
case MY_OPT_G_MAX
: g_max = atof(opt->val)
; break
;
case MY_OPT_G_SDEV
: g_sdev = atof(opt->val)
; break
;
case MY_OPT_G_MEAN
: g_mean = atof(opt->val)
; do_gaussian = TRUE
; break
;
case MY_OPT_G_RADIUS
: g_radius = atof(opt->val)
; break
;
case MY_OPT_N_RANGE
: n_range = atof(opt->val)
; break
;
case MY_OPT_N_SDEV
: n_sdev = atof(opt->val)
; break
;
case MY_OPT_N_RADIUS
: radius = atof(opt->val)
; break
;
case MY_OPT_SHUFFLE
: N_shuffle = atoi(opt->val)
; break
;
case MY_OPT_ADD
: N_add = atoi(opt->val)
; break
;
case MY_OPT_REMOVE
: N_remove = atoi(opt->val)
; break
; }
}
/* hitting y% in vi tells me the size of this block */
{ if (template_n_nodes)
mx = mclxAllocZero
( mclvCanonical(NULL, template_n_nodes, 1.0)
, mclvCanonical(NULL, template_n_nodes, 1.0)
)
; else
mx = mclxReadx
( xfmx
, EXIT_ON_FAIL
, MCLX_REQUIRE_GRAPH
)
; mx_diag = mclxDiagValues(mx, MCL_VECTOR_COMPLETE)
; if (N_shuffle)
mclxAdjustLoops(mx, mclxLoopCBremove, NULL)
; else
mclxSelectUpper(mx)
/* ^ apparently we always work on single arc representation (docme andsoon) */
; offsets = mcxAlloc(sizeof offsets[0] * N_COLS(mx), EXIT_ON_FAIL)
; N_edge = 0
; for (i=0;i<N_COLS(mx);i++)
{ offsets[i] = N_edge
; N_edge += mx->cols[i].n_ivps
; }
if (N_edge < N_remove)
{ mcxErr
( me
, "removal count %ld exceeds edge count %ld"
, (long) N_remove
, (long) N_edge
)
; N_remove = N_edge
; }
random_ignore = RAND_MAX - (N_edge ? RAND_MAX % N_edge : 0)
; if (RAND_MAX / 2 < N_edge)
mcxDie(1, me, "graph too large!")
; if (N_shuffle)
{ do_the_shuffle(mx, N_shuffle, offsets, N_edge, random_ignore)
; mx_readd_diagonal(mx, mx_diag)
; mclxWrite(mx, xfout, MCLXIO_VALUE_GETENV, RETURN_ON_FAIL)
; exit(0)
; }
; if (N_remove)
{ dim n_remove = do_remove(mx, N_remove, offsets, N_edge, random_ignore)
/* Need to recompute N_edge and random_ignore.
* NOTE we work with *upper* matrix; this counts graph edges.
*/
; N_edge = mclxNrofEntries(mx) - n_remove
; random_ignore = RAND_MAX - (RAND_MAX % N_COLS(mx))
; }
if (g_mean)
{ if (!g_radius)
{ if (g_sdev)
g_radius = 2 * g_sdev
; mcxWarn(me, "set radius to %.5f\n", g_radius)
; }
}
; if (N_add)
N_edge += do_add
( mx
, N_add , N_edge
, do_gaussian ? &g_mean : NULL, g_radius , g_sdev , g_min , g_max
, skew
, e_min , e_max
)
; if (radius)
{ for (i=0;i<N_COLS(mx);i++)
{ mclp* ivp = mx->cols[i].ivps, *ivpmax = ivp + mx->cols[i].n_ivps
;if(DEBUG)fprintf(stderr, "here %d\n", (int) i)
; while (ivp < ivpmax)
{ double val = ivp->val
; double r = mcxNormalCut(n_range * n_sdev, n_sdev)
; double newval = val + radius * (r / (n_range * n_sdev))
; if (e_min < e_max && newval >= e_min && newval <= e_max)
; ivp->val = newval
; ivp++
; }
}
}
mclxUnary(mx, fltxCopy, NULL) /* remove zeroes */
; mclxAddTranspose(mx, 0.0)
; mx_readd_diagonal(mx, mx_diag)
; if (plus)
mclxbWrite(mx, xfout, RETURN_ON_FAIL)
; else
mclxWrite(mx, xfout, MCLXIO_VALUE_GETENV, RETURN_ON_FAIL)
; }
return 0
; }
static mclx* make_mx_from_pars
( mclxIOstreamer* streamer
, stream_state* iface
, void (*ivpmerge)(void* ivp1, const void* ivp2)
, mcxbits bits
)
{ mclpAR* pars = iface->pars
; long dc_max_seen = iface->map_c->max_seen
; long dr_max_seen = iface->map_r->max_seen
; mclx* mx = NULL
; mclv* domc, *domr
; dim i
; if (bits & MCLXIO_STREAM_235ANY)
{ if (streamer->cmax_235 > 0 && dc_max_seen < streamer->cmax_235 - 1)
dc_max_seen = streamer->cmax_235-1
; }
else if (bits & MCLXIO_STREAM_123)
{ if (streamer->cmax_123 > 0 && dc_max_seen < streamer->cmax_123 - 1)
dc_max_seen = streamer->cmax_123-1
; if (streamer->rmax_123 > 0 && dr_max_seen < streamer->rmax_123 - 1)
dr_max_seen = streamer->rmax_123-1
; }
mcxTell("stream", "maxc=%d maxr=%d", (int) dc_max_seen, (int) dr_max_seen)
; if (iface->pars_n_used != iface->map_c->max_seen+1)
mcxDie
( 1
, module
, "internal discrepancy: n_pars=%lu max_seen+1=%lu"
, (ulong) iface->pars_n_used
, (ulong) (iface->map_c->max_seen+1)
)
; if (dc_max_seen < 0 || dr_max_seen < 0)
{ if (dc_max_seen < -1 || dr_max_seen < -1)
{ mcxErr(module, "bad apples %ld %ld", dc_max_seen, dr_max_seen)
; return NULL
; }
else
mcxTell(module, "no assignments yield void/empty matrix")
; }
/* fixme: with extend and same tab, should still copy.
* then, there are still occasions where one would
* want to go the sparse route
*/
domc = iface->map_c->tab && (iface->bits & MCLXIO_STREAM_CTAB_RO)
? mclvClone(iface->map_c->tab->domain)
: mclvCanonical(NULL, dc_max_seen+1, 1.0)
; domr = iface->map_r->tab && (iface->bits & MCLXIO_STREAM_RTAB_RO)
? mclvClone(iface->map_r->tab->domain)
: mclvCanonical(NULL, dr_max_seen+1, 1.0)
; if (! (mx = mclxAllocZero(domc, domr)))
{ mclvFree(&domc)
; mclvFree(&domr)
; }
else
for (i=0;i<iface->pars_n_used;i++) /* careful with signedness */
{ long d = domc->ivps[i].idx
;if(DEBUG3)fprintf(stderr, "column %d alloc %d\n", (int) d, (int) iface->pars_n_alloc);
; mclvFromPAR(mx->cols+i, pars+d, 0, ivpmerge, NULL)
; }
return mx
; }
