diff options
| author | ziejd2 | 2021-03-02 10:30:31 -0600 |
|---|---|---|
| committer | ziejd2 | 2021-03-02 10:30:31 -0600 |
| commit | b9aab10c79e649bc4f2dcdc719e72a8d65a90234 (patch) | |
| tree | 7d68d62ac0498a9e6f8a5a978243ea7739925087 | |
| parent | a2b306b10fb07f07c63235861ccfe460153e8609 (diff) | |
| download | BNW-b9aab10c79e649bc4f2dcdc719e72a8d65a90234.tar.gz | |
Added var_lib_genenet_bnw
59 files changed, 14544 insertions, 0 deletions
diff --git a/var_lib_genenet_bnw/build.sh b/var_lib_genenet_bnw/build.sh new file mode 100644 index 00000000..7f63840d --- /dev/null +++ b/var_lib_genenet_bnw/build.sh @@ -0,0 +1,9 @@ +#!/bin/bash +gcc ./localscore/network_score.c ./localscore/libRmath.so -lm -o network_score +gcc ./print_structure/structure.c -lm -o structure + +cd ./k-best/src/ +sh buildk_poster.sh + + + diff --git a/var_lib_genenet_bnw/k-best/src/Arguments.h b/var_lib_genenet_bnw/k-best/src/Arguments.h new file mode 100644 index 00000000..574b2bf7 --- /dev/null +++ b/var_lib_genenet_bnw/k-best/src/Arguments.h @@ -0,0 +1,195 @@ +#ifndef ARGUMENTS_H +#define ARGUMENTS_H + +#include<stdio.h> +#include<stdlib.h> + +using namespace std; + +class Arguments { +public: + static char* datafile; + static char* layeringfile; + static char* maxindegree; + static char* model; + static char* task; + static char* maxnumrecords; + + //HR: Add for in_out features + static char* inFeasFileName; + static char* outFeasFileName; + // + + //HR: Add for in_out features + static int option; + // + + //HR: Add for ADtree option + static int ADtree; + // + + //HR: Add for Topk dir option + static char* directoryName; + // + + + + static void init(int argc, char **args){ + for(int i = 1; i < argc; i ++){ + + if(args[i][0]=='-' && args[i][1]=='d' && args[i][2]=='\0'){ + int j = i + 1; + while (j < argc && args[j][0]!='-') { + Arguments::datafile = args[j]; + j ++; + } + } + else if(args[i][0]=='-' && args[i][1]=='l' && args[i][2]=='\0'){ + int j = i + 1; + while (j < argc && args[j][0]!='-') { + Arguments::layeringfile = args[j]; + j ++; + } + } + else if(args[i][0]=='-' && args[i][1]=='m' && args[i][2]=='\0'){ + int j = i + 1; + while (j < argc && args[j][0]!='-') { + Arguments::maxindegree = args[j]; + j ++; + } + } + else if(args[i][0]=='-' && args[i][1]=='u' && args[i][2]=='\0'){ + int j = i + 1; + while (j < argc && args[j][0]!='-') { + Arguments::maxnumrecords = args[j]; + j ++; + } + } + else if(args[i][0]=='-' && args[i][1]=='M' && args[i][2]=='\0'){ + int j = i + 1; + while (j < argc && args[j][0]!='-') { + Arguments::model = args[j]; + j ++; + } + } + else if(args[i][0]=='-' && args[i][1]=='T' && args[i][2]=='\0'){ + int j = i + 1; + while (j < argc && args[j][0]!='-') { + Arguments::task = args[j]; + j ++; + } + } + //HR: Add for in_out feature + else if(args[i][0]=='-' && args[i][1]=='i' && args[i][2]=='n' && args[i][3]=='\0'){ + int j = i + 1; + while (j < argc && args[j][0]!='-') { + Arguments::inFeasFileName = args[j]; + j ++; + } + } + else if(args[i][0]=='-' && args[i][1]=='o' && args[i][2]=='u' && args[i][3]=='t' && args[i][4]=='\0'){ + int j = i + 1; + while (j < argc && args[j][0]!='-') { + Arguments::outFeasFileName = args[j]; + j ++; + } + } + // + //HR: Add for in_out feature + else if(args[i][0]=='-' && args[i][1]=='o' && args[i][2]=='p' && args[i][3]=='t' && args[i][4]=='\0'){ + int j = i + 1; + while (j < argc && args[j][0]!='-') { + Arguments::option = atoi(args[j]); + j ++; + } + } + // + //HR: Add for ADtree feature + else if(args[i][0]=='-' && args[i][1]=='a' && args[i][2]=='d' && args[i][3]=='\0'){ + int j = i + 1; + while (j < argc && args[j][0]!='-') { + Arguments::ADtree = atoi(args[j]); + j ++; + } + } + // + //HR: Add for Topk dir + else if(args[i][0]=='-' && args[i][1]=='d' && args[i][2]=='i' && args[i][3]=='r' && args[i][4]=='\0'){ + int j = i + 1; + while (j < argc && args[j][0]!='-') { + Arguments::directoryName = args[j]; + j++; + } + } + // + } + + print_arguments(stderr); + + } + static void print_arguments(FILE *f){ + fprintf(f, " -d Data file:\n"); + fprintf(f, " %62s\n", Arguments::datafile); + //fprintf(f, " -l Layering file:\n"); + //fprintf(f, " %62s\n", Arguments::layeringfile); + fprintf(f, " -m Maximum indegree:\n"); + fprintf(f, " %62s\n", Arguments::maxindegree); + fprintf(f, " -u Maximum number of data records read:\n"); + fprintf(f, " %62s\n", Arguments::maxnumrecords); + //fprintf(f, " -M Model:\n"); + //fprintf(f, " %62s\n", Arguments::model); + //fprintf(f, " -T Task (Infer=I, Generate=G):\n"); + //fprintf(f, " %62s\n", Arguments::task); + + //HR: Add for in_out + fprintf(f, " -opt Option:\n"); + fprintf(f, " %62d\n", Arguments::option); + if(Arguments::option == 5){ + fprintf(f, " -in In_Feature File:\n"); + fprintf(f, " %62s\n", Arguments::inFeasFileName); + fprintf(f, " -out Out_Feature File:\n"); + fprintf(f, " %62s\n", Arguments::outFeasFileName); + } + // + //HR: Add for ADtree + fprintf(f, " -ad ADtree:\n"); + fprintf(f, " %62d\n", Arguments::ADtree); + // + //HR: Add for Topk dir + fprintf(f, " -dir directory name:\n"); + fprintf(f, " %62s\n", Arguments::directoryName); + // + } +}; + +char* Arguments::datafile = "testdata.dat"; +char* Arguments::layeringfile = "%"; +char* Arguments::maxindegree = "3"; +char* Arguments::model = "M"; +char* Arguments::task = "I"; +char* Arguments::maxnumrecords = "999999"; + + +//HR: For test +//char* Arguments::datafile = "cases/iris.idt"; +//char* Arguments::layeringfile = "%"; +//char* Arguments::maxindegree = "4"; +//char* Arguments::model = "M"; +//char* Arguments::task = "I"; +//char* Arguments::maxnumrecords = "150"; + + +//HR: Add for in_out +char* Arguments::inFeasFileName = "inFeature.txt"; +char* Arguments::outFeasFileName = "outFeature.txt"; +int Arguments::option = 5; + +//HR: Add for ADtree +int Arguments::ADtree = 0; + + +//HR: Add for Topk dir option +char* Arguments::directoryName = "./"; +// + +#endif diff --git a/var_lib_genenet_bnw/k-best/src/Engine.h b/var_lib_genenet_bnw/k-best/src/Engine.h new file mode 100644 index 00000000..2e16a701 --- /dev/null +++ b/var_lib_genenet_bnw/k-best/src/Engine.h @@ -0,0 +1,2278 @@ +#ifndef ENGINE_H +#define ENGINE_H + +#include<stdio.h> +#include<stdlib.h> + +#include"Arguments.h" +#include"Model.h" + +#include <sys/time.h> +#include <time.h> + +#define MARK 9.0e99 + +// Substitutes la += log(1+exp(lb-la)) <=> a = a + b. +#define LOGADD(la,lb) if(la>8e99||lb-la>100) la=lb;else la+=log(1+exp(lb-la)); + +#define LOG_ZERO -1.0e101 + +using namespace std; + +#include"UpdateHR.h" + + + +//---------------- +// Fast Möbius transform routines. +void sub_fumt(int j, int d, int S, int overlap, double *t, double *s, int n, int k){ + if (d < n && overlap < k){ + sub_fumt(j, d+1, S, overlap, t, s, n, k); + + + S |= (1 << d); + overlap += (d >= j+1); + sub_fumt(j, d+1, S, overlap, t, s, n, k); + } + + else{ + //base case: + //since s[S] = MARK initially, and the following 3 cases, s[S] must be assigned some score (neither MARK nor undecided) + s[S] = MARK; + + //jinS: j is in S + int jinS = ((S >> j) & 1); + if (overlap + jinS <= k) s[S] = t[S]; + //if (jinS) LOGADD(s[S], t[S - (1 << j)]); + if (jinS) logAdd_New(s[S], t[S - (1 << j)]); + } +} + +// Fast upward Möbius transform: +// s(S) := \sum_{T \subseteq S : |T| \leq k} t(T). +void fumt(double *t, double *s, int n, int k){ + double *tmp, *sprev = new double[1 << n]; + for (int T = 0; T < (1<<n); T ++) + sprev[T] = t[T]; + for (int j = 0; j < n; j ++){ + //for each j + sub_fumt(j, 0, 0, 0, sprev, s, n, k); + //recyclely use sprev, s + tmp = sprev; + sprev = s; + s = tmp; + } + if (n % 2 == 0){ + for (int S = 0; S < (1<<n); S ++){ + s[S] = sprev[S]; + } + } + else{ + tmp = sprev; + sprev = s; + s = tmp; + } + delete [] sprev; +} +void test_fumt(){ + int n = 4; + double t[16], s[16]; + for (int S = 0; S < 16; S ++){ + t[S] = log(S+1); + } + fumt(t, s, n, 2); + for (int S = 0; S < 16; S ++){ + cerr<<" s["<<S<<"] = "<<exp(s[S])<<endl; + } +} + + +void sub_fdmt(int j, int d, int T, int overlap, double *s, double *t, int n, int k){ + //cerr<<" T = "<<T<<":"; print_set(cerr, T); + //cerr<<" overlap = "<<overlap<<endl; + if (d < n && overlap <= k){ + sub_fdmt(j, d+1, T, overlap, s, t, n, k); + T |= (1 << d); + overlap += (d <= j); + sub_fdmt(j, d+1, T, overlap, s, t, n, k); + } + else if (d == n){ + t[T] = s[T]; + int jinT = ((T >> j) & 1); + //if (jinT == 0) LOGADD(t[T], s[T + (1 << j)]); + if (jinT == 0) logAdd_New(t[T], s[T + (1 << j)]); + if (overlap > k) t[T] = MARK; + } +} +// Fast downward Möbius transform: +// t(T) := \sum_{T \subseteq S} s(S). +void fdmt(double *s, double *t, int n, int k){ + double *tmp, *tprev = new double[1 << n]; + for (int S = 0; S < (1<<n); S ++) tprev[S] = s[S]; + for (int j = 0; j < n; j ++){ + + sub_fdmt(j, 0, 0, 0, tprev, t, n, k); + tmp = t; t = tprev; tprev = tmp; + } + if (n % 2 == 0){ for (int T = 0; T < (1<<n); T ++) t[T] = tprev[T];} + else{ tmp = t; t = tprev; tprev = tmp;} + delete [] tprev; +} + + +void sub_fdmtLogAddComp(int j, int d, int T, int overlap, double *s, double *t, int n, int k){ + //cerr<<" T = "<<T<<":"; print_set(cerr, T); + //cerr<<" overlap = "<<overlap<<endl; + if (d < n && overlap <= k){ + sub_fdmtLogAddComp(j, d+1, T, overlap, s, t, n, k); + T |= (1 << d); + overlap += (d <= j); + sub_fdmtLogAddComp(j, d+1, T, overlap, s, t, n, k); + } + else if (d == n){ + t[T] = s[T]; + int jinT = ((T >> j) & 1); + if (jinT == 0) logAddComp(t[T], s[T + (1 << j)]); + if (overlap > k) t[T] = MARK; + } +} +// Fast downward Möbius transform: +// t(T) := \sum_{T \subseteq S} s(S). +void fdmtLogAddComp(double *s, double *t, int n, int k){ + double *tmp, *tprev = new double[1 << n]; + for (int S = 0; S < (1<<n); S ++) tprev[S] = s[S]; + for (int j = 0; j < n; j ++){ + + sub_fdmtLogAddComp(j, 0, 0, 0, tprev, t, n, k); + tmp = t; t = tprev; tprev = tmp; + } + if (n % 2 == 0){ for (int T = 0; T < (1<<n); T ++) t[T] = tprev[T];} + else{ tmp = t; t = tprev; tprev = tmp;} + delete [] tprev; +} + + +void sub_fdmtNoLog(int j, int d, int T, int overlap, double *s, double *t, int n, int k){ + //cerr<<" T = "<<T<<":"; print_set(cerr, T); + //cerr<<" overlap = "<<overlap<<endl; + if (d < n && overlap <= k){ + sub_fdmtNoLog(j, d+1, T, overlap, s, t, n, k); + T |= (1 << d); + overlap += (d <= j); + sub_fdmtNoLog(j, d+1, T, overlap, s, t, n, k); + } + else if (d == n){ + t[T] = s[T]; + int jinT = ((T >> j) & 1); + //if (jinT == 0) LOGADD(t[T], s[T + (1 << j)]); + //if (jinT == 0) logAdd_New(t[T], s[T + (1 << j)]); + if (jinT == 0) t[T] += s[T + (1 << j)]; + if (overlap > k) t[T] = MARK; + } +} + +// Fast downward Möbius transform: +// t(T) := \sum_{T \subseteq S} s(S). +void fdmtNoLog(double *s, double *t, int n, int k){ + double *tmp, *tprev = new double[1 << n]; + for (int S = 0; S < (1<<n); S ++) tprev[S] = s[S]; + for (int j = 0; j < n; j ++){ + + sub_fdmtNoLog(j, 0, 0, 0, tprev, t, n, k); + tmp = t; t = tprev; tprev = tmp; + } + if (n % 2 == 0){ for (int T = 0; T < (1<<n); T ++) t[T] = tprev[T];} + else{ tmp = t; t = tprev; tprev = tmp;} + delete [] tprev; +} + + +void test_fdmt(){ + int n = 4; + double t[16], s[16]; + for (int S = 0; S < 16; S ++){ + s[S] = log(S+1); + } + fdmt(s, t, n, 3); + for (int T = 0; T < 16; T ++){ + cerr<<" t["<<T<<"] = "<<exp(t[T])<<endl; + } +} + +//---------------- + + + + + + +// NOTE: Engine only calls a veru limited set of interface functions +// implemented in Model. +class Engine { +public: + Engine(){} + ~Engine(){} + + void init(Model *m){ + model = m; + //test(); + + } + void test(){ + vector<int> T; + T.push_back(1); T.push_back(2); + + cerr<<" log p(x_0 | x_1,2): "<<model->log_lcp(0, T)<<endl; + + for (int h = 0; h < model->num_layers(); h ++){ + int *Vh, *Vu, *Vl; + int nh, nu, nl; + model->layer(h, &Vh, &nh); + model->upper_layers(h, &Vu, &nu); + model->lower_layers(h, &Vl, &nl); + cerr<<"Layer "<<h<<":"; + cerr<<endl<<" layer: "; + print_nodes(cerr, Vh, nh); + cerr<<endl<<" upper: "; + print_nodes(cerr, Vu, nu); + cerr<<endl<<" lower: "; + print_nodes(cerr, Vl, nl); + cerr<<endl; + } + + //test_fumt(); + test_fdmt(); + exit(1); + + } + // Computes all edge probabilities. + void compute_edge_probabilities(){ +// int l = model->num_layers(); + + //Arguments::option == 0 means the rebel method with new Dirichlet hyper-param (see sub_beta) + if(Arguments::option == 0){ + compute_edge_probabilities(0); + } + //Arguments::option == 1 means the forward method + else if(Arguments::option == 1){ + compute_edge_probabilities_forward(0); + } + //Arguments::option == 2 means the backward method + else if(Arguments::option == 2){ + compute_edge_probabilities_backward(0); + } + //Arguments::option == 3 means the mix method in the UAI paper + else if(Arguments::option == 3){ + compute_edge_probabilities_mixIndegree(0); + //compute_edge_probabilities_mixIndegreeNoLog(0); + } + //Arguments::option == 4 means the computation used in top-k + else if(Arguments::option == 4){ + compute_edge_probabilities_top_k(0); + } + //Arguments::option == 5 means the computation required for in and out features + else if(Arguments::option == 5){ + //For In_Out features + compute_edge_probabilities_in_out_features(0); + } + + + } + // Computes probabilities for edges pointing to the h-th layer. + void compute_edge_probabilities(int h){ + cerr<<"\nREBEL Method:" << endl; + cerr<<" Compute edge probabilities for Layer "<<h<<":"<<endl; + + // Step 1: Compute beta[][]; + // Step 2: Compute alpha[][]; + int *Vh, *Vu; int nh, nu; + model->layer(h, &Vh, &nh); + model->upper_layers(h-1, &Vu, &nu); + + + beta = new double*[nh]; + alpha = new double*[nh]; + + k = model->max_indegree(); + + cerr<<" . "<<nh<<" nodes"<<endl; + + struct timeval startTime; + struct timeval endTime; + struct timezone myTimeZone; + + + double betaTime; + double alphaTime; + double forwardTime; + double backwardTime; + double gammaTime; + + double step2BTime; + + gettimeofday(&startTime, &myTimeZone); + + //If Arguments::ADtree == 1, user wants to use ADtree, then make the whole tree first + if(Arguments::ADtree == 1){ + model->makeADTree(); + } + + for (int j = 0; j < nh; j ++){ + + beta[j] = new double[1 << nh]; + //int i = Vh[j]; + compute_beta(j, Vh, nh, Vu, nu); + + } + + //If Arguments::ADtree == 1, then delete the whole tree + if(Arguments::ADtree == 1){ + model->freeADTree(); + } + + gettimeofday(&endTime, &myTimeZone); + betaTime = (endTime.tv_sec - startTime.tv_sec) + + (endTime.tv_usec - startTime.tv_usec) / 1000000.0 ; + + cerr<<" . Tables beta are now ready."<<endl; + + gettimeofday(&startTime, &myTimeZone); + for (int j = 0; j < nh; j ++){ + + alpha[j] = new double[1 << nh]; + compute_alpha(j, Vh, nh); + + //cerr<<" . Tables beta and alpha computed for node "<<j<<"."<<endl; + + } + gettimeofday(&endTime, &myTimeZone); + alphaTime = (endTime.tv_sec - startTime.tv_sec) + + (endTime.tv_usec - startTime.tv_usec) / 1000000.0 ; + + cerr<<" . Tables alpha are now ready."<<endl; + + + // Step 3: Compute g_forward[]; + gf = new double[1 << nh]; + + gettimeofday(&startTime, &myTimeZone); + + compute_g_forward(nh); + + gettimeofday(&endTime, &myTimeZone); + forwardTime = (endTime.tv_sec - startTime.tv_sec) + + (endTime.tv_usec - startTime.tv_usec) / 1000000.0 ; + + //cerr<<" . gf[all] = "<<gf[(1<<nh)-1]<<endl; + + // Step 4: Compute g_backward[]; + + gb = new double[1 << nh]; + + gettimeofday(&startTime, &myTimeZone); + + compute_g_backward(nh); + + gettimeofday(&endTime, &myTimeZone); + backwardTime = (endTime.tv_sec - startTime.tv_sec) + + (endTime.tv_usec - startTime.tv_usec) / 1000000.0 ; + + //cerr<<" . gb[all] = "<<gb[(1<<nh)-1]<<endl; + + // Step 5: Loop over end-point nodes j. + + gammaTime = 0.0; + step2BTime = 0.0; + + double *gamma = new double[1 << nh]; + double *gfb = new double[1 << nh]; + for (int j = 0; j < nh; j ++){ + // Compute gfb[]. + + //start counting gammaTime for each j + gettimeofday(&startTime, &myTimeZone); + + for (int S = 0; S < (1<<nh); S ++){ + + //if j \in the binary repre of S + if ((S>>j) & 1){ + gfb[S] = -MARK; + } + else{ + int cS = (1 << nh) - 1 - S - (1 << j); + gfb[S] = gf[S] + gb[cS]; + //cerr<<" j = "<<j<<": "; + //print_set(cerr, S); + //cerr<<"; "; + //print_set(cerr, cS); + //cerr<<": "<<gfb[S]; + //cerr<<endl; + } + } + // Compute gamma_j() := gamma[]. + fdmt(gfb, gamma, nh, k); + + gettimeofday(&endTime, &myTimeZone); + gammaTime += (endTime.tv_sec - startTime.tv_sec) + + (endTime.tv_usec - startTime.tv_usec) / 1000000.0 ; + //end counting gammaTime for each j + + //cerr<<" gamma[0]: "<<gamma[0]<<endl; + //cerr<<" gfb[0]: "<<gfb[0]<<endl; + + cerr<<" . Incoming edges for node "<<j<<":"; + // Loop over start-point nodes i. + + //start counting step2BTime for each j + gettimeofday(&startTime, &myTimeZone); + + for (int i = 0; i < nh; i ++){ + if (i == j) continue; + cerr<<" "<<i; + double log_prob = eval_edge(i, j, gamma, beta[j], nh, k); + + model->print_edge_prob( + cout, Vh[i], Vh[j], exp(log_prob - gb[(1<<nh)-1])); //HR: - gb[(1<<nh)-1] mean /L(v) + + } + gettimeofday(&endTime, &myTimeZone); + step2BTime += (endTime.tv_sec - startTime.tv_sec) + + (endTime.tv_usec - startTime.tv_usec) / 1000000.0 ; + //end counting step2BTime for each j + + + + cerr<<endl; + + } + + + cout << "\n\n\nTime Statistics" << endl; + cout << "betaTime = " << betaTime << endl; + cout << "alphaTime = " << alphaTime << endl; + cout << "forwardTime = " << forwardTime << endl; + cout << "backwardTime = " << backwardTime << endl; + cout << "gammaTime = " << gammaTime << endl; + + cout << "step2BTime = " << step2BTime << endl; + + double totalTime = betaTime + alphaTime + forwardTime + + backwardTime + gammaTime + step2BTime; + cout << "totalTime = " << totalTime << endl; + + /* + ofResult << "\n\n\nTime Statistics" << endl; + ofResult << "betaTime = " << betaTime << endl; + ofResult << "alphaTime = " << alphaTime << endl; + ofResult << "RRFuncTime = " << RRFuncTime << endl; + ofResult << "HFuncTime = " << HFuncTime << endl; + ofResult << "KFuncTime = " << KFuncTime << endl; + + ofResult << "GammaTime = " << GammaTime << endl; + ofResult << "step2Time = " << step2Time << endl; + double totalTime = betaTime + alphaTime + RRFuncTime + + HFuncTime + KFuncTime + GammaTime + step2Time; + ofResult << "totalTime = " << totalTime << endl; + */ + + + delete [] gamma; + delete [] gfb; + + delete [] gf; delete [] gb; + for (int j = 0; j < nh; j ++){ + delete [] beta[j]; delete [] alpha[j]; + } + delete [] beta; delete [] alpha; + cerr<<" Edge probabilities now computed."<<endl; + } + + + void compute_edge_probabilities_ind(int h){ + cerr<<"\nREBEL Method with each individual edge:" << endl; + cerr<<" Compute edge probabilities for Layer "<<h<<":"<<endl; + + // Step 1: Compute beta[][]; + // Step 2: Compute alpha[][]; + int *Vh, *Vu; int nh, nu; + model->layer(h, &Vh, &nh); + model->upper_layers(h-1, &Vu, &nu); + + beta = new double*[nh]; + alpha = new double*[nh]; + + betaNume = new double*[nh]; + alphaNume = new double*[nh]; + + k = model->max_indegree(); + + cerr<<" . "<<nh<<" nodes"<<endl; + + for (int j = 0; j < nh; j ++){ + + beta[j] = new double[1 << nh]; + + //int i = Vh[j]; + compute_beta(j, Vh, nh, Vu, nu); + + alpha[j] = new double[1 << nh]; + compute_alpha(j, Vh, nh); + + //alphaNume[j] = new double[1 << nh]; + //compute_alphaNume(j, Vh, nh); + + cerr<<" . Tables beta and alpha computed for node "<<j<<"."<<endl; + + } + + for(int uu = 0; uu < nh; uu++){ + for(int vv = 0; vv < nh; vv++){ + if(vv != uu){ + + cerr<<" Compute edge ("<< uu <<"<-" << vv <<")" <<endl; + + for (int j = 0; j < nh; j ++){ + betaNume[j] = new double[1 << nh]; + compute_betaNume(j, Vh, nh, Vu, nu, uu, vv); + + alphaNume[j] = new double[1 << nh]; + compute_alphaNume(j, Vh, nh); + + cerr<<" . Tables betaNume and alphaNume computed for node "<<j<<"."<<endl; + + } + + cerr<<" . Tables beta/betaNume and alpha/alphaNume are now ready."<<endl; + + + // Step 3: Compute g_forward[]; + gf = new double[1 << nh]; + + compute_g_forward(nh); + + gfNume = new double[1 << nh]; + compute_gNume_forward(nh); + + cerr << "\nalpha" << endl; + for (int j = 0; j < nh; j ++){ + for(int index=0; index < (1 << nh); index++){ + cerr<< "alpha[" << j << "][" << index << "] =" << alpha[j][index] << endl; + } + } + + cerr << "\nalphaNume" << endl; + for (int j = 0; j < nh; j ++){ + for(int index=0; index < (1 << nh); index++){ + cerr<< "alphaNume[" << j << "][" << index << "] =" << alphaNume[j][index] << endl; + } + } + + cerr << "\ngf:" << endl; + for(int index = 0; index < (1 << nh); index++){ + cerr << "gf[" << index << "] = " << gf[index] << endl; + } + + cerr << "\ngfNume:" << endl; + for(int index = 0; index < (1 << nh); index++){ + cerr << "gfNume[" << index << "] = " << gfNume[index] << endl; + } + + cerr<<"gf[all] = "<<gf[(1<<nh)-1]<<endl; + cerr<<"gfNume[all] = "<<gfNume[(1<<nh)-1]<<endl; + + //For checking: Compute g_backward[]; + + gb = new double[1 << nh]; + compute_g_backward(nh); + cerr<<" gb[all] = "<<gb[(1<<nh)-1]<<endl; + + cerr<<" . Incoming edges from node " << vv << " to node " << uu <<" :"; + model->print_edge_prob(cout, Vh[vv], Vh[uu], exp(gfNume[(1<<nh)-1] - gf[(1<<nh)-1])); //HR: - gb[(1<<nh)-1] mean /L(v) + cerr<<endl; + + } + } + } + + delete [] gf; + delete [] gfNume; + for (int j = 0; j < nh; j ++){ + delete [] beta[j]; + delete [] betaNume[j]; + delete [] alpha[j]; + delete [] alphaNume[j]; + } + delete [] beta; + delete [] betaNume; + delete [] alpha; + delete [] alphaNume; + + cerr<<" Edge probabilities now computed."<<endl; + + return; + + + + } + + + //HR: new forward method, compute for each individual edge + void compute_edge_probabilities_forward(int h){ + cerr<<"Forward method: " << endl; + cerr<<" Compute edge probabilities for Layer "<<h<<":"<<endl; + + // Step 1: Compute beta[][]; + // Step 2: Compute alpha[][]; + int *Vh, *Vu; int nh, nu; + model->layer(h, &Vh, &nh); + model->upper_layers(h-1, &Vu, &nu); + + //If Arguments::ADtree == 1, user wants to use ADtree, then make the whole tree first + if(Arguments::ADtree == 1){ + model->makeADTree(); + } + + + beta = new double*[nh]; + alpha = new double*[nh]; + + betaNume = new double*[nh]; + alphaNume = new double*[nh]; + + k = model->max_indegree(); + + cerr<<" . "<<nh<<" nodes"<<endl; + + for (int j = 0; j < nh; j ++){ + + beta[j] = new double[1 << nh]; + + //int i = Vh[j]; + compute_beta(j, Vh, nh, Vu, nu); + + alpha[j] = new double[1 << nh]; + compute_alpha(j, Vh, nh); + + cerr<<" . Tables beta and alpha computed for node "<<j<<"."<<endl; + + } + + hFunc = new double[1 << nh]; + compute_h_Fast(nh, hFunc, alpha); + cerr<<"hFunc[all] = "<<hFunc[(1<<nh)-1]<<endl; + + + for(int uu = 0; uu < nh; uu++){ + for(int vv = 0; vv < nh; vv++){ + if(vv != uu){ + + cerr<<"Compute edge ("<< uu <<"<-" << vv <<")" <<endl; + + for (int j = 0; j < nh; j ++){ + betaNume[j] = new double[1 << nh]; + + compute_betaNume(j, Vh, nh, Vu, nu, uu, vv); + + alphaNume[j] = new double[1 << nh]; + compute_alphaNume(j, Vh, nh); + + //cerr<<" . Tables betaNume and alphaNume computed for node "<<j<<"."<<endl; + + } + + + cerr<<" . Tables beta/betaNume and alpha/alphaNume are now ready."<<endl; + + + hFuncNume = new double[1 << nh]; + compute_h_Fast(nh, hFuncNume, alphaNume); + + cerr<<"hFunc[all] = "<<hFunc[(1<<nh)-1]<<endl; + cerr<<"hFuncNume[all] = "<<hFuncNume[(1<<nh)-1]<<endl; + + cerr<<" . Incoming edges from node " << vv << " to node " << uu <<" :"; + model->print_edge_prob(cout, Vh[vv], Vh[uu], exp(hFuncNume[(1<<nh)-1] - hFunc[(1<<nh)-1])); //HR: - gb[(1<<nh)-1] mean /L(v) + cerr<<endl; + + } + } + } + + + //If Arguments::ADtree == 1, then delete the whole tree + if(Arguments::ADtree == 1){ + model->freeADTree(); + } + + delete [] hFunc; + + //it better to move the following line inside the double for loop + delete [] hFuncNume; + + for (int j = 0; j < nh; j ++){ + delete [] beta[j]; + delete [] betaNume[j]; + delete [] alpha[j]; + delete [] alphaNume[j]; + } + delete [] beta; + delete [] betaNume; + delete [] alpha; + delete [] alphaNume; + cerr<<" Edge probabilities now computed."<<endl; + + return; + + + + } + + + //HR: new backward method, compute for each individual edge + void compute_edge_probabilities_backward(int h){ + cerr<<"Backward method: " << endl; + cerr<<" Compute edge probabilities for Layer "<<h<<":"<<endl; + + // Step 1: Compute beta[][]; + // Step 2: Compute alpha[][]; + int *Vh, *Vu; int nh, nu; + model->layer(h, &Vh, &nh); + model->upper_layers(h-1, &Vu, &nu); + + //If Arguments::ADtree == 1, user wants to use ADtree, then make the whole tree first + if(Arguments::ADtree == 1){ + model->makeADTree(); + } + + beta = new double*[nh]; + alpha = new double*[nh]; + + betaNume = new double*[nh]; + alphaNume = new double*[nh]; + + k = model->max_indegree(); + + cerr<<" . "<<nh<<" nodes"<<endl; + + for (int j = 0; j < nh; j ++){ + + beta[j] = new double[1 << nh]; + + compute_beta(j, Vh, nh, Vu, nu); + + alpha[j] = new double[1 << nh]; + compute_alpha(j, Vh, nh); + + cerr<<" . Tables beta and alpha computed for node "<<j<<"."<<endl; + + } + + RRFunc = new double[1 << nh]; + compute_RR_Fast(nh, RRFunc, alpha); + cerr<<"RRFunc[all] = "<<RRFunc[(1<<nh)-1]<<endl; + + + //int uu; + //int vv; + //uu = 2; + //vv = 1; + for(int uu = 0; uu < nh; uu++){ + for(int vv = 0; vv < nh; vv++){ + if(vv != uu){ + + cerr<<"Compute edge ("<< uu <<"<-" << vv <<")" <<endl; + + for (int j = 0; j < nh; j ++){ + + betaNume[j] = new double[1 << nh]; + compute_betaNume(j, Vh, nh, Vu, nu, uu, vv); + + alphaNume[j] = new double[1 << nh]; + compute_alphaNume(j, Vh, nh); + + cerr<<" . Tables betaNume and alphaNume computed for node "<<j<<"."<<endl; + + } + + cerr<<" . Tables beta/betaNume and alpha/alphaNume are now ready."<<endl; + + RRFuncNume = new double[1 << nh]; + compute_RR_Fast(nh, RRFuncNume, alphaNume); + + cerr<<"RRFunc[all] = "<<RRFunc[(1<<nh)-1]<<endl; + cerr<<"RRFuncNume[all] = "<<RRFuncNume[(1<<nh)-1]<<endl; + + cerr<<" . Incoming edges from node " << vv << " to node " << uu <<" :"; + model->print_edge_prob(cout, Vh[vv], Vh[uu], exp(RRFuncNume[(1<<nh)-1] - RRFunc[(1<<nh)-1])); //HR: - gb[(1<<nh)-1] mean /L(v) + cerr<<endl; + + } + } + } + + //If Arguments::ADtree == 1, then delete the whole tree + if(Arguments::ADtree == 1){ + model->freeADTree(); + } + + delete [] RRFunc; + + //it better to move the following line inside the double for loop + delete [] RRFuncNume; + + for (int j = 0; j < nh; j ++){ + delete [] beta[j]; + delete [] betaNume[j]; + delete [] alpha[j]; + delete [] alphaNume[j]; + } + delete [] beta; + delete [] betaNume; + delete [] alpha; + delete [] alphaNume; + cerr<<" Edge probabilities now computed."<<endl; + + return; + + + + } + + + void compute_edge_probabilities_in_out_features(int h){ + cerr<<"Backward method for in and out features: " << endl; + //cerr<<" Compute poster probabilities for Layer "<<h<<":"<<endl; + + // Step 1: Compute beta[][]; + // Step 2: Compute alpha[][]; + int *Vh, *Vu; int nh, nu; + model->layer(h, &Vh, &nh); + model->upper_layers(h-1, &Vu, &nu); + + beta = new double*[nh]; + alpha = new double*[nh]; + + betaInOut = new double*[nh]; + alphaInOut = new double*[nh]; + + k = model->max_indegree(); + + cerr<<" . "<<nh<<" nodes"<<endl; + + //If Arguments::ADtree == 1, user wants to use ADtree, then make the whole tree first + if(Arguments::ADtree == 1){ + model->makeADTree(); + } + + for (int j = 0; j < nh; j ++){ + + beta[j] = new double[1 << nh]; + compute_beta(j, Vh, nh, Vu, nu); + + alpha[j] = new double[1 << nh]; + compute_alpha(j, Vh, nh); + + cerr<<" . Tables beta and alpha computed for node "<<j<<"."<<endl; + + } + + + inFeatureEdges = new int[nh]; + outFeatureEdges = new int[nh]; + //cerr << "call: getInOutFeatures(" << nh << ")" << endl; + getInOutFeatures(nh); + //cerr << "return: getInOutFeatures()" << endl; + +// for(int i = 0; i < nh; i++){ +// cerr << "inFeatureEdges[" << i << "] = " << inFeatureEdges[i] << endl; +// } +// for(int i = 0; i < nh; i++){ +// cerr << "outFeatureEdges[" << i << "] = " << outFeatureEdges[i] << endl; +// } + + for (int j = 0; j < nh; j ++){ + //cerr<<"\nj = " << j << endl; + betaInOut[j] = new double[1 << nh]; + compute_betaInOut(j, Vh, nh, Vu, nu); + + alphaInOut[j] = new double[1 << nh]; + compute_alphaInOut(j, Vh, nh); + + cerr<<" . Tables betaInOut and alphaInOut computed for node "<<j<<"."<<endl; + + } + + cerr<<" Tables beta/betaInOut and alpha/alphaInOut are now ready."<<endl; + + cerr << " Compute the postier probability for the specified In-Out features:" << endl; + RRFunc = new double[1 << nh]; + compute_RR_Fast(nh, RRFunc, alpha); + //compute_h_Fast(nh, RRFunc, alpha); //To confirm that the result is the same for forward and backward + + RRFuncInOut = new double[1 << nh]; + compute_RR_Fast(nh, RRFuncInOut, alphaInOut); + //compute_h_Fast(nh, RRFuncInOut, alphaInOut); //To confirm that the result is the same for forward and backward + + cerr<<"RRFunc[all] = "<<RRFunc[(1<<nh)-1]<<endl; + cerr<<"RRFuncInOut[all] = "<<RRFuncInOut[(1<<nh)-1]<<endl; + + //cerr<<" . Incoming edges from node " << vv << " to node " << uu <<" :"; + //model->print_edge_prob(cout, Vh[vv], Vh[uu], exp(RRFuncNume[(1<<nh)-1] - RRFunc[(1<<nh)-1])); //HR: - gb[(1<<nh)-1] mean /L(v) + cerr << "\nThe postier probability for the specified In-Out features: " << exp(RRFuncInOut[(1<<nh)-1] - RRFunc[(1<<nh)-1]); + cerr<<endl; + + cout << "The postier probability for the specified In-Out features: " << exp(RRFuncInOut[(1<<nh)-1] - RRFunc[(1<<nh)-1]); + cout<<endl; + + //If Arguments::ADtree == 1, then delete the whole tree + if(Arguments::ADtree == 1){ + model->freeADTree(); + } + + delete [] RRFunc; + delete [] RRFuncInOut; + + + delete [] inFeatureEdges; + delete [] outFeatureEdges; + + for (int j = 0; j < nh; j ++){ + delete [] beta[j]; + delete [] betaInOut[j]; + delete [] alpha[j]; + delete [] alphaInOut[j]; + } + delete [] beta; + delete [] betaInOut; + delete [] alpha; + delete [] alphaInOut; + cerr<<" Poster probabilities now computed."<<endl; + + return; + + + } + + + void compute_edge_probabilities_top_k(int h){ + cerr<<"For top-k: compute p(D): " << endl; + cerr<<" Compute edge probabilities for Layer "<<h<<":"<<endl; + + // Step 1: Compute beta[][]; + // Step 2: Compute alpha[][]; + int *Vh, *Vu; int nh, nu; + model->layer(h, &Vh, &nh); + model->upper_layers(h-1, &Vu, &nu); + + + beta = new double*[nh]; + alpha = new double*[nh]; + + //betaNume = new double*[nh]; + //alphaNume = new double*[nh]; + + k = model->max_indegree(); + + cerr<<" . "<<nh<<" nodes"<<endl; + + //If Arguments::ADtree == 1, user wants to use ADtree, then make the whole tree first + if(Arguments::ADtree == 1){ + model->makeADTree(); + } + + for (int j = 0; j < nh; j ++){ + + beta[j] = new double[1 << nh]; + + //cerr<<" Start compute_beta for node "<<j<<"."<<endl; + compute_beta(j, Vh, nh, Vu, nu); + //cerr<<" Tables beta computed for node "<<j<<"."<<endl; + + alpha[j] = new double[1 << nh]; + compute_alpha(j, Vh, nh); + + cerr<<" . Tables beta and alpha computed for node "<<j<<"."<<endl; + + } + + //If Arguments::ADtree == 1, then delete the whole tree + if(Arguments::ADtree == 1){ + model->freeADTree(); + } + + RRFunc = new double[1 << nh]; + + cerr<<"\n Compute_RR_Fast(): "<<endl; + compute_RR_Fast(nh, RRFunc, alpha); + cerr<<"\n RRFunc[all] = "<<RRFunc[(1<<nh)-1]<<endl <<endl; + cout<<"\n RRFunc[all] = "<<RRFunc[(1<<nh)-1]<<endl <<endl; + + fprintf(stderr, "RRFunc[all] = %18.8f\n", RRFunc[(1<<nh)-1]); + + //write to + FILE * fp_PD = fopen("exactPD.txt", "a"); + if(fp_PD){ + fprintf(fp_PD, "%18.8f\n", RRFunc[(1<<nh)-1]); + fclose(fp_PD); + + } + else{ + cerr <<"fopen exactPD.txt fails" << endl; + + } + + + delete [] RRFunc; + //delete [] RRFuncNume; + + for (int j = 0; j < nh; j ++){ + delete [] beta[j]; + //delete [] betaNume[j]; + delete [] alpha[j]; + //delete [] alphaNume[j]; + } + delete [] beta; + //delete [] betaNume; + delete [] alpha; + //delete [] alphaNume; + //cerr<<" Edge probabilities now computed."<<endl; + + return; + + } + + + //HR: new mix with max in-degree method, + void compute_edge_probabilities_mixIndegree(int h){ + cerr<<" Mix with max in-degree method: " << endl; + //cerr<<" Compute edge probabilities for Layer "<<h<<":"<<endl; + + // Step 1: Compute beta[][]; + // Step 2: Compute alpha[][]; + int *Vh, *Vu; int nh, nu; + model->layer(h, &Vh, &nh); + model->upper_layers(h-1, &Vu, &nu); + + //Step 1(a) (b) + + beta = new double*[nh]; + alpha = new double*[nh]; + + k = model->max_indegree(); + + cerr<<" . "<<nh<<" nodes"<<endl; + + struct timeval startTime; + struct timeval endTime; + struct timezone myTimeZone; + + double betaTime; + double alphaTime; + double RRFuncTime; + double HFuncTime; + double KFuncTime; + double GammaTime; + + double step2Time; + + + //Step 1(a) + + gettimeofday(&startTime, &myTimeZone); + + //If Arguments::ADtree == 1, user wants to use ADtree, then make the whole tree first + if(Arguments::ADtree == 1){ + //cout << "Arguments::ADtree == 1" << endl; + model->makeADTree(); + } + else{ + //cout << "Arguments::ADtree == 0" << endl; + } + + for (int j = 0; j < nh; j ++){ + beta[j] = new double[1 << nh]; + + //int i = Vh[j]; + compute_beta(j, Vh, nh, Vu, nu); + + //cerr<<" . Tables beta and alpha computed for node "<<j<<"."<<endl; + + } + + //If Arguments::ADtree == 1, then delete the whole tree + if(Arguments::ADtree == 1){ + model->freeADTree(); + } + + gettimeofday(&endTime, &myTimeZone); + betaTime = (endTime.tv_sec - startTime.tv_sec) + + (endTime.tv_usec - startTime.tv_usec) / 1000000.0 ; + + cerr<<" . Tables beta have been computed" << endl; + + + //HR: Add for Top-k inside void compute_edge_probabilities_mixIndegree(int h) + //HR: Use the Poster tool to compute the local scores for all the families of each variable (without max-indegree + // restriction). So for each of n variables, there are 2^(n-1) family scores. + write_family_scores_to_files(nh); + + + //step 1(b) + gettimeofday(&startTime, &myTimeZone); + for (int j = 0; j < nh; j ++){ + + alpha[j] = new double[1 << nh]; + compute_alpha(j, Vh, nh); + + //cerr<<" . Tables beta and alpha computed for node "<<j<<"."<<endl; + + } + gettimeofday(&endTime, &myTimeZone); + alphaTime = (endTime.tv_sec - startTime.tv_sec) + + (endTime.tv_usec - startTime.tv_usec) / 1000000.0 ; + + + cerr<<" . Tables alpha has been computed" << endl; + + + //Step 1(c) + //HR: backward method to compute: for all S \subset V RR(S) + RRFunc = new double[1 << nh]; + + cerr<<" . To compute Table RR" << endl; + + gettimeofday(&startTime, &myTimeZone); + + compute_RR_Fast(nh, RRFunc, alpha); + //compute_RR_Iter(nh, RRFunc, alpha); + + gettimeofday(&endTime, &myTimeZone); + RRFuncTime = (endTime.tv_sec - startTime.tv_sec) + + (endTime.tv_usec - startTime.tv_usec) / 1000000.0 ; + + //cerr<<"RRFunc[all] = "<<RRFunc[(1<<nh)-1]<<endl; + //fprintf(stderr, "RRFunc[all] = %18.8f\n", RRFunc[(1<<nh)-1]); + cerr<<" . Table RR computed." <<endl; + + + //HR: merge the function of opt 4 into here. + //write to exactPD.txt + //string directory_name = "./family_scores"; + string str; + str.assign(Arguments::directoryName); + str.append("/"); + str.append("exactPD.txt"); + + //FILE * fp_PD = fopen(str.c_str(), "a"); + FILE * fp_PD = fopen(str.c_str(), "w"); + if(fp_PD){ + fprintf(fp_PD, "%18.8f\n", RRFunc[(1<<nh)-1]); + fclose(fp_PD); + + } + else{ + cerr <<"fopen exactPD.txt fails" << endl; + + } + + + //Step 1(d) + //HR: forward method to compute: for all S \subset V H(S) + + hFunc = new double[1 << nh]; + + cerr<<" . To compute Table H" << endl; + + gettimeofday(&startTime, &myTimeZone); + + compute_h_Fast(nh, hFunc, alpha); + //compute_h_Iter(nh, hFunc, alpha); + + gettimeofday(&endTime, &myTimeZone); + HFuncTime = (endTime.tv_sec - startTime.tv_sec) + + (endTime.tv_usec - startTime.tv_usec) / 1000000.0 ; + + + //cerr<<"hFunc[all] = "<<hFunc[(1<<nh)-1]<<endl; + //fprintf(stderr, "hFunc[all] = %18.8f\n", hFunc[(1<<nh)-1]); + cerr<<" . Table H computed" <<endl; + + + //Step 1 (e) + KFunc = new double*[nh]; + cerr<<" . To compute Table K" << endl; + + gettimeofday(&startTime, &myTimeZone); + for(int i = 0; i < nh; i++){ + //cerr<<" For v = " << i << endl; + KFunc[i] = new double [1<<nh]; + compute_all_K_v(nh, KFunc[i], i, alpha); + + } + + gettimeofday(&endTime, &myTimeZone); + KFuncTime = (endTime.tv_sec - startTime.tv_sec) + + (endTime.tv_usec - startTime.tv_usec) / 1000000.0 ; + + + cerr<<" . Table K computed" <<endl; + + + // Step 1 (f): For all i \in V, for all Pa_i \subset V - {i} with |Pa_i| <= k, compute Gamma_i(Pa_i) + + double * Gamma = new double[1 << nh]; + double * Gfb = new double[1 << nh]; + + GammaTime = 0.0; + step2Time = 0.0; + + for (int v = 0; v < nh; v++){ + //cerr<<" For v = " << v <<": " << endl; + + //start counting the GammaTime for each v + gettimeofday(&startTime, &myTimeZone); + + // Compute Gfb[]. + for (int U = 0; U < (1<<nh); U++){ + //if v \in the binary repre of U + if ((U>>v) & 1){ + Gfb[U] = LOG_ZERO; + } + else{ + + //Gfb[U] = hFunc[U] + KFunc[v][U]; + if(KFunc[v][U] == LOG_ZERO){ + Gfb[U] = LOG_ZERO; + } + //note that KFunc[v][U] == 0 is possible + else if(KFunc[v][U] <= 0){ + Gfb[U] = hFunc[U] + KFunc[v][U]; + } + else{ + //Now if Gfb[U] > 0, then Gfb[U] + + Gfb[U] = -(hFunc[U] - KFunc[v][U]); + } + + //cerr<<" j = "<<j<<": "; + //print_set(cerr, S); + //cerr<<"; "; + //print_set(cerr, cS); + //cerr<<": "<<gfb[S]; + //cerr<<endl; + } + } + + //cerr<< "Table Gfb has been computed" << endl; + + // Compute gamma_j() := gamma[]. + + fdmtLogAddComp(Gfb, Gamma, nh, k); + + gettimeofday(&endTime, &myTimeZone); + //end counting GammaTime for each v + GammaTime += (endTime.tv_sec - startTime.tv_sec) + + (endTime.tv_usec - startTime.tv_usec) / 1000000.0 ; + + + //cerr<< "Table Gamma has been computed" << endl; + + //cerr<< " Gfb[0]: " <<Gfb[0]<<endl; + //cerr<< " Gamma[0]: " << Gamma[0]<<endl; + + + //Step 2 + //cerr<<" . Incoming edges for node "<< v <<":"; + // Loop over start-point nodes i. + + //start counting step2Time for each v + gettimeofday(&startTime, &myTimeZone); + + for (int i = 0; i < nh; i++){ + if (i == v) continue; + //cerr<<" "<< i; + double log_prob_nume = eval_edge_mixIndegree(i, v, Gamma, beta[v], nh, k); + + model->print_edge_prob( + cout, Vh[i], Vh[v], exp(log_prob_nume - RRFunc[(1<<nh)-1])); //HR: - gb[(1<<nh)-1] mean /L(v) + + } + + + gettimeofday(&endTime, &myTimeZone); + //end counting step2Time for each v + step2Time += (endTime.tv_sec - startTime.tv_sec) + + (endTime.tv_usec - startTime.tv_usec) / 1000000.0 ; + + //cerr<<endl; + + } + + +// cout << "\n\n\nTime Statistics" << endl; +// cout << "betaTime = " << betaTime << endl; +// cout << "alphaTime = " << alphaTime << endl; +// cout << "RRFuncTime = " << RRFuncTime << endl; +// cout << "HFuncTime = " << HFuncTime << endl; +// cout << "KFuncTime = " << KFuncTime << endl; +// +// cout << "GammaTime = " << GammaTime << endl; +// cout << "step2Time = " << step2Time << endl; +// double totalTime = betaTime + alphaTime + RRFuncTime +// + HFuncTime + KFuncTime + GammaTime + step2Time; +// cout << "totalTime = " << totalTime << endl; + + + delete [] Gamma; + delete [] Gfb; + + delete [] hFunc; + + delete [] RRFunc; + + delete [] Eta_U; + + for (int j = 0; j < nh; j ++){ + delete [] beta[j]; + delete [] alpha[j]; + + delete [] KFunc[j]; + + } + delete [] beta; + delete [] alpha; + + delete [] KFunc; + + + cerr<<" Edge probabilities now computed."<<endl; + + return; + + } + //HR: end mixIndegree + + + void compute_edge_probabilities_mixIndegreeNoLog(int h){ + cerr<<"Mix with max in-degree method: " << endl; + cerr<<" Compute edge probabilities for Layer "<<h<<":"<<endl; + + + // Step 1: Compute beta[][]; + // Step 2: Compute alpha[][]; + int *Vh, *Vu; int nh, nu; + model->layer(h, &Vh, &nh); + model->upper_layers(h-1, &Vu, &nu); + + //Step 1(a) (b) + + beta = new double*[nh]; + alpha = new double*[nh]; + + k = model->max_indegree(); + + cerr<<" . "<<nh<<" nodes"<<endl; + + for (int j = 0; j < nh; j ++){ + + beta[j] = new double[1 << nh]; + + //int i = Vh[j]; + compute_beta(j, Vh, nh, Vu, nu); + + alpha[j] = new double[1 << nh]; + compute_alpha(j, Vh, nh); + + cerr<<" . Tables beta and alpha computed for node "<<j<<"."<<endl; + + } + + + //Step 1(c) + //HR: backward method to compute: for all S \subset V RR(S) + RRFunc = new double[1 << nh]; + + cerr<<" . To compute Table RR" << endl; + + compute_RR_Fast(nh, RRFunc, alpha); + + cerr<<" . Table RR computed." <<endl; + + + //Step 1(d) + //HR: forward method to compute: for all S \subset V H(S) + + hFunc = new double[1 << nh]; + + cerr<<" . To compute Table H" << endl; + + compute_h_Fast(nh, hFunc, alpha); + + cerr<<" . Table H computed" <<endl; + + + //Step 1 (e) + KFunc = new double*[nh]; + cerr<<" . To compute Table K" << endl; + for(int i = 0; i < nh; i++){ + cerr<<" For v = " << i << endl; + KFunc[i] = new double [1<<nh]; + compute_all_K_v(nh, KFunc[i], i, alpha); + + } + cerr<<" . Table K computed" <<endl; + + // Step 2: Loop over end-point nodes v \in V + + //No Log transformation + double * Gamma = new double[1 << nh]; + double * Gfb = new double[1 << nh]; + ofstream ofNoLog("debugEngineNoLog.txt"); + + for (int v = 0; v < nh; v++){ + cerr<<" For v = " << v <<": " << endl; + // Compute Gfb[]. + for (int U = 0; U < (1<<nh); U++){ + //if v \in the binary repre of U + if ((U>>v) & 1){ + //Gfb[U] = LOG_ZERO; + //Gfb[U] = 0; + Gfb[U] = LOG_ZERO;// + } + else{ + //Gfb[U] = hFunc[U] + KFunc[v][U]; + + if(KFunc[v][U] == LOG_ZERO){ + Gfb[U] = exp(hFunc[U]); + } + else if (KFunc[v][U] > 0){ + Gfb[U] = - exp(hFunc[U] - KFunc[v][U]); + + } + else{ + Gfb[U] = exp(hFunc[U] + KFunc[v][U]); + } + // + if(Gfb[U] == 0){ + Gfb[U] = LOG_ZERO; + } + else{ + Gfb[U] = log(Gfb[U]); + } + // + + //cerr<<" j = "<<j<<": "; + //print_set(cerr, S); + //cerr<<"; "; + //print_set(cerr, cS); + //cerr<<": "<<gfb[S]; + //cerr<<endl; + } + } + cerr<< "Table Gfb has been computed" << endl; + + ofNoLog <<"For v = " << v <<": " << endl; + ofNoLog << "\nGfb: " << endl; + for(int index = 0; index < (1 << nh); index++){ + ofNoLog << "Gfb[" << index << " ] =" << Gfb[index] << endl; + } + ofNoLog << endl; + + + // Compute gamma_j() := gamma[]. + //fdmtNoLog(Gfb, Gamma, nh, k); + fdmt(Gfb, Gamma, nh, k); + + cerr<< "Table Gamma has been computed" << endl; + + cerr<< " Gamma[0]: " << Gamma[0]<<endl; + cerr<< " Gfb[0]: " <<Gfb[0]<<endl; + + cerr<<" . Incoming edges for node "<< v <<":"; + // Loop over start-point nodes i. + for (int i = 0; i < nh; i++){ + if (i == v) continue; + cerr<<" "<< i; + double log_prob_nume = eval_edge_mixIndegree(i, v, Gamma, beta[v], nh, k); + + model->print_edge_prob( + cout, Vh[i], Vh[v], exp(log_prob_nume - RRFunc[(1<<nh)-1])); //HR: - gb[(1<<nh)-1] mean /L(v) + + } + cerr<<endl; + + } + + delete [] Gamma; + delete [] Gfb; + + delete [] hFunc; + + delete [] RRFunc; + + delete [] Eta_U; + + for (int j = 0; j < nh; j ++){ + delete [] beta[j]; + delete [] alpha[j]; + + delete [] KFunc[j]; + + } + delete [] beta; + delete [] alpha; + + delete [] KFunc; + + cerr<<" Edge probabilities now computed."<<endl; + + return; + + } + + //HR: end mixIndegreeNoLog + + + // beta[j][T] := sum_W gamma[j][T \cup W] . + void compute_beta(int j, int *Vh, int nh, int *Vu, int nu){ + //cerr<<"Compute beta, j = "<<j<<", i = "<< Vh[j]; + //cerr<<", k = "<<k<<", nh = "<<nh<<":"<<endl; + + sub_init(0, 0, beta[j], MARK, 0, nh); + + //cerr<<" Initialization done."<<endl; + + int *S = new int[k]; + sub_beta(-1, nh, beta[j], 0, S, Vh[j], Vu, nu, 0); + delete [] S; + + }// end void compute_beta() + + + // beta[j][T] := sum_W gamma[j][T \cup W] . + void compute_betaNume(int j, int *Vh, int nh, int *Vu, int nu, int uu, int vv){ + //cerr<<"Compute betaNume, j = "<<j<<", i = "<< Vh[j]; + + sub_init(0, 0, betaNume[j], MARK, 0, nh); + + //cerr<<" Initialization done."<<endl; + + int *S = new int[k]; + + //check whether uu == j + if(uu != j){ + sub_beta(-1, nh, betaNume[j], 0, S, Vh[j], Vu, nu, 0); + } + else{ + //cerr << "uu == j == " << uu << ": so call sub_betaNume()" << endl; + sub_betaNume(-1, nh, betaNume[j], 0, S, Vh[j], Vu, nu, 0, uu, vv); + } + + + + delete [] S; + } + + + void compute_betaInOut(int j, int *Vh, int nh, int *Vu, int nu){ + + //cerr << "call: sub_init(0, 0, betaInOut[j], MARK, 0, nh)" << endl; + sub_init(0, 0, betaInOut[j], MARK, 0, nh); + //cerr << "return: sub_init(0, 0, betaInOut[j], MARK, 0, nh)" << endl; + + //cerr<<" Initialization done."<<endl; + + int *S = new int[k]; + + //cerr << "call: sub_betaInOut()" << endl; + + sub_betaInOut(-1, nh, betaInOut[j], 0, S, Vh[j], Vu, nu, 0); + //sub_beta(-1, nh, betaInOut[j], 0, S, Vh[j], Vu, nu, 0); + + //cerr << "return: sub_betaInOut()" << endl; + + delete [] S; + + }//end of compute_betaInOut() + + + + void sub_beta(int jprev, int nh, double *b, int d, int *S, int i, int *Vu, int nu, int T){ + //cerr<<" S:"; print_nodes(cerr, S, d); + //cerr<<"; T:"; print_nodes(cerr, T, Vu, nu); cerr<<endl; + + + double lb; + if(Arguments::option < 1){ + + //HR: for old prior for q(G_i)and new Dirichlet hyper-param + //used to compare rebel and out method + + //lb = model->log_prior(i, S, d) + model->log_lcpHR(i, S, d); + if(Arguments::ADtree == 0){ + lb = model->log_prior(i, S, d) + model->log_lcpHR(i, S, d); + } + else{ + lb = model->log_prior(i, S, d) + model->log_lcpHR_ADtree(i, S, d); + } + } + else if(Arguments::option >= 1) { + + //lb = 0 + model->log_lcpHR(i, S, d); + if(Arguments::ADtree == 0){ + lb = 0 + model->log_lcpHR(i, S, d); + } + else{ + lb = 0 + model->log_lcpHR_ADtree(i, S, d); + } + } + + //LOGADD(b[T], lb); + logAdd_New(b[T], lb); + // + + if (d < k){ + for (int j = jprev + 1; j < nu; j ++){ + if (Vu[j] != i){ + S[d] = Vu[j]; + + if (j < nh) { + sub_beta(j, nh, b, d+1, S, i, Vu, nu, T | (1 << j)); + } + + else{ + sub_beta(j, nh, b, d+1, S, i, Vu, nu, T); + } + } + } + } + } + + + void sub_betaNume(int jprev, int nh, double *b, int d, int *S, int i, int *Vu, int nu, int T, int uu, int vv){ + //cerr<<" S:"; print_nodes(cerr, S, d); + //cerr<<"; T:"; print_nodes(cerr, T, Vu, nu); cerr<<endl; + int vvInS = 0; + + for(int ind = 0; ind < d; ind++){ + if(vv == S[ind]){ + vvInS = 1; + break; + } + } + + if(vvInS == 1){ + double lb; + if(Arguments::option < 1){ + + //HR: for old prior for q(G_i)and new Dirichlet hyper-param + //used to compare rebel and out method + + //lb = model->log_prior(i, S, d) + model->log_lcpHR(i, S, d); + if(Arguments::ADtree == 0){ + lb = model->log_prior(i, S, d) + model->log_lcpHR(i, S, d); + } + else{ + lb = model->log_prior(i, S, d) + model->log_lcpHR_ADtree(i, S, d); + } + } + else if(Arguments::option >= 1) { + //HR: for 1 prior for q(G_i) and new Dirichlet hyper-param + //lb = 0 + model->log_lcpHR(i, S, d); + if(Arguments::ADtree == 0){ + lb = 0 + model->log_lcpHR(i, S, d); + } + else{ + lb = 0 + model->log_lcpHR_ADtree(i, S, d); + } + + } + + //double lb = model->log_prior(i, S, d) + model->log_lcp(i, S, d); + //double lb = 0 + model->log_lcpHR(i, S, d); + + //LOGADD(b[T], lb); + logAdd_New(b[T], lb); + } + else{ + //how to set? 0-no, MARK-no; log(0) = -inf = LOG_ZERO + //LOGADD(b[T], LOG_ZERO); + double tempLogB = LOG_ZERO; + logAdd_New(b[T], tempLogB); + } + + + + if (d < k){ + for (int j = jprev + 1; j < nu; j ++){ + if (Vu[j] != i){ + S[d] = Vu[j]; + + if (j < nh) { + sub_betaNume(j, nh, b, d+1, S, i, Vu, nu, T | (1 << j), uu, vv); + } + + else{ + sub_betaNume(j, nh, b, d+1, S, i, Vu, nu, T, uu, vv); + } + } + } + } + } + + + + void getInOutFeatures(int no_vars){ + + for(int i = 0; i < no_vars; i++){ + inFeatureEdges[i] = 0; + } + for(int i = 0; i < no_vars; i++){ + outFeatureEdges[i] = 0; + } + + FILE * fpIn = fopen(Arguments::inFeasFileName, "r"); + + int fromNode; + int toNode; + //char c; + //int i=0; + while(!feof(fpIn)){ + + fromNode = -1; + toNode = -1; + //c = -1; + + fscanf(fpIn,"%d->%d\n",&fromNode, &toNode); + + //cout << "fromNode = "<< fromNode << endl; + //cout << "toNode = "<< toNode << endl; + + //To guard against toNode == -1 + if(toNode == -1){ + break; + } + else{ + inFeatureEdges[toNode] += (1 << fromNode); + } + + } + + fclose(fpIn); + +// for(int i = 0; i < no_vars; i++){ +// cout << "inFeatureEdges[" << i << "] " << inFeatureEdges[i] << endl; +// } + + + FILE *fp2 = fopen(Arguments::outFeasFileName, "r"); + + while(!feof(fp2)){ + + fromNode = -1; + toNode = -1; + + fscanf(fp2,"%d->%d\n",&fromNode, &toNode); + + //cout << "fromNode = "<< fromNode << endl; + //cout << "toNode = "<< toNode << endl; + + if(toNode == -1){ + break; + } + else{ + outFeatureEdges[toNode] += (1 << fromNode); + } + + + } + fclose(fp2); + +// for(int i = 0; i < no_vars; i++){ +// cout << "outFeatureEdges[" << i << "] " << outFeatureEdges[i] << endl; +// } + + } //end of getInOutFeatures + + + void sub_betaInOut(int jprev, int nh, double *b, int d, int *S, int i, int *Vu, int nu, int T){ +// cerr<< "Start sub_betaInOut()" << endl; +// cerr<<" S:"; print_nodes(cerr, S, d); +// cerr<<" T: " << T << endl; +// cerr<<" d: " << d << endl; + //cerr<<"; T:"; print_nodes(cerr, T, Vu, nu); cerr<<endl; + + int compBetaNeeded = 0; + + //cerr << "inFeatureEdges[" << i << "] = " << inFeatureEdges[i] << endl; + //cerr << "outFeatureEdges[" << i << "] = " << outFeatureEdges[i] << endl; + + //if (each of inFeatureEdges[i] is in T ) && (none of outFeatureEdges[i] is in T ) + if(((inFeatureEdges[i] & T) == inFeatureEdges[i]) && ((outFeatureEdges[i] & T) == 0) ){ + compBetaNeeded = 1; + //cerr << "inFeatureEdges[" << i << "] = " << inFeatureEdges[i] << endl; + //cerr << "outFeatureEdges[" << i << "] = " << outFeatureEdges[i] << endl; + //cerr << "T = " << T << endl; + //cerr<<" compBetaNeeded = 1;" << endl; + + } + + if(compBetaNeeded == 1){ + double lb; + //Arguments::option must be 5 + if(Arguments::option < 1){ + + //HR: for old prior for q(G_i)and new Dirichlet hyper-param + //used to compare rebel and out method + //lb = model->log_prior(i, S, d) + model->log_lcpHR(i, S, d); + if(Arguments::ADtree == 0){ + lb = model->log_prior(i, S, d) + model->log_lcpHR(i, S, d); + } + else{ + lb = model->log_prior(i, S, d) + model->log_lcpHR_ADtree(i, S, d); + } + } + else if(Arguments::option >= 1) { + //HR: for 1 prior for q(G_i) and new Dirichlet hyper-param + //cerr << "start: double lb = 0 + model->log_lcpHR(i, S, d)" << endl; + //lb = 0 + model->log_lcpHR(i, S, d); + if(Arguments::ADtree == 0){ + lb = 0 + model->log_lcpHR(i, S, d); + } + else{ + lb = 0 + model->log_lcpHR_ADtree(i, S, d); + } + //cerr << "end: double lb = 0 + model->log_lcpHR(i, S, d)" << endl; + } + + + //LOGADD(b[T], lb); + logAdd_New(b[T], lb); + } + else{ + //LOGADD(b[T], LOG_ZERO); + double tempLogB = LOG_ZERO; + logAdd_New(b[T], tempLogB); + } + + if (d < k){ + for (int j = jprev + 1; j < nu; j ++){ + if (Vu[j] != i){ + S[d] = Vu[j]; + + if (j < nh) { + sub_betaInOut(j, nh, b, d+1, S, i, Vu, nu, T | (1 << j)); + } + + else{ + sub_betaInOut(j, nh, b, d+1, S, i, Vu, nu, T); + } + } + } + } + } //end of sub_betaInOut + + + void sub_init(int d, int S, double *a, double value, int ones, int nh){ + //cerr<<" d: "<<d<<endl; + a[S] = value; + + if (d < nh){ + sub_init(d+1, S, a, value, ones, nh); + + if (ones < k) sub_init(d+1, S | (1 << d), a, value, ones+1, nh); + } + } + + //HR: From get_kbest_nets.cc in Top-k + //HR: add v itself into the binary repres, v posi should be 0 + //Convert the parent set to the appropriate variable set + unsigned int parset2varset(int v, unsigned int set) { + unsigned int sinkleton = 1U << v; + unsigned int mask = sinkleton - 1; + unsigned int low = set & mask; + unsigned int high = set & ~mask; + return (high << 1) | low; + } + + + //HR: Add for Top-k inside void compute_edge_probabilities_mixIndegree(int h) + //HR: Use the Poster tool to compute the local scores for all the families of each variable (without max-indegree + // restriction). So for each of n variables, there are 2^(n-1) family scores. + // Then store them as file 0, 1, 2, ..., n-1 for variable 0, 1, ..., n-1. + void write_family_scores_to_files(int nh){ + FILE* fout; + //nh is the number of variables + int num_of_vars = nh; + unsigned int num_of_parsets = 1U << (num_of_vars - 1); + //HR: for each variable + for (int v = 0; v < num_of_vars; v++) { + char str1[40]; + sprintf(str1, "%d", v); + string str; + //string dirname = "./family_scores"; + string dirname = Arguments::directoryName; + str.append(dirname); + str.append("/"); + str.append(str1); + + fout = fopen(str.c_str(), "wb"); + unsigned int new_par_set; + for (unsigned int par_set = 0; par_set < num_of_parsets; par_set++) { + //HR: add v itself into the binary repres, v posi should be 0 + new_par_set = parset2varset(v, par_set); + //This is fine. + //fwrite(beta[v] + new_par_set, sizeof(double), 1, fout); + //This is also fine. + fwrite(&(beta[v][new_par_set]), sizeof(double), 1, fout); + + } + fclose(fout); + + } +// //test +// //HR: for each variable +// FILE* fin; +// for (int v = 0; v < num_of_vars; v++) { +// char str1[40]; +// sprintf(str1, "%d", v); +// string str; +// //string dirname = "./family_scores"; +// string dirname = Arguments::directoryName; +// str.append(dirname); +// str.append("/"); +// str.append(str1); +// +// fin = fopen(str.c_str(), "rb"); +// unsigned int new_par_set; +// for (unsigned int par_set = 0; par_set < num_of_parsets; par_set++) { +// //HR: add v itself into the binary repres, v posi should be 0 +// new_par_set = parset2varset(v, par_set); +// double temp_family_score; +// fread(&temp_family_score, sizeof(double), 1, fin); +// if(temp_family_score != beta[v][new_par_set]){ +// cerr << "temp_family_score = " << temp_family_score << endl; +// cerr << "beta[" << v << "][" << new_par_set << "] = " << beta[v][new_par_set] << endl; +// cerr << "Error: temp_family_score != beta[" +// << v << "][" << new_par_set << "]" << endl; +// exit(1); +// } +// } +// fclose(fin); +// +// } +// // + + }//write_family_scores_to_files(int nh) + + + // alpha[j][S] = sum_T beta[j][T] (...times the prior). + void compute_alpha(int j, int *Vh, int nh){ + // Use fast truncated upward Möbius transform. + fumt(beta[j], alpha[j], nh, k); + } + + + void compute_alphaNume(int j, int *Vh, int nh){ + // Use fast truncated upward Möbius transform. + fumt(betaNume[j], alphaNume[j], nh, k); + } + + + void compute_alphaInOut(int j, int *Vh, int nh){ + // Use fast truncated upward Möbius transform. + fumt(betaInOut[j], alphaInOut[j], nh, k); + } + + + void compute_g_forward(int nh){ + sub_gf(0, nh, 0); + + } + + + void compute_gNume_forward(int nh){ + sub_gfNume(0, nh, 0); + + } + + + void sub_gf(int d, int nh, int S){ + + if (d < nh){ + sub_gf(d+1, nh, S); + sub_gf(d+1, nh, S | (1 << d)); + } + else { + double sum = MARK; + int T = S, J = 1; + + for (int j = 0; j < nh; j ++){ + if (T & 1){ + // Now S - J is a subset of S. + + double w = alpha[j][S - J] + gf[S - J]; + //LOGADD(sum, w); + logAdd_New(sum, w); + } + + T >>= 1; J <<= 1; + } + if (S == 0) + gf[0] = 0; + else + gf[S] = sum; + } + } + + + void sub_gfNume(int d, int nh, int S){ + + if (d < nh){ + sub_gfNume(d+1, nh, S); + sub_gfNume(d+1, nh, S | (1 << d)); + } + else { + double sum = MARK; + int T = S, J = 1; + + for (int j = 0; j < nh; j ++){ + if (T & 1){ + // Now S - J is a subset of S. + + double w = alphaNume[j][S - J] + gfNume[S - J]; + //LOGADD(sum, w); + logAdd_New(sum, w); + } + + T >>= 1; J <<= 1; + } + if (S == 0) + gfNume[0] = 0; + else + gfNume[S] = sum; + } + } + + + + void compute_g_backward(int nh){ + sub_gb(0, nh, 0); + + } + + + void sub_gb(int d, int nh, int S){ + if (d < nh){ + sub_gb(d+1, nh, S); + sub_gb(d+1, nh, S | (1 << d)); + } + else { + double sum = MARK; + int T = S, J = 1, complS = (1 << nh) - 1 - S; + for (int j = 0; j < nh; j ++){ + if (T & 1){ + // Now S - J is a subset of S. + double w = alpha[j][complS] + gb[S - J]; + //LOGADD(sum, w); + logAdd_New(sum, w); + } + T >>= 1; J <<= 1; + } + if (S == 0) gb[0] = 0; else gb[S] = sum; + } + } + + + double eval_edge(int i, int j, double *a, double *b, int nh, int k){ + int T = 1 << i; + return sub_eval_edge(-1, 1, T, i, j, a, b, nh, k); + } + + + double sub_eval_edge( + int tprev, int d, int T, int i, int j, double *a, double *b, int nh, int k){ + + //cerr<<" T:"; print_set(cerr, T); + //cerr<<": "<<a[T]<<"; "<<b[T]<<endl; + + //if T, d = |G_v| = k + if (d == k){ + return a[T] + b[T]; + } + + //if T < k, can add more + double sum = a[T] + b[T]; + for (int t = tprev + 1; t < nh; t ++){ + if (t == i || t == j) continue; + + int Tnext = T | (1 << t); + double w = sub_eval_edge(t, d+1, Tnext, i, j, a, b, nh, k); + //LOGADD(sum, w); + logAdd_New(sum, w); + } + return sum; + } + + + double eval_edge_mixIndegree(int i, int j, double * Gamma, double * Beta_j, int nh, int k){ + int T = 1 << i; + return sub_eval_edge_mixIndegree(-1, 1, T, i, j, Gamma, Beta_j, nh, k); + } + + + double sub_eval_edge_mixIndegree( + int tprev, int d, int T, int i, int j, double * Gamma, double * Beta_j, int nh, int k){ + + //cerr<<" T:"; print_set(cerr, T); + //cerr<<": "<<a[T]<<"; "<<b[T]<<endl; + + //if T, d = |G_v| = k + if (d == k){ + double sumRes; + if(Beta_j[T] == MARK){ + cerr<<"\n**** Beta_j[T] == MARK "; + } + + //return (Gamma[T] + Beta_j[T]); + if(Gamma[T] == LOG_ZERO){ + sumRes = LOG_ZERO; + } + + else if(Gamma[T] <= 0){ + sumRes = Beta_j[T] + Gamma[T]; + } + else{ + cerr<<"\n**** Gamma[T] > 0 "; + sumRes = - ( Beta_j[T] - Gamma[T] ); + + } + return sumRes; + + } + + //if T < k, can add more + //double sum = Gamma[T] + Beta_j[T]; + double sum; + if(Beta_j[T] == MARK){ + cerr<<"\n**** Beta_j[T] == MARK "; + } + if(Gamma[T] == LOG_ZERO){ + sum = LOG_ZERO; + } + + else if(Gamma[T] <= 0){ + sum = Beta_j[T] + Gamma[T]; + } + else{ + cerr<<"\n**** Gamma[T] > 0 "; + sum = - ( Beta_j[T] - Gamma[T] ); + + } + + + for (int t = tprev + 1; t < nh; t ++){ + if (t == i || t == j) continue; + + int Tnext = T | (1 << t); + double w = sub_eval_edge_mixIndegree(t, d+1, Tnext, i, j, Gamma, Beta_j, nh, k); + logAddComp(sum, w); + } + return sum; + } + + + double eval_edge_mixIndegreeNoLog(int i, int j, double * Gamma, double * Beta_j, int nh, int k){ + int T = 1 << i; + return sub_eval_edge_mixIndegreeNoLog(-1, 1, T, i, j, Gamma, Beta_j, nh, k); + } + + + double sub_eval_edge_mixIndegreeNoLog( + int tprev, int d, int T, int i, int j, double * Gamma, double * Beta_j, int nh, int k){ + //cerr<<" T:"; print_set(cerr, T); + //cerr<<": "<<a[T]<<"; "<<b[T]<<endl; + + //if T, d = |G_v| = k + if (d == k){ + //Lose precision + //return (Gamma[T] * exp(Beta_j[T])); + double product_res; + //if Beta_j[T] has not been initialized + if(Beta_j[T] == MARK){ + cerr<<"***Beta_j[T] has not been initialized" << endl; + product_res = 0; + } + else{ + if(Gamma[T] == 0){ + product_res = exp(Beta_j[T]); + } + else if(Gamma[T] > 0){ + product_res = exp(Beta_j[T] + log(Gamma[T])); + } + else{ + product_res = - exp(Beta_j[T] + log(-Gamma[T])); + } + + } + + return product_res; + + } + + //if T < k, can add more + //double sum = Gamma[T] * exp(Beta_j[T]); + double sum; + double product_res; + + //if Beta_j[T] has not been initialized + if(Beta_j[T] == MARK){ + cerr<<"***Beta_j[T] has not been initialized" << endl; + product_res = 0; + } + else{ + if(Gamma[T] == 0){ + product_res = exp(Beta_j[T]); + } + else if(Gamma[T] > 0){ + product_res = exp(Beta_j[T] + log(Gamma[T])); + } + else{ + product_res = - exp(Beta_j[T] + log(-Gamma[T])); + } + + } + + sum = product_res; + for (int t = tprev + 1; t < nh; t ++){ + if (t == i || t == j) continue; + + int Tnext = T | (1 << t); + double w = sub_eval_edge_mixIndegreeNoLog(t, d+1, Tnext, i, j, Gamma, Beta_j, nh, k); + //LOGADD(sum, w); + sum += w; + } + return sum; + } + + + Model *model; + + double **alpha, **beta; + double **alphaNume, **betaNume; + + double *gf, *gb; + + double *gfNume; + int k; + + double **alphaInOut, **betaInOut; + int * inFeatureEdges; + int * outFeatureEdges; + + +}; + + + +#endif diff --git a/var_lib_genenet_bnw/k-best/src/buildk_poster.sh b/var_lib_genenet_bnw/k-best/src/buildk_poster.sh new file mode 100644 index 00000000..a7c11183 --- /dev/null +++ b/var_lib_genenet_bnw/k-best/src/buildk_poster.sh @@ -0,0 +1,7 @@ +#!/bin/bash + +D=g++ + +$D -o get_kbest_parents get_kbest_parents.cc +$D -o get_kbest_nets get_kbest_nets.cc + diff --git a/var_lib_genenet_bnw/k-best/src/cfg.h b/var_lib_genenet_bnw/k-best/src/cfg.h new file mode 100644 index 00000000..15e3fe89 --- /dev/null +++ b/var_lib_genenet_bnw/k-best/src/cfg.h @@ -0,0 +1,9 @@ +#ifndef __CFG_H_ +#define __CFG_H_ + +#define MAX_NOF_VARS (32) +#define LARGEST_SET(NOF_VARS) ((NOF_VARS)==MAX_NOF_VARS?(varset_t)~0:(1U<<(NOF_VARS))-1) +typedef unsigned int varset_t; +typedef double score_t; + +#endif diff --git a/var_lib_genenet_bnw/k-best/src/data2netk_poster.sh b/var_lib_genenet_bnw/k-best/src/data2netk_poster.sh new file mode 100644 index 00000000..19d8f7cd --- /dev/null +++ b/var_lib_genenet_bnw/k-best/src/data2netk_poster.sh @@ -0,0 +1,56 @@ +#!/bin/bash + +binpath=`dirname $0` + +if [ $# -ne 4 ]; then + echo Usage: data2net.sh datafile resultdir k 1>&2 + exit 1 +fi + +datafile=$1; shift +#score=$1; shift +rdir=$1; shift +k=$1;shift +n=$1;shift + +nof_vars=`head -1 $datafile|wc -w` +#echo "The number of variables is $nof_vars." + +#HR: +if [ "$n" -eq 0 ] +then + maxindegree=`expr $nof_vars - 1` +else + maxindegree=$n +fi + +#maxindegree=`expr $nof_vars - 1` +#echo "maxindegree is $maxindegree." + +#HR: +nof_instances=`cat $datafile | wc -l` +#delete the header and type +nof_instances=`expr $nof_instances - 2` +#echo "The number of instances is $nof_instances." + + +START=$(date +%s%N) +$binpath/get_kbest_parents $nof_vars ${rdir} $k +#HR +END=$(date +%s%N) +#DIFF=$(( $END - $START )) +DIFF2=$(( $END - $START )) +#echo "get_kbest_parents is done." +#echo "get_kbest_parents took $DIFF2 n-seconds." + +START=$(date +%s%N) +$binpath/get_kbest_nets $nof_vars ${rdir} $k +#HR +END=$(date +%s%N) +#DIFF=$(( $END - $START )) +DIFF3=$(( $END - $START )) +#echo "get_kbest_nets is done." +#echo "get_kbest_nets took $DIFF3 n-seconds." + +DIFF=`expr $DIFF1 + $DIFF2 + $DIFF3` +#echo "The total process took $DIFF n-seconds." diff --git a/var_lib_genenet_bnw/k-best/src/files.h b/var_lib_genenet_bnw/k-best/src/files.h new file mode 100644 index 00000000..f11dd09e --- /dev/null +++ b/var_lib_genenet_bnw/k-best/src/files.h @@ -0,0 +1,12 @@ +#ifndef __FILES_H__ +#define __FILES_H__ + +#include <stdio.h> + +int nof_lines(char* filename); +char* create_fn(char* dirname, int i, char* ext); +FILE* open_file(char* dirname, int i, char* ext, char* mode); +FILE** open_files(int nof_vars, char* dirname, char* ext, char* mode); +void free_files(int nof_vars, FILE** files); + +#endif diff --git a/var_lib_genenet_bnw/k-best/src/files.o b/var_lib_genenet_bnw/k-best/src/files.o new file mode 100644 index 00000000..33f376d3 --- /dev/null +++ b/var_lib_genenet_bnw/k-best/src/files.o Binary files differdiff --git a/var_lib_genenet_bnw/k-best/src/get_kbest_nets b/var_lib_genenet_bnw/k-best/src/get_kbest_nets new file mode 100644 index 00000000..1c4a6041 --- /dev/null +++ b/var_lib_genenet_bnw/k-best/src/get_kbest_nets Binary files differdiff --git a/var_lib_genenet_bnw/k-best/src/get_kbest_nets.cc b/var_lib_genenet_bnw/k-best/src/get_kbest_nets.cc new file mode 100644 index 00000000..2ee35265 --- /dev/null +++ b/var_lib_genenet_bnw/k-best/src/get_kbest_nets.cc @@ -0,0 +1,1552 @@ +#include <iostream> +#include <fstream> +#include <iomanip> +//#include "varpar.h" +#include <stdlib.h> +#include <math.h> +#include <list> +#include <stdio.h> +#include <vector> +#include "cfg.h" +#include <string.h> +#include <cmath> +//HR +//#define EPSILON 0.001 +#define EPSILON 0.00001 + + +//HR: Add for hash_set +#if __GNUC__ < 3 && __GNUC__ >= 2 && __GNUC_MINOR__ >= 95 +# include <hash_set> +# include <functional> +# define gnu_namespace std +#elif __GNUC__ >= 3 +# include <ext/hash_set> +# if __GNUC_MINOR__ == 0 +# include <functional> +# define gnu_namespace std +# else +# include <ext/functional> +# define gnu_namespace __gnu_cxx +# endif +#else +# include <hash_set.h> +# include <functional.h> +# define gnu_namespace std +#endif +using namespace gnu_namespace; +#include <set> +// + + +using namespace std; + + +#define MARK 9e99 +#define LOG_ZERO -1e101 + +//HR: add from UpdateHR.h to deal with the problem in sum = 0 in comp_post() +//call by reference to the original value +//the log sum result is stored in logA + +#define epsilon 1.0e5 + +bool logSpecValEquals(double logX, double logSpecVal){ + return (logX >= logSpecVal - epsilon && logX <= logSpecVal + epsilon); +} + +void logAddComp(double & logA, double & logB){ + + //if(logA == MARK){ + if(logSpecValEquals(logA, MARK)){ + logA = logB; + } + //else if (logA == LOG_ZERO){ + else if (logSpecValEquals(logA, LOG_ZERO)){ + logA = logB; + } + //else if(logB == MARK){ + else if(logSpecValEquals(logB, MARK)){ + logA = logA; + } + //else if(logB == LOG_ZERO){ + else if(logSpecValEquals(logB, LOG_ZERO)){ + logA = logA; + } + + + //Neither logA nor logB is MARK/LOG_ZERO + else{ + //1 + if(logA < 0 && logB < 0 ){ + //1.1 + //Gaurd logB-logA <= 100 to avoid that exp(logB-logA) go to inf + if(logB - logA <= 100 ){ + logA = logA + log( 1 + exp(logB-logA) ); + + } + //1.2 + //if logB - logA > 100, then logB > 100 + logA so that B is much bigger than A (B > e^100 * A) + // So (A + B) almost = B + else{ + //logA = logB; + //The following is the real formula,; but it is almost same as //logA = logB; + logA = logB + log( exp(logA - logB) + 1); + } + } + + //2 + else if(logA > 0 && logB > 0){ + //always make exp(.): . > 0 + if(-logB + logA <= 100){ + //2.1 + logA = -( -logA + log( 1 + exp(-logB+logA) ) ); + } + else{ + //2.2 + logA = -( -logB + log( 1 + exp(-logA+logB) ) ); + } + + } + //3 + else if(logA < 0 && logB > 0){ + //3.1 + if(logA + logB > 0){ + if(logA + logB <= 100){ + //3.1.2 + logA = -logB + log( exp(logA + logB) - 1 ); + } + else{ + //3.1.1 + logA = logA + log( 1 - exp(-logB-logA) ); + } + + } + //3.2 + else if(logA + logB < 0){ + if(-logA - logB <= 100){ + //3.2.2 + logA = -( logA + log( exp(-logB-logA) - 1) ); + } + else{ + //3.2.1 + logA = - ( -logB + log(1 - exp(logA+logB) ) ); + } + + } + //3.3 + else{ + logA = LOG_ZERO; + } + } + //4 + else if(logA > 0 && logB < 0){ + //4.1 + if(logA + logB > 0){ + if(logA + logB <= 100){ + //4.1.2 + logA = -logA + log( exp(logB+logA) - 1); + } + else{ + //4.1.1 + logA = logB + log( 1 - exp(-logA-logB) ); + } + + } + //4.2 + else if(logA + logB < 0){ + if(-logA-logB <= 100){ + //4.2.2 + logA = -( logB + log( exp(-logA-logB) - 1) ); + } + else{ + //4.2.1 + logA = -( -logA + log(1 - exp(logB+logA)) ); + } + + } + //4.3 + else{ + logA = LOG_ZERO; + } + } + + } + +} // end of void logAddComp(double & logA, double & logB)c + + + +//HR: Note: The whole program supposes that max no. of vars = 32 and hardcord 32 + + +//Convert the parent set to the appropriate variable set +//HR:F +varset_t parset2varset(int v, varset_t set){ + varset_t sinkleton = 1U<<v; + varset_t mask = sinkleton - 1; + varset_t low = set & mask; + varset_t high = set & ~mask; + return (high<<1) | low; +} + + + +/*================================================================*/ +//class for bnets +//HR:F +//for (net, score) pair +// each net[j] (0 <= j <= 32-1) is the binary repres of the parents +class net_set{ + public: + score_t score; + varset_t net[32]; + + net_set(){ + score=0.0000; + for(int j=0;j<32;j++){ + net[j]=0; + } + } + + friend int operator<(net_set s1,net_set s2); + friend int operator==(net_set s1,net_set s2); + friend int operator>(net_set s1,net_set s2); + friend bool same_obj(net_set s1, net_set s2, int nof_vars); + +}; + +//HR:F +/*================================================================*/ + +int operator<(net_set s1,net_set s2){ + if(fabs(s1.score-s2.score)<EPSILON){ + return false; + } + return(s1.score<s2.score); +} + +int operator>(net_set s1,net_set s2){ + if(fabs(s1.score-s2.score)<EPSILON){ + return false; + } + return(s1.score>s2.score); +} + +int operator==(net_set s1,net_set s2){ + return(fabs(s1.score-s2.score)<EPSILON); +} + +//HR: check whether s1 and s2 are the same +bool same_obj(net_set s1, net_set s2, int nof_vars){ + + bool flag=true; + + for(int j=0;j<nof_vars;j++){ + if(s1.net[j]!=s2.net[j]){ + //cout<<"************************"; + flag=false; + break; + } + } + //cout<<"Flag "<<flag; + // if(flag==true) + // { + // if(fabs(s1.score-s2.score)<0.1) + // flag=true; + // else flag=false; + // } + + return(flag); +} + +//HR: check whether s1 and s2 are the same +bool same_obj(net_set s1, net_set s2){ + + bool flag=true; + + for(int j=0;j<MAX_NOF_VARS;j++){ + if(s1.net[j]!=s2.net[j]){ + //cout<<"************************"; + flag=false; + break; + } + } + //cout<<"Flag "<<flag; + // if(flag==true) + // { + // if(fabs(s1.score-s2.score)<0.1) + // flag=true; + // else flag=false; + // } + + return(flag); +} +// + +/*================================================================*/ +//HR:F +//HR: Refined +void insert_vec(list<net_set>* v,net_set s, int k, int nof_vars){ + list<net_set>::iterator it; + //HR: can improve its time + //first check whether v->size() > 0 && s < v->back() + //see Lav's comment + + + bool flag=false; + + + //HR: Refined + // + if( (v->size() > 0) && (s < v->back()) ){ + v->push_back(s); + flag=true; + } + else{ + // + + for(it=v->begin();it!=v->end();it++){ + if(same_obj(s,*it,nof_vars)){ +// cout<<"Same object so not inserted!!!!!!!!!!!!!"<<endl; + flag=true; + break; + } + else if(s>(*it)){ + // cout<<"score of s:"<<s.score<<"Score of kbnet element "<<(*it).score<<endl; + v->insert(it,s); + flag=true; + break; + } + + } + + } + + if(flag==false){ + v->push_back(s); + } + if(v->size()>k){ + v->pop_back(); + } + + //v->unique(); +} + +/*================================================================*/ +//class for bparents +//HR:F +//HR: (variable set, score) pair +class score_network{ + public: + score_t scores; + varset_t vset; + + friend int operator<(score_network s1,score_network s2); + friend int operator==(score_network s1,score_network s2); + friend int operator>(score_network s1,score_network s2); + friend bool same_obj(score_network s1, score_network s2); + +}; + + +//HR:F +int operator<(score_network s1,score_network s2){ + if(fabs(s1.scores-s2.scores)<EPSILON){ + return false; + } + return(s1.scores<s2.scores); + +} + +int operator>(score_network s1,score_network s2){ + if(fabs(s1.scores-s2.scores)<EPSILON){ + return false; + } + return(s1.scores>s2.scores); + +} + +int operator==(score_network s1,score_network s2){ + return(fabs(s1.scores-s2.scores)<EPSILON); +} + + +bool same_obj(score_network s1, score_network s2){ + return((s1==s2)&&(s1.vset==s2.vset)); +} + + + + +void insert_vec(list<score_network>* v,score_network s, int k) + { + list<score_network>::iterator it; + + if( s < v->back()) + { + v->push_back(s); + } + else + { + for(it=v->begin();it!=v->end();it++) + { + // if(same_obj(s,*it)) + // { + // break; + // } +// else + if(s>(*it)) + { + v->insert(it,s); + break; + } + + } + } + + if(v->size()>k) + { + v->pop_back(); + } + + } + +/*================================================================*/ +//class for node +//HR:F +class node{ + public: + int ip; + int in; + score_t score; + + node(int x, int y, score_t z){ + ip=x; + in=y; + score=z; + } + + friend int operator<(node s1,node s2); + friend int operator==(node s1,node s2); + friend int operator>(node s1,node s2); + friend bool same_obj(node s1, node s2); +}; + +/*================================================================*/ + +int operator<(node s1,node s2){ + if(fabs(s1.score-s2.score)<EPSILON){ + return false; + } + return(s1.score<s2.score); +} + + +int operator>(node s1,node s2){ + + if(fabs(s1.score-s2.score)<EPSILON){ + return false; + } + return(s1.score>s2.score); +} + + +int operator==(node s1,node s2){ + return(fabs(s1.score-s2.score)<EPSILON); +} + + +bool same_obj(node s1, node s2){ + return((s1==s2)&&(s1.ip==s2.ip)&&(s1.in==s2.in)); +} + +/*================================================================*/ + +//HR: F +void print_queue(list<net_set> v[],int size,int nof_vars){ + + list<net_set>::iterator iter; + + for(int j=0;j<size;j++){ + for(iter=v[j].begin();iter!=v[j].end();iter++){ + //HR: + //kbnetscore[j] can have at most k (net, score) pairs + cout<<"kbnetscore "<<j<<" Score:"<<(*iter).score<<" net "; + for(int p=0;p<nof_vars;p++){ + cout<<(*iter).net[p]; + } + cout<<endl; + } + } +} + +//HR: Add +void print_netscore(net_set ns,int nof_vars){ + + + cout<<"netscore "<<" Score:"<<ns.score<<" \tnet "; //<<endl; + for(int p=0;p<nof_vars;p++){ + cout<<ns.net[p] << " "; + } + cout<<endl; + cout<<endl; + +} +// + +void print_queue(vector<score_network>* v){ + + vector<score_network>::iterator iter; + + for(iter=v->begin();iter!=v->end();iter++){ + cout<<"bparents "<<(*iter).vset<<","<<(*iter).scores<<" ,, "; + } + +} + +void print_queue(list<node>* v){ + + list<node>::iterator iter; + cout<<"fringe"<<endl; + for(iter=v->begin();iter!=v->end();iter++){ + cout<<" ip "<<(*iter).ip<<", in "<<(*iter).in<<" score "<<(*iter).score; + } + +} + +void print_queue(vector<net_set>* v,int nof_vars){ + + vector<net_set>::iterator iter; + + for(iter=v->begin();iter!=v->end();iter++){ +// cout<<" "<<(*iter).bsps<<","<<(*iter).scores; + cout<<"bnets "<<" Score:"<<(*iter).score<<" net "<<endl; + for(int p=0;p<nof_vars;p++){ + cout<<(*iter).net[p]; + } + + } +} + +void print_queue(list<net_set>* v,int nof_vars){ + + list<net_set>::iterator iter; + + for(iter=v->begin();iter!=v->end();iter++){ +// cout<<" "<<(*iter).bsps<<","<<(*iter).scores; + cout<<"kbnet "<<" Score:"<<(*iter).score<<" net "<<endl; + for(int p=0;p<nof_vars;p++){ + cout<<(*iter).net[p]; + } + } +} + + + + +//HR: call insert_vec(&fringe,n,k); +//HR: by this way, fringe is in descending order +//HR: Lav's code is wrong +//HR: corrected +void insert_vec(list<node>* v,node s, int k){ + list<node>::iterator it; + + //HR: test + //bool sameObj = false; + //bool inserted = false; + // + + //if( s < v->back()){ same + if( (v->size() == 0) || (s < v->back())){ + v->push_back(s); + } + else{ + for(it=v->begin();it!=v->end();it++){ + //comment it out will give the different answer. Because Lav's original is wrong, it will still insert the same object. It will eventually pop the correct end > k + // + if(same_obj(s, *it)){ + break; +// sameObj = true; +// cout << "s: "; +// print_node(s); +// cout << "*it: "; +// print_node(*it); +// cout << endl; +// print_queue(v); + + } + else{ + // + if(s>(*it)){ + v->insert(it,s); + //inserted = true; + break; + } + } + + } + + //HR: test +// if(sameObj == true && inserted == true){ +// cout << "Error: sameObj == true && inserted = true" << endl; + +// cout << "s: "; +// print_node(s); +// print_queue(v); +// } + } + + if(v->size()>k){ + //cout << "\n\nv->size()>k happens, v->pop_back()\n" << endl; + v->pop_back(); + } + // cout<<"Inserted:"<<endl; +} + + + + +//===================================================================// +//HR: Add hash_set to store net_set (i.e. (net, score) pair +namespace gnu_namespace { + + template<> + + struct hash<const net_set*> { + + hash<unsigned> hasher_ns; + + size_t operator()(const net_set* ns) const { + return hasher_ns((unsigned) roundl(- ns->score*10)); // wrong hash function?? + } + + }; //end of struct + +} //end of namespace + + + +struct eqNetScore{ + bool operator()(const net_set* ns1, const net_set* ns2) const{ + return same_obj(*ns1, *ns2); + } +}; + + + +typedef hash_set<const net_set *, hash<const net_set *>, eqNetScore> NetScoreHashSet; + +NetScoreHashSet knets; + + +//HR: Add +void print_nsHashSet(NetScoreHashSet nsHSet, int nof_vars){ + for(NetScoreHashSet::iterator it = nsHSet.begin(); it != nsHSet.end(); it++){ + print_netscore(**it, nof_vars); + } +} +// + + + +//=====================================================================================// + +/*================================================================*/ + +//HR:F +//HR: call gettopk(&bnets,&bparents,&kbnetscore[varset],k,sink,nof_vars); +void gettopk(vector<net_set>* bnets, vector<score_network>* bparents, list<net_set>* kbnet, int k, varset_t sink,int nof_vars){ + int h; + int ipmax=bparents->size(); +// cout<<"ipmax: "<<ipmax; + + int inmax=bnets->size(); + // cout<<"inmax: "<<inmax; + + //HR: Add hash_set generated here + + // + + int ip,in; + + net_set * netwP; + + score_t score; + + list<node> fringe; + + //HR: different from Algo4, here start from 0 vs. 1 + node n(0,0,(bparents->at(0)).scores + (bnets->at(0)).score); + insert_vec(&fringe,n,k); + // print_queue(&fringe); + // scanf("%d",&h); + + NetScoreHashSet::iterator iter1; + + while(!fringe.empty()){ + // cout<<"Fringe not empty"<<endl; + n = fringe.front(); + fringe.pop_front(); + // cout<<"Fringe After popping"<<endl; + // print_queue(&fringe); + ip=n.ip; + in=n.in; + score=n.score; + // cout<<"Popped node"<<endl; + // cout<<"ip "<<ip<<"in "<<in<<"score "<<score<<endl; + + if((kbnet->size())<k){ + // cout<<"Size < k"<<endl; + //HR: Add + //net_set netw; + // + netwP = new net_set(); + for(int j=0;j<nof_vars;j++){ + (*netwP).net[j]=(bnets->at(in)).net[j]; + // cout<<"Net w j"<<netw.net[j]<<endl; + } + (*netwP).net[sink]=((bparents->at(ip)).vset); + //cout<<"net w sinkleton"<<netw.net[sinkleton]<<endl; + (*netwP).score=score; + //cout<<"net score "<<netw.score<<endl; + //cout<<"Before inserting:"<<endl; + // print_queue(kbnet,nof_vars); + + //HR: Add hash_set knets check here + //if not find netw + if((iter1 = knets.find(netwP)) == knets.end()){ + //Lav + //every time call by value of netw + + insert_vec(kbnet, *netwP, k, nof_vars); + //cout<<"After inserting"<<endl; + //print_queue(kbnet,nof_vars); + //scanf("%d",&h); + //cout<<"Inserted into kbnetscore"<<endl; + // + //HR: Add to knets + knets.insert(netwP); + + } + + else{ + if( same_obj(*netwP, **iter1, nof_vars) == false ){ + cout<<"Error: same_obj(*netwP, **iter1, nof_vars) == false"<<endl; + return; + } + + //delete the memory + delete netwP; + + } + + // + + } + + else if((fabs(score-(kbnet->back()).score)>EPSILON)&&(score>(kbnet->back().score))){ + // cout<<"score>kbnetback's score"<<endl; + + //HR: Add + //net_set netw; + // + netwP = new net_set(); + for(int j=0;j<nof_vars;j++){ + (*netwP).net[j]=(bnets->at(in)).net[j]; + // cout<<"Net w j"<<netw.net[j]<<endl; + } + (*netwP).net[sink]=(bparents->at(ip)).vset; + //cout<<"net w sinkleton"<<netw.net[sinkleton]<<endl; + (*netwP).score=score; + //cout<<"net score"<<netw.score<<endl; + //cout<<"Before inserting:"<<endl; + // print_queue(kbnet,nof_vars); + + + //HR: Add hash_set knets check here + //if not find + if((iter1 = knets.find(netwP)) == knets.end()){ + + net_set lastNs = kbnet->back(); + + //Lav + insert_vec(kbnet,*netwP,k,nof_vars); + //cout<<"After inserting"<<endl; + //print_queue(kbnet,nof_vars); + //scanf("%d",&h); + // + //HR: Add to knets + knets.insert(netwP); + + iter1 = knets.find(&lastNs); + + if(iter1 == knets.end()){ + cout << "Error: iter1 should != knets.end() since lastNs should be found in kents" << endl; + return; + } + const net_set * nsTempP = * iter1; + + knets.erase(&lastNs); //do not remove + delete nsTempP; + + //HR: remove from kbnet has been done inside knets.insert(netwP); + } + + else{ + if( same_obj(*netwP, **iter1, nof_vars) == false ){ + cout<<"Error: same_obj(*netwP, **iter1, nof_vars) == false"<<endl; + return; + } + + //delete the memory + delete netwP; + + + } + + + + } + else{ + return; + } + + //HR: since start from 0 not 1; so use ip<ipmax-1 + if(ip<ipmax-1){ + //cout<<"before child:"<<endl; + node child(ip+1,in,(bparents->at(ip+1)).scores + (bnets->at(in)).score); + //cout<<"after child"<<endl; + //cout<<"Fringe before inserting:"<<endl; + //print_queue(&fringe); + + //may add hash_set generated check here + + insert_vec(&fringe,child,k); + //cout<<"Fringe after inserting"<<endl; + //print_queue(&fringe); + //scanf("%d",&h); + + } + if(in<inmax-1){ + // cout<<"Fringe before inserting:"<<endl; + // print_queue(&fringe); + + node child(ip,in+1,(bparents->at(ip)).scores + (bnets->at(in+1)).score); + + //may add hash_set generated check here + + insert_vec(&fringe,child,k); + //cout<<"Fringe after inserting"<<endl; + + // print_queue(&fringe); + // scanf("%d",&h); + + } + }//end of while + // scanf("%d",&h); +} + +/*================================================================*/ +//converts from the best parent sets obtained to actual variable set +//HR: call conv_net(&kbnetscore[nof_combs-1],k,nof_vars); +//HR:F +void conv_net(list<net_set>* kbnet, int k,int nof_vars){ + list<net_set>::iterator it; + //int j=0; + //each it is one of k best + for(it=kbnet->begin();it!=kbnet->end();it++){ + for(int p=0;p<nof_vars;p++){ + + (*it).net[p]=parset2varset(p,((*it).net[p])); + // j++; + } + } +} + +/*================================================================*/ +//To convert net string into arc set +//HR: call net2arc(dirname,k,nof_vars); +//HR:F +void net2arc(char* dirname,int k,int nof_vars){ + score_t s; + string str; + unsigned int vset; + char str1[32]; + //HR: for each j'th best network + for(int j=0;j<k;j++){ + str.assign(dirname); + str.append("/"); + sprintf(str1,"%d",j); + str.append(str1); + str.append("net"); + FILE* netf=fopen(str.c_str(),"r"); + if(netf==NULL) + break; + str.assign(dirname); + str.append("/"); + str.append("arc"); + sprintf(str1,"%d",j); + str.append(str1); + + FILE* arcf=fopen(str.c_str(),"w"); + fscanf(netf,"%f",&s); + // printf("\n ===network %d",j); + for(int p=0;p<nof_vars;p++){ + // printf("\n\nVar %d's parents:\n\n",p); + fscanf(netf,"%u",&vset); + const int SHIFT = 8 * sizeof( unsigned ) - 1; + const unsigned MASK = 1 << SHIFT; + for ( int i = 1; i <= SHIFT + 1; i++ ) { + // cout << ( vset & MASK ? '1' : '0' ); + if(vset&MASK){ + fprintf(arcf,"%u %d",SHIFT+1-i,p); + fprintf(arcf,"\n"); + } + vset <<= 1; + } + // printf("\n\n"); + } + fclose(netf); + fclose(arcf); + } +} + +/*================================================================*/ +//Write net file +//HR: call write_net(kbnetscore,dirname,k,nof_vars); +//HR: get files: 0net, 1net, ..., (k-1)net +void write_net(list<net_set> kbnetscore[],char* dirname,int k,int nof_vars) +{ + string str; + list<net_set>::iterator it; + char str1[10]; + int j=0; + //HR: each it is the one of the k best + for(it=kbnetscore[(1U<<(nof_vars))-1].begin();it!=kbnetscore[(1U<<(nof_vars))-1].end();it++){ + str.assign(dirname); + str.append("/"); + sprintf(str1,"%d",j++); + str.append(str1); + str.append("net"); + FILE* netf=fopen(str.c_str(),"w"); + fprintf(netf,"%f \n",(*it).score); + // cout<<(*it).score<<endl; + for(int p=0;p<nof_vars;p++){ + // (*it).net[p]=parset2varset( + fprintf(netf,"%u \n",(*it).net[p]); + } + fclose(netf); + } + +} + +/*================================================================*/ + +void print_scores(list<net_set> kbnetscore[],char* dirname,int k,int nof_vars){ +// string str; + list<net_set>::iterator it; + + int j=0; + for(j=0;j<((1U<<nof_vars)-1);j++) + for(it=kbnetscore[j].begin();it!=kbnetscore[j].end();it++){ + cout<<(*it).score<<endl; + } + +} + +/*================================================================*/ + + +//HR: Add +//HR: Update from comp_post_compl, now compute the exact post. prob. using +// denominator P(D) instead of \hat{P}(D) = \sum{G \in the set of k best G's} P(G,D) +// require exactPD.txt (computed by POSTER) is stored under the directory +//Compute each edge out of nof_vars * nof_vars, instead of just the best network + +void comp_postExact_compl(list<net_set>* kbnet, int k, char* dirname, int nof_vars){ + + //cout << "Start comp_postExact_compl()" << endl; + //long double Sum=0.0; + //double logSum = LOG_ZERO; + + list<net_set>::iterator it; + + //HR: assume k < 5000 + long double postExact[5000]; + + string str; + char str1[32]; + + //cout << "dirname = " << dirname << endl; + str.assign(dirname); + str.append("/"); + str.append("exactPD.txt"); + //str.assign("exactPD.txt"); + + FILE *fp; + fp=fopen(str.c_str(),"r"); + double exactPD = 0.0; + + if(!feof(fp)){ + char c; + fscanf(fp, "%lf", &exactPD); + fscanf(fp,"%c",&c); + } + fclose(fp); + //printf("exactPD = %18.8f\n", exactPD); + + + str.assign(dirname); + str.append("/netpostExact"); + fp=fopen(str.c_str(),"w"); + + //for each it of k best networks +// for(it=kbnet->begin();it!=kbnet->end();it++){ +// //HR: change it +// //sum+=exp((*it).score); +// logAddComp(logSum, (*it).score); //HR +// } +// cout << "logSum: " << logSum << endl; //HR +// printf("logSum = %18.6f\n", logSum); +// // +// long double Sum = exp(logSum); //HR +// cout << "Sum: " << exp(logSum) << endl; //HR + // + + int i=0; + //for each it of k best networks, compute equation (4) + //each post[i] ( 0 <= i <= k - 1). repre post prob for i'th best network + for(it=kbnet->begin();it!=kbnet->end();it++){ + //post[i]=(exp((*it).score))/sum; + //double logScore = (*it).score; + //LOGMINUS_NEW(logScore, logSum) + postExact[i]=exp( (*it).score - exactPD ); // + fprintf(fp,"%Lg\n",postExact[i]); + i++; + } + fclose(fp); + + + //Start the update + + //define and init + long double postProbExact[nof_vars][nof_vars]; + for(int i = 0; i < nof_vars; i++){ + for (int j = 0; j < nof_vars; j++){ + postProbExact[i][j] = 0.0; + } + } + + int listSize = kbnet->size(); + int num1 = -1; + int num2 = -1; + + + //HR: for each j of k best networks, j >=1 + for(int j=0; j<listSize; j++){ + str.assign(dirname); + str.append("/"); + str.append("arc"); + sprintf(str1,"%d",j); + str.append(str1); + fp=fopen(str.c_str(),"r"); + // fp=fopen(str.c_str(),"r"); + + //HR: for each edge in j'th best network + while(!feof(fp)){ + char c; + fscanf(fp,"%d",&num1); + fscanf(fp,"%d",&num2); + fscanf(fp,"%c",&c); + postProbExact[num1][num2] += postExact[j]; + //HR: needed! why? Otherwise there is error. fscanf() could not exactly overwrite the content of &num1/&num2 + num1 = -1; + num2 = -1; + + }//HR: end of while(!feof(fp)); + fclose(fp); + }//HR: end of for + + str.assign(dirname); + str.append("/postProbExactEachEdge.txt"); + ofstream totalOf1(str.c_str()); + + for(int i = 0; i < nof_vars; i++){ + for (int j = 0; j < nof_vars; j++){ + totalOf1 << "" << j << " -> " << i << " \t" << postProbExact[j][i] << endl; + } + } + +} //end void comp_postExact_compl() + + + + +//HR: Add +//HR: Update from comp_post +//Compute each edge out of nof_vars * nof_vars, instead of just the best network +void comp_post_compl(list<net_set>* kbnet, int k, char* dirname, int nof_vars){ + //long double Sum=0.0; + double logSum = LOG_ZERO; + list<net_set>::iterator it; + //HR: assume k < 5000 + long double post[5000]; + + string str; + char str1[32]; + str.assign(dirname); + str.append("/netpost"); + FILE *fp=fopen(str.c_str(),"w"); + + //for each it of k best networks + for(it=kbnet->begin();it!=kbnet->end();it++){ + //HR: change it + //sum+=exp((*it).score); + logAddComp(logSum, (*it).score); //HR + } + //cout << "logSum: " << logSum << endl; //HR + //printf("logSum = %18.6f\n", logSum); + // + long double Sum = exp(logSum); //HR + //cout << "Sum: " << exp(logSum) << endl; //HR + // + + int i=0; + //for each it of k best networks, compute equation (4) + //each post[i] ( 0 <= i <= k - 1). repre post prob for i'th best network + for(it=kbnet->begin();it!=kbnet->end();it++){ + //post[i]=(exp((*it).score))/sum; + //double logScore = (*it).score; + //LOGMINUS_NEW(logScore, logSum) + post[i]=exp( (*it).score - logSum ); // + fprintf(fp,"%Lg\n",post[i]); + i++; + } + fclose(fp); + + + //Start the update + + //define and init + long double postProb[nof_vars][nof_vars]; + for(int i = 0; i < nof_vars; i++){ + for (int j = 0; j < nof_vars; j++){ + postProb[i][j] = 0.0; + } + } + + int listSize = kbnet->size(); + int num1 = -1; + int num2 = -1; + + + //HR: for each j of k best networks, j >=1 + for(int j=0; j<listSize; j++){ + str.assign(dirname); + str.append("/"); + str.append("arc"); + sprintf(str1,"%d",j); + str.append(str1); + fp=fopen(str.c_str(),"r"); + // fp=fopen(str.c_str(),"r"); + + //HR: for each edge in j'th best network + while(!feof(fp)){ + char c; + fscanf(fp,"%d",&num1); + fscanf(fp,"%d",&num2); + fscanf(fp,"%c",&c); + postProb[num1][num2] += post[j]; + //HR: needed! why? Otherwise there is error. fscanf() could not exactly overwrite the content of &num1/&num2 + num1 = -1; + num2 = -1; + + }//HR: end of while(!feof(fp)); + fclose(fp); + }//HR: end of for + + str.assign(dirname); + str.append("/postProbEachEdge.txt"); + ofstream totalOf1(str.c_str()); + + for(int i = 0; i < nof_vars; i++){ + for (int j = 0; j < nof_vars; j++){ + totalOf1 << "" << j << " -> " << i << " \t" << postProb[j][i] << endl; + } + } + +} + + + +//Computation of posterior probabilities - This function's call has been commented. Remove the commenting slashes if the posterior probability needs to be computed. +//HR: call comp_post(&kbnetscore[nof_combs-1],k,dirname); + +void comp_post(list<net_set>* kbnet, int k, char* dirname){ + //long double Sum=0.0; + double logSum = LOG_ZERO; + list<net_set>::iterator it; + long double post[5000]; + + string str; + char str1[32]; + str.assign(dirname); + str.append("/netpost"); + FILE *fp=fopen(str.c_str(),"w"); + + //for each it of k best networks + for(it=kbnet->begin();it!=kbnet->end();it++){ + //HR: change it + //sum+=exp((*it).score); + logAddComp(logSum, (*it).score); //HR + } + cout << "logSum: " << logSum << endl; //HR + // + long double Sum = exp(logSum); //HR + cout << "Sum: " << exp(logSum) << endl; //HR + // + + int i=0; + //for each it of k best networks, compute equation (4) + //each post[i] ( 0 <= i <= k - 1). repre post prob for i'th best network + for(it=kbnet->begin();it!=kbnet->end();it++){ + //post[i]=(exp((*it).score))/sum; + //double logScore = (*it).score; + //LOGMINUS_NEW(logScore, logSum) + post[i]=exp( (*it).score - logSum ); // + fprintf(fp,"%Lg\n",post[i]); + i++; + } + fclose(fp); + + + ifstream indata; + int n=0; + int num[50][2]; + int num1,num2; + // char f[50][20]; + long double postf[50]; + str.assign(dirname); + str.append("/"); + str.append("arc0"); + fp=fopen(str.c_str(),"r"); + // fp=fopen(str.c_str(),"r"); + i=0; + while(!feof(fp)){ + char c; + //HR: for parent + fscanf(fp,"%d",&num[i][0]); + //HR: for var + fscanf(fp,"%d",&num[i][1]); + fscanf(fp,"%c",&c); + + //indata>>num[i][1]; + //HR: + // cout<<"HIIIII"<<num[i][0]<<"'"<<num[i][1]<<endl; + + // indata.getline(f[i],100); + i++; + } + //HR: + //i: the no. of lines in the arc0; so only for the edges in the best network + n=i-1; + cout<<n<<endl; + + //HR: postf vs. post + //HR: due to equality (5) + for(i=0;i<n;i++){ + postf[i]=post[0]; + } + + //indata.close(); + fclose(fp); + int j; + + //HR: for each j of k best networks, j >=1 + for(j=1;j<k;j++){ + str.assign(dirname); + str.append("/"); + str.append("arc"); + sprintf(str1,"%d",j); + str.append(str1); + fp=fopen(str.c_str(),"r"); + // fp=fopen(str.c_str(),"r"); + + //HR: for each edge in j'th best network + while(!feof(fp)){ + char c; + fscanf(fp,"%d",&num1); + fscanf(fp,"%d",&num2); + fscanf(fp,"%c",&c); + // indata>>num1; + // indata>>num2; + + //HR: + // cout<<endl<<endl<<endl<<num1<<",,,"<<num2<<endl; + //HR: check whether such edge is one of the edeges in the best network 0net + for(i=0;i<n;i++){ +// if(!strcmp(str1,f[i])) + //HR: if such edge is one of the edeges in the best network 0net + if(num1==num[i][0]&&num2==num[i][1]){ + postf[i]+=post[j]; + //HR: can add break; since each edge out of n edges in the best net is different + } + } + num1=num2=-1; + }//HR: end of while(!feof(fp)); + fclose(fp); + }//HR: end of for + + //HR: print out the posterior prob. for each edge in the best network + for(j=0;j<n;j++) + cout<<postf[j]<<endl; + +} + + +/*================================================================*/ +//inside it: get_top_k for the features +//HR:F +void get_kbest_nets(int nof_vars, FILE** fp,int k, char* dirname){ + int h; + //HR: 2^nof_vars + varset_t nof_combs = 1U<<(nof_vars); + //HR: + //cout<<"No of combs: "<<nof_combs<<endl; + //cout<<"Get k best nets"<<endl; + // + + //cout << "before list<net_set> kbnetscore[nof_combs]" << endl; + //cerr << "before list<net_set> kbnetscore[nof_combs]" << endl; + //HR: net_set is the (net, score) pair + //HR: have not yet set each list kbnetscore[W] the size k + list<net_set> kbnetscore[nof_combs]; + //cerr << "after list<net_set> kbnetscore[nof_combs]" << endl; + //cout << "after list<net_set> kbnetscore[nof_combs]" << endl; + list<net_set>::iterator it; + + vector<net_set> bnets; + + //HR: score_network is (variable set, score) pair + score_network s; + + vector<score_network> bparents; + + //HR: Add hash_set knets here; global may be better so that gettopk can access + //NetScoreHashSet knets; + // + //cout << "before net_set netw" << endl; + + net_set netw; + netw.score=0; + for(int j=0;j<nof_vars;j++) + netw.net[j]=0; + kbnetscore[0].push_back(netw); + + //cout << "before insert_vec(&kbnetscore[0],netw,k,nof_vars)" << endl; + + //HR + insert_vec(&kbnetscore[0],netw,k,nof_vars); + + //HR: call void print_queue(list<net_set> v[],int size,int nof_vars) + //cout << "print_queue(kbnetscore)" << endl; + //print_queue(kbnetscore,(1U<<nof_vars),nof_vars); +// scanf("%d",&h); +// cout<<"Pushed!!!"<<endl; + // + + varset_t varset; + int sink; + + //HR: W \subset V except empty set; + //HR: varset is the binary repre of W + for(varset=1;varset<nof_combs;varset++){ + //HR +// if(varset % 10000 == 1){ +// cout<<"====Varset==="<<varset<<endl; // +// } + // + + + //HR: Add for hash_set knets + //totally clean + //cout << "knets.clear() begins:" << endl; + int knetsSize = knets.size() ; + const net_set * nsPtrA[knetsSize]; + int j = 0; + for(NetScoreHashSet::iterator it = knets.begin(); it != knets.end(); it++){ + nsPtrA[j++] = *it; + } + knets.clear(); + + //really delete each object + for(j = 0; j < knetsSize; j++){ + delete nsPtrA[j]; //delete (*nsPtrA[j]) is wrong + } + //cout << "knets.clear() ends." << endl; + // + + + //HR: for each sink + for(sink = 0; sink<nof_vars;sink++){ + // cout<<"Sink "<<sink<<endl; + varset_t sinkleton = 1U<<sink; + // cout<<"sinkleton"<<sinkleton<<endl; + varset_t upvars; + + //HR: if sink is the subset of W + if (varset & sinkleton){ + // cout<<"inside if loop"; + upvars = varset& ~sinkleton; + // cout<<"Upvars:"<<upvars<<endl; + + //HR: construct array bnets from kbnetscore[upvars] + bnets.clear(); + bnets.resize(kbnetscore[upvars].size()); + copy(kbnetscore[upvars].begin(), kbnetscore[upvars].end(), bnets.begin()); + // print_queue(&bnets,nof_vars); + // scanf("%d",&h); + //cout<<"Copied"<<endl; + + //HR: construct array bparents from kbps[s][upvars] + bparents.clear(); + while(1){ + fread(&s.scores,sizeof(score_t),1,fp[sink]); + //cout<<"read score"<<endl; + if(s.scores==1000.0) + break; + + fread(&s.vset,sizeof(varset_t),1,fp[sink]); + // cout<<"read varset"<<endl; + //int num =k; + //insert_vec(&bparents,s,num); + + bparents.push_back(s); + // print_queue(&bparents); + //scanf("%d",&h); + } + + //scanf("%d",&h); + //printf("\n\n\nB PARENTS ============\n\n"); + //print_queue(&bparents); + //scanf("%d",&h); + + //printf("\n\n\nB nets =================\n\n"); + //print_queue(&bnets,nof_vars); + //scanf("%d",&h); + + //printf("\n\n\nKBNETSCORE %u =================\n\n",varset); + //print_queue(&kbnetscore[varset],nof_vars); + //scanf("%d",&h); + + ////printf("K = %d",k); + + //printf("Sink = %d",sink); + + + + //cout<<"Goin to call gettopk"<<endl; + gettopk(&bnets,&bparents,&kbnetscore[varset],k,sink,nof_vars); //new function: for each combination from n: totally 2^n + //printf("\n\n\nAfter topkKBNETSCORE %u =================\n\n",varset); + //print_queue(&kbnetscore[varset],nof_vars); + + }//end of if + + + }//end of for each sink + //scanf("%d",&h); + + }//end of for each W + //HR: last clear + //cout << "knets.clear() at the end of V begins: " << endl; + int knetsSize = knets.size() ; + const net_set * nsPtrA[knetsSize]; + int j = 0; + for(NetScoreHashSet::iterator it = knets.begin(); it != knets.end(); it++){ + nsPtrA[j++] = *it; + } + knets.clear(); + + //really delete each object + for(j = 0; j < knetsSize; j++){ + delete nsPtrA[j]; //delete (*nsPtrA[j]) is wrong + } + //cout << "knets.clear() at the end of V ends. " << endl; + + + + //HR + //print_queue(kbnetscore,32,5); //32 = 2^5 + + //cout << "main part of get__kbest_nets() is done." << endl; + + //HR: only consider V, the bianary repre is nof_combs-1 + conv_net(&kbnetscore[nof_combs-1],k,nof_vars); + //cout << "conv_net(&kbnetscore[nof_combs-1],k,nof_vars) is done." << endl; + + //HR: get files: 0net, 1net, ..., (k-1)net + write_net(kbnetscore,dirname,k,nof_vars); + //cout << "write_net(kbnetscore,dirname,k,nof_vars) is done." << endl; + + net2arc(dirname,k,nof_vars); + //cout << "net2arc(dirname,k,nof_vars) is done." << endl; + + //HR: + //cout << endl; + //cout << "kbnetscore[nof_combs-1].size() = " << kbnetscore[nof_combs-1].size() << endl; + //cout << "1st network score: " << kbnetscore[nof_combs-1].front().score << endl; + //cout << "last network score: " << kbnetscore[nof_combs-1].back().score << endl; + //cout << "The difference of the scores = " << ( kbnetscore[nof_combs-1].front().score - kbnetscore[nof_combs-1].back().score ) << endl; + //cout << endl; + // + + //comp_post(&kbnetscore[nof_combs-1],k,dirname); //new function: compute the posterior prob. + comp_post_compl(&kbnetscore[nof_combs-1],k,dirname, nof_vars); + //cout << "comp_post_compl(&kbnetscore[nof_combs-1],k,dirname) is done." << endl; + + //comp_postExact_compl(&kbnetscore[nof_combs-1],k,dirname, nof_vars); + //cout << "comp_postExact_compl(&kbnetscore[nof_combs-1],k,dirname, nof_vars) is not done. we will change it if requires" << endl; + + //HR: + // print_scores(kbnetscore,dirname,k,nof_vars); + +}//end of get_kbest_nets + +/*================================================================*/ + +//HR:F +int main(int argc, char* argv[]){ + FILE* fp[32]; + string str; + char str1[10]; + // printf("argc : %d \n\n",argc); + if(argc!=4){ + fprintf(stderr, "Usage: get_kbest_nets nof_vars dirname k\n"); + return 1; + } + + int nof_vars = atoi(argv[1]); + int k = atoi(argv[3]); + // printf("No of vars: %d K: %d\n\n",nof_vars,k); + for(int j=0;j<nof_vars;j++){ + str.assign(argv[2]); + str.append("/"); + sprintf(str1,"%d",j); + str.append(str1); + str.append(".kbps"); + // cout<<str<<endl; + //HR: In order to open a file as a binary file, a "b" character has to be included in the mode string + fp[j]=fopen(str.c_str(),"rb"); + } + //HR: + //cout<<"Calling function getkbestnets\n"; + // + get_kbest_nets(nof_vars, fp, k,argv[2]); + //cout<<"Success!"<<endl; + return 0; + +} + + + diff --git a/var_lib_genenet_bnw/k-best/src/get_kbest_parents b/var_lib_genenet_bnw/k-best/src/get_kbest_parents new file mode 100644 index 00000000..c31a73ee --- /dev/null +++ b/var_lib_genenet_bnw/k-best/src/get_kbest_parents Binary files differdiff --git a/var_lib_genenet_bnw/k-best/src/get_kbest_parents.cc b/var_lib_genenet_bnw/k-best/src/get_kbest_parents.cc new file mode 100644 index 00000000..9377d11e --- /dev/null +++ b/var_lib_genenet_bnw/k-best/src/get_kbest_parents.cc @@ -0,0 +1,249 @@ +//HR: formetted only, no code change + +#include <string> +#include <cmath> +#include <iostream> +#include "cfg.h" + +#include <stdlib.h> +#include <stdio.h> +#include <string.h> +#include <list> +#define EPSILON 0.001 + + +#include "files.h" + +using namespace std; + +int h; + +//class for bparents +//HR:F +//HR: (variable set, score) pair +//This class is to store the best parent set and the corresponding score +class score_network{ + public: + score_t scores; + varset_t bsps; + + score_network(score_t a,varset_t b){ + scores=a; + bsps=b; + } + + score_network(){ + scores=bsps=0; + } + + friend int operator<(score_network s1,score_network s2); + friend int operator==(score_network s1,score_network s2); + friend int operator>(score_network s1,score_network s2); + friend bool same_obj(score_network s1, score_network s2); + + +}; + +//HR:F +/*================================================================*/ + +void print_queue(list<score_network>* v){ + + list<score_network>::iterator iter; + + for(iter=v->begin();iter!=v->end();iter++){ + cout<<" "<<(*iter).bsps<<","<<(*iter).scores; + } + +} + +//HR:F +/*================================================================*/ + +int operator<(score_network s1,score_network s2){ + if(fabs(s1.scores-s2.scores)<EPSILON){ + return false; + } + return(s1.scores<s2.scores); + +} + + +int operator>(score_network s1,score_network s2){ + + if(fabs(s1.scores-s2.scores)<EPSILON){ + return false; + } + return(s1.scores>s2.scores); + +} + +int operator==(score_network s1,score_network s2){ + return(fabs(s1.scores-s2.scores)<EPSILON); + +} + + +bool same_obj(score_network s1, score_network s2){ + return((s1==s2)&&(s1.bsps==s2.bsps)); + +} + +/*================================================================*/ +//HR:F +//To insert into the best parent set list +void insert_vec(list<score_network>* v,score_network s, int k){ + list<score_network>::iterator it; + + if( s < v->back()){ + v->push_back(s); + } + else{ + for(it=v->begin();it!=v->end();it++){ + if(same_obj(s,*it)){ + break; + } + else if(s>(*it)){ + v->insert(it,s); + break; + } + + } + } + + if(v->size()>k){ + v->pop_back(); + } + +} + +/*================================================================*/ + +void get_best_parents(int nof_vars, char* dirname, int k){ + varset_t nof_parsets = 1U<<(nof_vars-1); + int i; +// cout<<endl<<"Inside fn"; + list<score_network> v[nof_parsets]; + list<score_network>::iterator it; + score_network s; + string str; + char str1[40]; + + //HR: For each var + for(i=0;i<nof_vars; ++i){ + /* READ SCORES FOR i */ + str.assign(dirname); + str.append("/"); + sprintf(str1,"%d",i); + str.append(str1); + // cout<<str; + FILE* fin = fopen(str.c_str(),"rb"); + + // cout<<fin; + // scanf("%d",&h); + + //HR: for all the possible parents + //Read local score and add it to the queue + for(int j=0;j<nof_parsets;j++){ + fread(&s.scores, sizeof(score_t), 1, fin); + // cout<<s.scores; + // scanf("%d",&h); + s.bsps = j; + + //HR: At this time, every queue has only one element s + v[j].push_back(s); + + + } + fclose(fin); + + + /* FIND BEST PARENTS AND THEIR SCORES IN EACH SET FOR i */ + + varset_t ps; + + //HR: for each possible parent set cs + //For each possible parent set compare and add to the list if it is within best k parent sets + for(ps=0; ps<nof_parsets; ++ps){ + varset_t psel = 1U; + + //HR: psel represents the number equals the single element which is not in the ps + // + for(psel=1; psel<nof_parsets; psel <<= 1){ + if (ps & psel){ + + //HR: use xor to get the subset whose size is 1 smaller + varset_t subset = ps^psel; + for(it=v[subset].begin();it!=v[subset].end();it++){ + if(v[ps].size()<k){ + insert_vec(&v[ps],*it, k); + + } + else if(v[ps].size()==k){ + if(((*it)<v[ps].back())||(*it)==v[ps].back()){ + break; + } + else{ + insert_vec(&v[ps], *it, k); + + + } + } + } + } + } + } + + + + /* WRITE BEST PARENTS FOR i */ + str.append(".kbps"); + FILE* fout = fopen(str.c_str(),"wb"); + double sentinel = 1000.0; + //printf("nofparset: %u",nof_parsets); + for(int j=0;j<nof_parsets;j++){ + // int g=0; + // print_queue(&v[j]); + // printf("\n"); + for(it=v[j].begin();it!=v[j].end();it++){ + // g++; + //fwrite(&v[j] + fwrite(&(it->scores), sizeof(double), 1, fout); + fwrite(&(it->bsps),sizeof(unsigned int),1,fout); + //print_queue(&v[j]); + //printf("\n"); + //fprintf(fout,"\n"); + } + + fwrite(&sentinel,sizeof(double),1,fout); + v[j].clear(); + + } + //printf("\n"); + fclose(fout); + + }// endfor(i=0;i<nof_vars; ++i) + +} + +/*================================================================*/ + +//HR: F +int main(int argc, char* argv[]){ + + // cout<<endl<<"Get K Best Parent sets"<<endl; + if (argc!=4){ + fprintf(stderr, "Usage: best_parents nof_vars dirname k\n"); + return 1; + } + + char str[32]; + int nof_vars = atoi(argv[1]); + int k = atoi(argv[3]); + + //strcpy(str,argv[2]); + + get_best_parents(nof_vars, argv[2],k); + + return 0; +} diff --git a/var_lib_genenet_bnw/k-best/src/varpar.o b/var_lib_genenet_bnw/k-best/src/varpar.o new file mode 100644 index 00000000..4fa1b165 --- /dev/null +++ b/var_lib_genenet_bnw/k-best/src/varpar.o Binary files differdiff --git a/var_lib_genenet_bnw/localscore/Applic.h b/var_lib_genenet_bnw/localscore/Applic.h new file mode 100644 index 00000000..0ae5e981 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/Applic.h @@ -0,0 +1,291 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 1998-2012 Robert Gentleman, Ross Ihaka + * and the R Core Team + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + * + * + * Application Routines, typically implemented in ../appl/ + * ---------------------------------------------- ======== + */ + +/* This header file contains routines which are in the R API and ones which + are not. + + Those which are not can be used only at the user's risk and may change + or disappear in a future release of R. +*/ + + +#ifndef R_APPLIC_H_ +#define R_APPLIC_H_ + +#include <R_ext/Boolean.h> +#include <R_ext/RS.h> /* F77_... */ +#include <R_ext/BLAS.h> + +#ifdef __cplusplus +extern "C" { +#endif + +/* Entry points in the R API */ + +/* appl/integrate.c */ +typedef void integr_fn(double *x, int n, void *ex); +/* vectorizing function f(x[1:n], ...) -> x[] {overwriting x[]}. */ + +void Rdqags(integr_fn f, void *ex, double *a, double *b, + double *epsabs, double *epsrel, + double *result, double *abserr, int *neval, int *ier, + int *limit, int *lenw, int *last, int *iwork, double *work); + +void Rdqagi(integr_fn f, void *ex, double *bound, int *inf, + double *epsabs, double *epsrel, + double *result, double *abserr, int *neval, int *ier, + int *limit, int *lenw, int *last, + int *iwork, double *work); + +/* main/optim.c */ +typedef double optimfn(int, double *, void *); +typedef void optimgr(int, double *, double *, void *); + +void vmmin(int n, double *b, double *Fmin, + optimfn fn, optimgr gr, int maxit, int trace, + int *mask, double abstol, double reltol, int nREPORT, + void *ex, int *fncount, int *grcount, int *fail); +void nmmin(int n, double *Bvec, double *X, double *Fmin, optimfn fn, + int *fail, double abstol, double intol, void *ex, + double alpha, double bet, double gamm, int trace, + int *fncount, int maxit); +void cgmin(int n, double *Bvec, double *X, double *Fmin, + optimfn fn, optimgr gr, + int *fail, double abstol, double intol, void *ex, + int type, int trace, int *fncount, int *grcount, int maxit); +void lbfgsb(int n, int m, double *x, double *l, double *u, int *nbd, + double *Fmin, optimfn fn, optimgr gr, int *fail, void *ex, + double factr, double pgtol, int *fncount, int *grcount, + int maxit, char *msg, int trace, int nREPORT); +void samin(int n, double *pb, double *yb, optimfn fn, int maxit, + int tmax, double ti, int trace, void *ex); + + + +/* Entry points NOT in the R API */ + +/* appl/bakslv.c : hidden */ +void bakslv(double *, int *, int *, + double *, int *, int *, + double *, int *, int *); + +/* appl/binning.c : hidden */ +void bincode (double *x, int *n, double *breaks, int *nb, + int *code, int *right, int *include_border, int *naok); +void bincount(double *x, int *n, double *breaks, int *nb, int *count, + int *right, int *include_border, int *naok); + +/* appl/ch2inv.f */ +void F77_NAME(ch2inv)(double *x, int *ldx, int *n, double *v, int *info); + +/* appl/chol.f Used in nlme */ +void F77_NAME(chol)(double *a, int *lda, int *n, double *v, int *info); + +/* appl/cpoly.c : hidden */ +void R_cpolyroot(double *opr, double *opi, int *degree, + double *zeror, double *zeroi, Rboolean *fail); +/* More `Complex Polynomial Utilities' could be exported: + + polyev(...) + errev(...) + cpoly_cauchy(...) + cpoly_scale(...) + cdivid(...) +*/ + + +/* appl/cumsum.c : non-API, used in package DCluster */ +void R_cumsum(double *, int *, double *, double *); + +/* appl/eigen.f */ +int F77_NAME(cg)(int *nm, int *n, double *ar, double *ai, + double *wr, double *wi, int *matz, double *zr, double *zi, + double *fv1, double *fv2, double *fv3, int *ierr); +int F77_NAME(ch)(int *nm, int *n, double *ar, double *ai, + double *w, int *matz, double *zr, double *zi, + double *fv1, double *fv2, double *fm1, int *ierr); +int F77_NAME(rg)(int *nm, int *n, double *a, double *wr, double *wi, + int *matz, double *z, int *iv1, double *fv1, int *ierr); +/* used in nlme */ +int F77_NAME(rs)(int *nm, int *n, double *a, double *w, + int *matz, double *z, double *fv1, double *fv2, int *ierr); + +/* appl/fft.c */ +/* NOTE: The following functions use GLOBAL (static) variables !! + * ---- some of R-core think that this should be changed, + * which will INEVITABLY extend the argument lists ...! + */ +/* non-API, but used by package RandomFields */ +void fft_factor(int n, int *pmaxf, int *pmaxp); +Rboolean fft_work(double *a, double *b, int nseg, int n, int nspn, +/* TRUE: success */ int isn, double *work, int *iwork); + +/* appl/fmin.c : */ +double Brent_fmin(double ax, double bx, double (*f)(double, void *), + void *info, double tol); + +/* appl/interv.c: also in Utils.h */ +/* used in packages gam and mda */ +int F77_SUB(interv)(double *xt, int *n, double *x, + Rboolean *rightmost_closed, Rboolean *all_inside, + int *ilo, int *mflag); +/* Non-API No longer used */ +void find_interv_vec(double *xt, int *n, double *x, int *nx, + int *rightmost_closed, int *all_inside, int *indx); +/* API, used in package eco */ +int findInterval(double *xt, int n, double x, + Rboolean rightmost_closed, Rboolean all_inside, int ilo, + int *mflag); + +/* appl/lbfgsb.c */ +void setulb(int n, int m, double *x, double *l, double *u, int *nbd, + double *f, double *g, double factr, double *pgtol, + double *wa, int * iwa, char *task, int iprint, + int *lsave, int *isave, double *dsave); + +/* appl/machar.c */ +void machar(int *ibeta, int *it, int *irnd, int *ngrd, int *machep, + int *negep, int *iexp, int *minexp, int *maxexp, + double *eps, double *epsneg, double *xmin, double *xmax); + +/* appl/maxcol.c: also in Utils.h Used in package MNP */ +void R_max_col(double *matrix, int *nr, int *nc, int *maxes, int *ties_meth); + + +/* appl/pretty.c */ +double R_pretty0(double *lo, double *up, int *ndiv, int min_n, + double shrink_sml, double high_u_fact[], + int eps_correction, int return_bounds); +void R_pretty(double *lo, double *up, int *ndiv, int *min_n, + double *shrink_sml, double *high_u_fact, + int *eps_correction); + +/* appl/rcont.c: API prior to R 2.15.2 */ +void rcont2(int *nrow, int *ncol, int *nrowt, int *ncolt, int *ntotal, + double *fact, int *jwork, int *matrix); + +/* appl/rowsum.c */ +void R_rowsum(int *dim, double *na_x, double *x, double *group); + +/* appl/stem.c */ +Rboolean stemleaf(double *x, int *n, double *scale, int *width, double *atom); + +/* appl/strsignif.c */ +void str_signif(char *x, int *n, const char **type, int *width, int *digits, + const char **format, const char **flag, char **result); + +/* appl/tabulate.c : non-API, used in package ape, phangorn, pcaPA */ +void R_tabulate(int *x, int *n, int *nbin, int *ans); + +/* appl/uncmin.c : */ + +/* type of pointer to the target and gradient functions */ +typedef void (*fcn_p)(int, double *, double *, void *); + +/* type of pointer to the hessian functions */ +typedef void (*d2fcn_p)(int, int, double *, double *, void *); + +void fdhess(int n, double *x, double fval, fcn_p fun, void *state, + double *h, int nfd, double *step, double *f, int ndigit, + double *typx); + +/* used in nlme */ +void optif9(int nr, int n, double *x, + fcn_p fcn, fcn_p d1fcn, d2fcn_p d2fcn, + void *state, double *typsiz, double fscale, int method, + int iexp, int *msg, int ndigit, int itnlim, int iagflg, + int iahflg, double dlt, double gradtl, double stepmx, + double steptl, double *xpls, double *fpls, double *gpls, + int *itrmcd, double *a, double *wrk, int *itncnt); + +void optif0(int nr, int n, double *x, fcn_p fcn, void *state, + double *xpls, double *fpls, double *gpls, int *itrmcd, + double *a, double *wrk); + +/* appl/zeroin.c : non API, but used in package qtl */ +double R_zeroin(double ax, double bx, double (*f)(double, void *), void *info, + double *Tol, int *Maxit); +/* R_zeroin2() is faster for "expensive" f(), in those typical cases where + * f(ax) and f(bx) are available anyway : */ +double R_zeroin2(double ax, double bx, double fa, double fb, + double (*f)(double, void *), void *info, double *Tol, int *Maxit); + + +/* ALL appl/<foobar>.f [semi-automatically by + * f2c -A -P *.f; cat *.P > all.h and editing] + */ + +/* This is not in the applications but in the BLAS, and defined in Lapack.h +extern int F77_NAME(lsame)(const char *, const char *); +*/ + +/* LINPACK routines also declared in Linpack.h +void F77_NAME(dpoco)(double *a, int *lda, int *n, double *rcond, + double *z__, int *info); +void F77_NAME(dpodi)(double *a, int *lda, int *n, double *det, int *job); +void F77_NAME(dpofa)(double *a, int *lda, int *n, int *info); +void F77_NAME(dposl)(double *a, int *lda, int *n, double *b); +void F77_NAME(dqrdc)(double *x, int *ldx, int *n, int *p, + double *qraux, int *jpvt, double *work, int *job); +void F77_NAME(dqrsl)(double *x, int *ldx, int *n, int *k, + double *qraux, double *y, + double *qy, double *qty, double *b, + double *rsd, double *xb, int *job, int *info); +void F77_NAME(dsvdc)(double *x, int *ldx, int *n, int *p, + double *s, double *e, + double *u, int *ldu, double *v, int *ldv, + double *work, int *job, int *info); +void F77_NAME(dtrco)(double *t, int *ldt, int *n, double *rcond, + double *z__, int *job); +void F77_NAME(dtrsl)(double *t, int *ldt, int *n, double *b, int *job, + int *info); +*/ + +/* find qr decomposition, dqrdc2() is basis of R's qr(), also used by nlme */ +void F77_NAME(dqrdc2)(double *x, int *ldx, int *n, int *p, + double *tol, int *rank, + double *qraux, int *pivot, double *work); +void F77_NAME(dqrls)(double *x, int *n, int *p, double *y, int *ny, + double *tol, double *b, double *rsd, + double *qty, int *k, + int *jpvt, double *qraux, double *work); + +/* appl/dqrutl.f: interfaces to dqrsl */ +void F77_NAME(dqrqty)(double *x, int *n, int *k, double *qraux, + double *y, int *ny, double *qty); +void F77_NAME(dqrqy)(double *x, int *n, int *k, double *qraux, + double *y, int *ny, double *qy); +void F77_NAME(dqrcf)(double *x, int *n, int *k, double *qraux, + double *y, int *ny, double *b, int *info); +void F77_NAME(dqrrsd)(double *x, int *n, int *k, double *qraux, + double *y, int *ny, double *rsd); +void F77_NAME(dqrxb)(double *x, int *n, int *k, double *qraux, + double *y, int *ny, double *xb); + + +#ifdef __cplusplus +} +#endif + +#endif /* R_APPLIC_H_ */ diff --git a/var_lib_genenet_bnw/localscore/Arith.h b/var_lib_genenet_bnw/localscore/Arith.h new file mode 100644 index 00000000..4a0030f1 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/Arith.h @@ -0,0 +1,87 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka + * Copyright (C) 1998--2007 The R Core Team. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +/* Included by R.h: API */ + +#ifndef R_ARITH_H_ +#define R_ARITH_H_ + +/* Only for use where config.h has not already been included */ +#if defined(HAVE_GLIBC2) && !defined(_BSD_SOURCE) +/* ensure that finite and isnan are declared */ +# define _BSD_SOURCE 1 +#endif + +#include "libextern.h" +#ifdef __cplusplus +extern "C" { +#elif !defined(NO_C_HEADERS) +/* needed for isnan and isfinite, neither of which are used under C++ */ +# include <math.h> +#endif + +/* implementation of these : ../../main/arithmetic.c */ +LibExtern double R_NaN; /* IEEE NaN */ +LibExtern double R_PosInf; /* IEEE Inf */ +LibExtern double R_NegInf; /* IEEE -Inf */ +LibExtern double R_NaReal; /* NA_REAL: IEEE */ +LibExtern int R_NaInt; /* NA_INTEGER:= INT_MIN currently */ +#ifdef __MAIN__ +#undef extern +#undef LibExtern +#endif + +#define NA_LOGICAL R_NaInt +#define NA_INTEGER R_NaInt +/* #define NA_FACTOR R_NaInt unused */ +#define NA_REAL R_NaReal +/* NA_STRING is a SEXP, so defined in Rinternals.h */ + +int R_IsNA(double); /* True for R's NA only */ +int R_IsNaN(double); /* True for special NaN, *not* for NA */ +int R_finite(double); /* True if none of NA, NaN, +/-Inf */ +#define ISNA(x) R_IsNA(x) + +/* ISNAN(): True for *both* NA and NaN. + NOTE: some systems do not return 1 for TRUE. + Also note that C++ math headers specifically undefine + isnan if it is a macro (it is on OS X and in C99), + hence the workaround. This code also appears in Rmath.h +*/ +#ifdef __cplusplus + int R_isnancpp(double); /* in arithmetic.c */ +# define ISNAN(x) R_isnancpp(x) +#else +# define ISNAN(x) (isnan(x)!=0) +#endif + +/* The following is only defined inside R */ +#ifdef HAVE_WORKING_ISFINITE +/* isfinite is defined in <math.h> according to C99 */ +# define R_FINITE(x) isfinite(x) +#else +# define R_FINITE(x) R_finite(x) +#endif + +#ifdef __cplusplus +} +#endif + +#endif /* R_ARITH_H_ */ diff --git a/var_lib_genenet_bnw/localscore/BLAS.h b/var_lib_genenet_bnw/localscore/BLAS.h new file mode 100644 index 00000000..98c192e9 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/BLAS.h @@ -0,0 +1,382 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 2003-12 The R Core Team. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +/* + C declarations of BLAS Fortran subroutines always available in R. + + Part of the API. + + R packages that use these should have PKG_LIBS in src/Makevars include + $(BLAS_LIBS) $(FLIBS) + */ + +/* Part of the API */ + +#ifndef R_BLAS_H +#define R_BLAS_H + +#include <R_ext/RS.h> /* for F77_... */ +#include <R_ext/Complex.h> /* for Rcomplex */ + +#ifdef __cplusplus +extern "C" { +#endif + +// never defined in R itself. +#ifndef BLAS_extern +#define BLAS_extern extern +#endif + +/* Double Precision Level 1 BLAS */ + +BLAS_extern double /* DASUM - sum of absolute values of a one-dimensional array */ +F77_NAME(dasum)(const int *n, const double *dx, const int *incx); +BLAS_extern void /* DAXPY - replace y by alpha*x + y */ +F77_NAME(daxpy)(const int *n, const double *alpha, + const double *dx, const int *incx, + double *dy, const int *incy); +BLAS_extern void /* DCOPY - copy x to y */ +F77_NAME(dcopy)(const int *n, const double *dx, const int *incx, + double *dy, const int *incy); +BLAS_extern double /* DDOT - inner product of x and y */ +F77_NAME(ddot)(const int *n, const double *dx, const int *incx, + const double *dy, const int *incy); +BLAS_extern double /* DNRM2 - 2-norm of a vector */ +F77_NAME(dnrm2)(const int *n, const double *dx, const int *incx); +BLAS_extern void /* DROT - apply a Given's rotation */ +F77_NAME(drot)(const int *n, double *dx, const int *incx, + double *dy, const int *incy, const double *c, const double *s); +BLAS_extern void /* DROTG - generate a Given's rotation */ +F77_NAME(drotg)(const double *a, const double *b, double *c, double *s); +BLAS_extern void /* DROTM - apply a modified Given's rotation */ +F77_NAME(drotm)(const int *n, double *dx, const int *incx, + double *dy, const int *incy, const double *dparam); +BLAS_extern void /* DROTMG - generate a modified Given's rotation */ +F77_NAME(drotmg)(const double *dd1, const double *dd2, const double *dx1, + const double *dy1, double *param); +BLAS_extern void /* DSCAL - scale a one-dimensional array */ +F77_NAME(dscal)(const int *n, const double *alpha, double *dx, const int *incx); +BLAS_extern void /* DSWAP - interchange one-dimensional arrays */ +F77_NAME(dswap)(const int *n, double *dx, const int *incx, + double *dy, const int *incy); +BLAS_extern int /* IDAMAX - return the index of the element with max abs value */ +F77_NAME(idamax)(const int *n, const double *dx, const int *incx); + +/* Double Precision Level 2 BLAS */ + +/* DGBMV - perform one of the matrix-vector operations */ +/* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, */ +BLAS_extern void +F77_NAME(dgbmv)(const char *trans, const int *m, const int *n, + const int *kl,const int *ku, + const double *alpha, const double *a, const int *lda, + const double *x, const int *incx, + const double *beta, double *y, const int *incy); +/* DGEMV - perform one of the matrix-vector operations */ +/* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, */ +BLAS_extern void +F77_NAME(dgemv)(const char *trans, const int *m, const int *n, + const double *alpha, const double *a, const int *lda, + const double *x, const int *incx, const double *beta, + double *y, const int *incy); +/* DSBMV - perform the matrix-vector operation */ +/* y := alpha*A*x + beta*y, */ +BLAS_extern void +F77_NAME(dsbmv)(const char *uplo, const int *n, const int *k, + const double *alpha, const double *a, const int *lda, + const double *x, const int *incx, + const double *beta, double *y, const int *incy); +/* DSPMV - perform the matrix-vector operation */ +/* y := alpha*A*x + beta*y, */ +BLAS_extern void +F77_NAME(dspmv)(const char *uplo, const int *n, + const double *alpha, const double *ap, + const double *x, const int *incx, + const double *beta, double *y, const int *incy); + +/* DSYMV - perform the matrix-vector operation */ +/* y := alpha*A*x + beta*y, */ +BLAS_extern void +F77_NAME(dsymv)(const char *uplo, const int *n, const double *alpha, + const double *a, const int *lda, + const double *x, const int *incx, + const double *beta, double *y, const int *incy); +/* DTBMV - perform one of the matrix-vector operations */ +/* x := A*x, or x := A'*x, */ +BLAS_extern void +F77_NAME(dtbmv)(const char *uplo, const char *trans, + const char *diag, const int *n, const int *k, + const double *a, const int *lda, + double *x, const int *incx); +/* DTPMV - perform one of the matrix-vector operations */ +/* x := A*x, or x := A'*x, */ +BLAS_extern void +F77_NAME(dtpmv)(const char *uplo, const char *trans, const char *diag, + const int *n, const double *ap, + double *x, const int *incx); +/* DTRMV - perform one of the matrix-vector operations */ +/* x := A*x, or x := A'*x, */ +BLAS_extern void +F77_NAME(dtrmv)(const char *uplo, const char *trans, const char *diag, + const int *n, const double *a, const int *lda, + double *x, const int *incx); +/* DTBSV - solve one of the systems of equations */ +/* A*x = b, or A'*x = b, */ +BLAS_extern void +F77_NAME(dtbsv)(const char *uplo, const char *trans, + const char *diag, const int *n, const int *k, + const double *a, const int *lda, + double *x, const int *incx); +/* DTPSV - solve one of the systems of equations */ +/* A*x = b, or A'*x = b, */ +BLAS_extern void +F77_NAME(dtpsv)(const char *uplo, const char *trans, + const char *diag, const int *n, + const double *ap, double *x, const int *incx); +/* DTRSV - solve one of the systems of equations */ +/* A*x = b, or A'*x = b, */ +BLAS_extern void +F77_NAME(dtrsv)(const char *uplo, const char *trans, + const char *diag, const int *n, + const double *a, const int *lda, + double *x, const int *incx); +/* DGER - perform the rank 1 operation A := alpha*x*y' + A */ +BLAS_extern void +F77_NAME(dger)(const int *m, const int *n, const double *alpha, + const double *x, const int *incx, + const double *y, const int *incy, + double *a, const int *lda); +/* DSYR - perform the symmetric rank 1 operation A := alpha*x*x' + A */ +BLAS_extern void +F77_NAME(dsyr)(const char *uplo, const int *n, const double *alpha, + const double *x, const int *incx, + double *a, const int *lda); +/* DSPR - perform the symmetric rank 1 operation A := alpha*x*x' + A */ +BLAS_extern void +F77_NAME(dspr)(const char *uplo, const int *n, const double *alpha, + const double *x, const int *incx, double *ap); +/* DSYR2 - perform the symmetric rank 2 operation */ +/* A := alpha*x*y' + alpha*y*x' + A, */ +BLAS_extern void +F77_NAME(dsyr2)(const char *uplo, const int *n, const double *alpha, + const double *x, const int *incx, + const double *y, const int *incy, + double *a, const int *lda); +/* DSPR2 - perform the symmetric rank 2 operation */ +/* A := alpha*x*y' + alpha*y*x' + A, */ +BLAS_extern void +F77_NAME(dspr2)(const char *uplo, const int *n, const double *alpha, + const double *x, const int *incx, + const double *y, const int *incy, double *ap); + +/* Double Precision Level 3 BLAS */ + +/* DGEMM - perform one of the matrix-matrix operations */ +/* C := alpha*op( A )*op( B ) + beta*C */ +BLAS_extern void +F77_NAME(dgemm)(const char *transa, const char *transb, const int *m, + const int *n, const int *k, const double *alpha, + const double *a, const int *lda, + const double *b, const int *ldb, + const double *beta, double *c, const int *ldc); +/* DTRSM - solve one of the matrix equations */ +/* op(A)*X = alpha*B, or X*op(A) = alpha*B */ +BLAS_extern void +F77_NAME(dtrsm)(const char *side, const char *uplo, + const char *transa, const char *diag, + const int *m, const int *n, const double *alpha, + const double *a, const int *lda, + double *b, const int *ldb); +/* DTRMM - perform one of the matrix-matrix operations */ +/* B := alpha*op( A )*B, or B := alpha*B*op( A ) */ +BLAS_extern void +F77_NAME(dtrmm)(const char *side, const char *uplo, const char *transa, + const char *diag, const int *m, const int *n, + const double *alpha, const double *a, const int *lda, + double *b, const int *ldb); +/* DSYMM - perform one of the matrix-matrix operations */ +/* C := alpha*A*B + beta*C, */ +BLAS_extern void +F77_NAME(dsymm)(const char *side, const char *uplo, const int *m, + const int *n, const double *alpha, + const double *a, const int *lda, + const double *b, const int *ldb, + const double *beta, double *c, const int *ldc); +/* DSYRK - perform one of the symmetric rank k operations */ +/* C := alpha*A*A' + beta*C or C := alpha*A'*A + beta*C */ +BLAS_extern void +F77_NAME(dsyrk)(const char *uplo, const char *trans, + const int *n, const int *k, + const double *alpha, const double *a, const int *lda, + const double *beta, double *c, const int *ldc); +/* DSYR2K - perform one of the symmetric rank 2k operations */ +/* C := alpha*A*B' + alpha*B*A' + beta*C or */ +/* C := alpha*A'*B + alpha*B'*A + beta*C */ +BLAS_extern void +F77_NAME(dsyr2k)(const char *uplo, const char *trans, + const int *n, const int *k, + const double *alpha, const double *a, const int *lda, + const double *b, const int *ldb, + const double *beta, double *c, const int *ldc); +/* + LSAME is a LAPACK support routine, not part of BLAS +*/ + +/* Double complex BLAS routines added for 2.3.0 */ +/* #ifdef HAVE_FORTRAN_DOUBLE_COMPLEX */ + BLAS_extern double + F77_NAME(dcabs1)(double *z); + BLAS_extern double + F77_NAME(dzasum)(int *n, Rcomplex *zx, int *incx); + BLAS_extern double + F77_NAME(dznrm2)(int *n, Rcomplex *x, int *incx); + BLAS_extern int + F77_NAME(izamax)(int *n, Rcomplex *zx, int *incx); + BLAS_extern void + F77_NAME(zaxpy)(int *n, Rcomplex *za, Rcomplex *zx, + int *incx, Rcomplex *zy, int *incy); + BLAS_extern void + F77_NAME(zcopy)(int *n, Rcomplex *zx, int *incx, + Rcomplex *zy, int *incy); + + /* WARNING! The next two return a value that may not be + compatible between C and Fortran, and even if it is, this might + not be the right translation to C. Only use after + configure-testing with your compilers. + */ + BLAS_extern Rcomplex + F77_NAME(zdotc)(int *n, + Rcomplex *zx, int *incx, Rcomplex *zy, int *incy); + BLAS_extern Rcomplex + F77_NAME(zdotu)(int *n, + Rcomplex *zx, int *incx, Rcomplex *zy, int *incy); + + BLAS_extern void + F77_NAME(zdrot)(int *n, Rcomplex *zx, int *incx, Rcomplex *zy, + int *incy, double *c, double *s); + BLAS_extern void + F77_NAME(zdscal)(int *n, double *da, Rcomplex *zx, int *incx); + BLAS_extern void + F77_NAME(zgbmv)(char *trans, int *m, int *n, int *kl, + int *ku, Rcomplex *alpha, Rcomplex *a, int *lda, + Rcomplex *x, int *incx, Rcomplex *beta, Rcomplex *y, + int *incy); + BLAS_extern void + F77_NAME(zgemm)(const char *transa, const char *transb, const int *m, + const int *n, const int *k, const Rcomplex *alpha, + const Rcomplex *a, const int *lda, + const Rcomplex *b, const int *ldb, + const Rcomplex *beta, Rcomplex *c, const int *ldc); + BLAS_extern void + F77_NAME(zgemv)(char *trans, int *m, int *n, Rcomplex *alpha, + Rcomplex *a, int *lda, Rcomplex *x, int *incx, + Rcomplex *beta, Rcomplex *y, int * incy); + BLAS_extern void + F77_NAME(zgerc)(int *m, int *n, Rcomplex *alpha, Rcomplex *x, + int *incx, Rcomplex *y, int *incy, Rcomplex *a, int *lda); + BLAS_extern void + F77_NAME(zgeru)(int *m, int *n, Rcomplex *alpha, Rcomplex *x, + int *incx, Rcomplex *y, int *incy, Rcomplex *a, int *lda); + BLAS_extern void + F77_NAME(zhbmv)(char *uplo, int *n, int *k, Rcomplex *alpha, + Rcomplex *a, int *lda, Rcomplex *x, int *incx, + Rcomplex *beta, Rcomplex *y, int *incy); + BLAS_extern void + F77_NAME(zhemm)(char *side, char *uplo, int *m, int *n, + Rcomplex *alpha, Rcomplex *a, int *lda, Rcomplex *b, + int *ldb, Rcomplex *beta, Rcomplex *c, int *ldc); + BLAS_extern void + F77_NAME(zhemv)(char *uplo, int *n, Rcomplex *alpha, Rcomplex *a, + int *lda, Rcomplex *x, int *incx, Rcomplex *beta, + Rcomplex *y, int *incy); + BLAS_extern void + F77_NAME(zher)(char *uplo, int *n, double *alpha, Rcomplex *x, + int *incx, Rcomplex *a, int *lda); + BLAS_extern void + F77_NAME(zher2)(char *uplo, int *n, Rcomplex *alpha, Rcomplex *x, + int *incx, Rcomplex *y, int *incy, Rcomplex *a, int *lda); + BLAS_extern void + F77_NAME(zher2k)(char *uplo, char *trans, int *n, int *k, + Rcomplex *alpha, Rcomplex *a, int *lda, Rcomplex *b, + int *ldb, double *beta, Rcomplex *c, int *ldc); + BLAS_extern void + F77_NAME(zherk)(char *uplo, char *trans, int *n, int *k, + double *alpha, Rcomplex *a, int *lda, double *beta, + Rcomplex *c, int *ldc); + BLAS_extern void + F77_NAME(zhpmv)(char *uplo, int *n, Rcomplex *alpha, Rcomplex *ap, + Rcomplex *x, int *incx, Rcomplex * beta, Rcomplex *y, + int *incy); + BLAS_extern void + F77_NAME(zhpr)(char *uplo, int *n, double *alpha, + Rcomplex *x, int *incx, Rcomplex *ap); + BLAS_extern void + F77_NAME(zhpr2)(char *uplo, int *n, Rcomplex *alpha, Rcomplex *x, + int *incx, Rcomplex *y, int *incy, Rcomplex *ap); + BLAS_extern void + F77_NAME(zrotg)(Rcomplex *ca, Rcomplex *cb, double *c, Rcomplex *s); + BLAS_extern void + F77_NAME(zscal)(int *n, Rcomplex *za, Rcomplex *zx, int *incx); + BLAS_extern void + F77_NAME(zswap)(int *n, Rcomplex *zx, int *incx, Rcomplex *zy, int *incy); + BLAS_extern void + F77_NAME(zsymm)(char *side, char *uplo, int *m, int *n, + Rcomplex *alpha, Rcomplex *a, int *lda, Rcomplex *b, + int *ldb, Rcomplex *beta, Rcomplex *c, int *ldc); + BLAS_extern void + F77_NAME(zsyr2k)(char *uplo, char *trans, int *n, int *k, + Rcomplex *alpha, Rcomplex *a, int *lda, Rcomplex *b, + int *ldb, Rcomplex *beta, Rcomplex *c, int *ldc); + BLAS_extern void + F77_NAME(zsyrk)(char *uplo, char *trans, int *n, int *k, + Rcomplex *alpha, Rcomplex *a, int *lda, + Rcomplex *beta, Rcomplex *c, int *ldc); + BLAS_extern void + F77_NAME(ztbmv)(char *uplo, char *trans, char *diag, int *n, int *k, + Rcomplex *a, int *lda, Rcomplex *x, int *incx); + BLAS_extern void + F77_NAME(ztbsv)(char *uplo, char *trans, char *diag, int *n, int *k, + Rcomplex *a, int *lda, Rcomplex *x, int *incx); + BLAS_extern void + F77_NAME(ztpmv)(char *uplo, char *trans, char *diag, int *n, + Rcomplex *ap, Rcomplex *x, int *incx); + BLAS_extern void + F77_NAME(ztpsv)(char *uplo, char *trans, char *diag, int *n, + Rcomplex *ap, Rcomplex *x, int *incx); + BLAS_extern void + F77_NAME(ztrmm)(char *side, char *uplo, char *transa, char *diag, + int *m, int *n, Rcomplex *alpha, Rcomplex *a, + int *lda, Rcomplex *b, int *ldb); + BLAS_extern void + F77_NAME(ztrmv)(char *uplo, char *trans, char *diag, int *n, + Rcomplex *a, int *lda, Rcomplex *x, int *incx); + BLAS_extern void + F77_NAME(ztrsm)(char *side, char *uplo, char *transa, char *diag, + int *m, int *n, Rcomplex *alpha, Rcomplex *a, + int *lda, Rcomplex *b, int *ldb); + BLAS_extern void + F77_NAME(ztrsv)(char *uplo, char *trans, char *diag, int *n, + Rcomplex *a, int *lda, Rcomplex *x, int *incx); +/* #endif */ + +#ifdef __cplusplus +} +#endif + +#endif /* R_BLAS_H */ diff --git a/var_lib_genenet_bnw/localscore/Boolean.h b/var_lib_genenet_bnw/localscore/Boolean.h new file mode 100644 index 00000000..ea855a29 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/Boolean.h @@ -0,0 +1,37 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 2000, 2001 The R Core Team. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +/* Included by R.h: API */ + +#ifndef R_EXT_BOOLEAN_H_ +#define R_EXT_BOOLEAN_H_ + +#undef FALSE +#undef TRUE + +#ifdef __cplusplus +extern "C" { +#endif +typedef enum { FALSE = 0, TRUE /*, MAYBE */ } Rboolean; + +#ifdef __cplusplus +} +#endif + +#endif /* R_EXT_BOOLEAN_H_ */ diff --git a/var_lib_genenet_bnw/localscore/Callbacks.h b/var_lib_genenet_bnw/localscore/Callbacks.h new file mode 100644 index 00000000..cb1d64ca --- /dev/null +++ b/var_lib_genenet_bnw/localscore/Callbacks.h @@ -0,0 +1,116 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 2001-2 The R Core Team. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +/* + Not part of the API, subject to change at any time. +*/ + +#ifndef R_CALLBACKS_H +#define R_CALLBACKS_H + +/** + These structures are for C (and R function) top-level task handlers. + Such routines are called at the end of every (successful) top-level task + in the regular REPL. + */ + +#include <Rinternals.h> +/** + The signature of the C routine that a callback must implement. + expr - the expression for the top-level task that was evaluated. + value - the result of the top-level task, i.e. evaluating expr. + succeeded - a logical value indicating whether the task completed propertly. + visible - a logical value indicating whether the result was printed to the R ``console''/stdout. + data - user-level data passed to the registration routine. + */ +typedef Rboolean (*R_ToplevelCallback)(SEXP expr, SEXP value, Rboolean succeeded, Rboolean visible, void *); + +typedef struct _ToplevelCallback R_ToplevelCallbackEl; +/** + Linked list element for storing the top-level task callbacks. + */ +struct _ToplevelCallback { + R_ToplevelCallback cb; /* the C routine to call. */ + void *data; /* the user-level data to pass to the call to cb() */ + void (*finalizer)(void *data); /* Called when the callback is removed. */ + + char *name; /* a name by which to identify this element. */ + + R_ToplevelCallbackEl *next; /* the next element in the linked list. */ +}; + +#ifdef __cplusplus +extern "C" { +#endif + +Rboolean Rf_removeTaskCallbackByIndex(int id); +Rboolean Rf_removeTaskCallbackByName(const char *name); +SEXP R_removeTaskCallback(SEXP which); +R_ToplevelCallbackEl* Rf_addTaskCallback(R_ToplevelCallback cb, void *data, void (*finalizer)(void *), const char *name, int *pos); + + + +/* + The following definitions are for callbacks to R functions and + methods related to user-level tables. This was implemented in a + separate package on Omegahat and these declarations allow the package + to interface to the internal R code. + + See http://developer.r-project.org/RObjectTables.pdf, + http://www.omegahat.org/RObjectTables/ +*/ + +typedef struct _R_ObjectTable R_ObjectTable; + +/* Do we actually need the exists() since it is never called but R + uses get to see if the symbol is bound to anything? */ +typedef Rboolean (*Rdb_exists)(const char * const name, Rboolean *canCache, R_ObjectTable *); +typedef SEXP (*Rdb_get)(const char * const name, Rboolean *canCache, R_ObjectTable *); +typedef int (*Rdb_remove)(const char * const name, R_ObjectTable *); +typedef SEXP (*Rdb_assign)(const char * const name, SEXP value, R_ObjectTable *); +typedef SEXP (*Rdb_objects)(R_ObjectTable *); +typedef Rboolean (*Rdb_canCache)(const char * const name, R_ObjectTable *); + +typedef void (*Rdb_onDetach)(R_ObjectTable *); +typedef void (*Rdb_onAttach)(R_ObjectTable *); + +struct _R_ObjectTable{ + int type; + char **cachedNames; + Rboolean active; + + Rdb_exists exists; + Rdb_get get; + Rdb_remove remove; + Rdb_assign assign; + Rdb_objects objects; + Rdb_canCache canCache; + + Rdb_onDetach onDetach; + Rdb_onAttach onAttach; + + void *privateData; +}; + + +#ifdef __cplusplus +} +#endif + +#endif /* R_CALLBACKS_H */ diff --git a/var_lib_genenet_bnw/localscore/Complex.h b/var_lib_genenet_bnw/localscore/Complex.h new file mode 100644 index 00000000..06417a71 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/Complex.h @@ -0,0 +1,38 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 1998-2001 The R Core Team + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +/* Included by R.h: API */ + +#ifndef R_COMPLEX_H +#define R_COMPLEX_H + +#ifdef __cplusplus +extern "C" { +#endif + +typedef struct { + double r; + double i; +} Rcomplex; + +#ifdef __cplusplus +} +#endif + +#endif /* R_COMPLEX_H */ diff --git a/var_lib_genenet_bnw/localscore/Constants.h b/var_lib_genenet_bnw/localscore/Constants.h new file mode 100644 index 00000000..08e3d158 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/Constants.h @@ -0,0 +1,44 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka + * Copyright (C) 1998-2012 The R Core Team. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +/* Included by R.h: API */ + +#ifndef R_EXT_CONSTANTS_H_ +#define R_EXT_CONSTANTS_H_ + +/* usually in math.h, but not with strict C99 compliance */ +#ifndef M_PI +#define M_PI 3.141592653589793238462643383279502884197169399375 +#endif + +#ifndef STRICT_R_HEADERS +#define PI M_PI +#include <float.h> /* Defines the rest, at least in C99 */ +#define SINGLE_EPS FLT_EPSILON +#define SINGLE_BASE FLT_RADIX +#define SINGLE_XMIN FLT_MIN +#define SINGLE_XMAX FLT_MAX +#define DOUBLE_DIGITS DBL_MANT_DIG +#define DOUBLE_EPS DBL_EPSILON +#define DOUBLE_XMAX DBL_MAX +#define DOUBLE_XMIN DBL_MIN +#endif + +#endif /* R_EXT_CONSTANTS_H_ */ diff --git a/var_lib_genenet_bnw/localscore/Error.h b/var_lib_genenet_bnw/localscore/Error.h new file mode 100644 index 00000000..1a8905c6 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/Error.h @@ -0,0 +1,46 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 1998-2005 The R Core Team + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +/* Included by R.h: API */ + +#ifndef R_ERROR_H_ +#define R_ERROR_H_ + +#ifdef __cplusplus +extern "C" { +#endif + +void Rf_error(const char *, ...); +void Rf_warning(const char *, ...); +void WrongArgCount(const char *); +void UNIMPLEMENTED(const char *); +void R_ShowMessage(const char *s); + + +#ifdef __cplusplus +} +#endif + +#ifndef R_NO_REMAP +#define error Rf_error +#define warning Rf_warning +#endif + + +#endif /* R_ERROR_H_ */ diff --git a/var_lib_genenet_bnw/localscore/GetX11Image.h b/var_lib_genenet_bnw/localscore/GetX11Image.h new file mode 100644 index 00000000..a7181fa3 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/GetX11Image.h @@ -0,0 +1,36 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 2003 R Core Team + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +#ifndef GETX11IMAGE_H_ +#define GETX11IMAGE_H_ + +#ifdef __cplusplus +extern "C" { +#endif + +/* used by package tkrplot */ + +Rboolean R_GetX11Image(int d, void *pximage, int *pwidth, int *pheight); +/* pximage is really (XImage **) */ + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/var_lib_genenet_bnw/localscore/GraphicsDevice.h b/var_lib_genenet_bnw/localscore/GraphicsDevice.h new file mode 100644 index 00000000..10851b26 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/GraphicsDevice.h @@ -0,0 +1,863 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 2001-11 The R Core Team. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +/* Used by third-party graphics devices. + * + * This defines DevDesc, whereas GraphicsEngine.h defines GEDevDesc. + * Also contains entry points from gevents.c + */ + +#ifndef R_GRAPHICSDEVICE_H_ +#define R_GRAPHICSDEVICE_H_ + + +/* ideally we would use prototypes in DevDesc. + Some devices have taken to passing pointers to their own structure + instead of DevDesc* , defining R_USE_PROTOTYPES 0 allows them to + opt out. +*/ + +#ifndef R_USE_PROTOTYPES +# define R_USE_PROTOTYPES 1 +# ifndef R_GRAPHICSENGINE_H_ +# error R_ext/GraphicsEngine.h must be included first, and includes this header +# endif +#endif + +#include <R_ext/Boolean.h> + +#ifdef __cplusplus +extern "C" { +#endif + +/* --------- New (in 1.4.0) device driver structure --------- + * NOTES: + * 1. All locations and dimensions are in device coordinates. + * 2. I found this comment in the doc for dev_Open -- looks nasty + * Any known instances of such a thing happening? Should be + * replaced by a function to query the device for preferred gpars + * settings? (to be called when the device is initialised) + * + * NOTE that it is perfectly acceptable for this + * function to set generic graphics parameters too + * (i.e., override the generic parameter settings + * which GInit sets up) all at the author's own risk + * of course :) + * + * 3. Do we really need dev_StrWidth as well as dev_MetricInfo? + * I can see the difference between the two -- its just a + * question of whether dev_MetricInfo should just return + * what dev_StrWidth would give if font metric information is + * not available. I guess having both allows the developer + * to decide when to ask for which sort of value, and to decide + * what to do when font metric information is not available. + * And why not a dev_StrHeight? + * 4. Should "ipr", "asp", and "cra" be in the device description? + * If not, then where? + * I guess they don't need to be if no device makes use of them. + * On the other hand, they would need to be replaced by a device + * call that R base graphics could use to get enough information + * to figure them out. (e.g., some sort of dpi() function to + * complement the size() function.) + */ + +typedef struct _DevDesc DevDesc; +typedef DevDesc* pDevDesc; + +struct _DevDesc { + /******************************************************** + * Device physical characteristics + ********************************************************/ + double left; /* left raster coordinate */ + double right; /* right raster coordinate */ + double bottom; /* bottom raster coordinate */ + double top; /* top raster coordinate */ + /* R only has the notion of a rectangular clipping region + */ + double clipLeft; + double clipRight; + double clipBottom; + double clipTop; + /* I hate these next three -- they seem like a real fudge + * BUT I'm not sure what to replace them with so they stay for now. + */ + double xCharOffset; /* x character addressing offset - unused */ + double yCharOffset; /* y character addressing offset */ + double yLineBias; /* 1/2 interline space as frac of line height */ + double ipr[2]; /* Inches per raster; [0]=x, [1]=y */ + /* I hate this guy too -- seems to assume that a device can only + * have one font size during its lifetime + * BUT removing/replacing it would take quite a lot of work + * to design and insert a good replacement so it stays for now. + */ + double cra[2]; /* Character size in rasters; [0]=x, [1]=y */ + double gamma; /* (initial) Device Gamma Correction */ + /******************************************************** + * Device capabilities + ********************************************************/ + Rboolean canClip; /* Device-level clipping */ + Rboolean canChangeGamma; /* can the gamma factor be modified? */ + int canHAdj; /* Can do at least some horiz adjust of text + 0 = none, 1 = {0,0.5,1}, 2 = [0,1] */ + /******************************************************** + * Device initial settings + ********************************************************/ + /* These are things that the device must set up when it is created. + * The graphics system can modify them and track current values, + */ + double startps; + int startcol; /* sets par("fg"), par("col") and gpar("col") */ + int startfill; /* sets par("bg") and gpar("fill") */ + int startlty; + int startfont; + double startgamma; + /******************************************************** + * Device specific information + ********************************************************/ + void *deviceSpecific; /* pointer to device specific parameters */ + /******************************************************** + * Device display list + ********************************************************/ + Rboolean displayListOn; /* toggle for initial display list status */ + + + /******************************************************** + * Event handling entries + ********************************************************/ + + /* Used in do_setGraphicsEventEnv */ + + Rboolean canGenMouseDown; /* can the device generate mousedown events */ + Rboolean canGenMouseMove; /* can the device generate mousemove events */ + Rboolean canGenMouseUp; /* can the device generate mouseup events */ + Rboolean canGenKeybd; /* can the device generate keyboard events */ + + Rboolean gettingEvent; /* This is set while getGraphicsEvent + is actively looking for events */ + + /******************************************************** + * Device procedures. + ********************************************************/ + + /* + * --------------------------------------- + * GENERAL COMMENT ON GRAPHICS PARAMETERS: + * --------------------------------------- + * Graphical parameters are now passed in a pointer to a + * graphics context structure (pGEcontext) rather than individually. + * Each device action should extract the parameters it needs + * and ignore the others. Thought should be given to which + * parameters are relevant in each case -- the graphics engine + * does not REQUIRE that each parameter is honoured, but if + * a parameter is NOT honoured, it might be a good idea to + * issue a warning when a parameter is not honoured (or at + * the very least document which parameters are not honoured + * in the user-level documentation for the device). [An example + * of a parameter that may not be honoured by many devices is + * transparency.] + */ + + /* + * device_Activate is called when a device becomes the + * active device. For example, it can be used to change the + * title of a window to indicate the active status of + * the device to the user. Not all device types will + * do anything. + * The only parameter is a device driver structure. + * An example is ... + * + * static void X11_Activate(pDevDesc dd); + * + * As from R 2.14.0 this can be omitted or set to NULL. + */ +#if R_USE_PROTOTYPES + void (*activate)(const pDevDesc ); +#else + void (*activate)(); +#endif + /* + * device_Circle should have the side-effect that a + * circle is drawn, centred at the given location, with + * the given radius. + * (If the device has non-square pixels, 'radius' should + * be interpreted in the units of the x direction.) + * The border of the circle should be + * drawn in the given "col", and the circle should be + * filled with the given "fill" colour. + * If "col" is NA_INTEGER then no border should be drawn + * If "fill" is NA_INTEGER then the circle should not + * be filled. + * An example is ... + * + * static void X11_Circle(double x, double y, double r, + * pGEcontext gc, + * pDevDesc dd); + * + * R_GE_gcontext parameters that should be honoured (if possible): + * col, fill, gamma, lty, lwd + */ +#if R_USE_PROTOTYPES + void (*circle)(double x, double y, double r, const pGEcontext gc, pDevDesc dd); +#else + void (*circle)(); +#endif + /* + * device_Clip is given the left, right, bottom, and + * top of a rectangle (in DEVICE coordinates). + * It should have the side-effect that subsequent output + * is clipped to the given rectangle. + * NOTE that R's graphics engine already clips to the + * extent of the device. + * NOTE also that this will probably only be called if + * the flag canClip is true. + * An example is ... + * + * static void X11_Clip(double x0, double x1, double y0, double y1, + * pDevDesc dd) + */ +#if R_USE_PROTOTYPES + void (*clip)(double x0, double x1, double y0, double y1, pDevDesc dd); +#else + void (*clip)(); +#endif + /* + * device_Close is called when the device is killed. + * This function is responsible for destroying any + * device-specific resources that were created in + * device_Open and for FREEing the device-specific + * parameters structure. + * An example is ... + * + * static void X11_Close(pDevDesc dd) + * + */ +#if R_USE_PROTOTYPES + void (*close)(pDevDesc dd); +#else + void (*close)(); +#endif + /* + * device_Deactivate is called when a device becomes + * inactive. + * This allows the device to undo anything it did in + * dev_Activate. + * Not all device types will do anything. + * An example is ... + * + * static void X11_Deactivate(pDevDesc dd) + * + * As from R 2.14.0 this can be omitted or set to NULL. + */ +#if R_USE_PROTOTYPES + void (*deactivate)(pDevDesc ); +#else + void (*deactivate)(); +#endif + + + /* + * device_Locator should return the location of the next + * mouse click (in DEVICE coordinates) + * Not all devices will do anything (e.g., postscript) + * An example is ... + * + * static Rboolean X11_Locator(double *x, double *y, pDevDesc dd) + * + * As from R 2.14.0 this can be omitted or set to NULL. + */ +#if R_USE_PROTOTYPES + Rboolean (*locator)(double *x, double *y, pDevDesc dd); +#else + Rboolean (*locator)(); +#endif + /* + * device_Line should have the side-effect that a single + * line is drawn (from x1,y1 to x2,y2) + * An example is ... + * + * static void X11_Line(double x1, double y1, double x2, double y2, + * const pGEcontext gc, + * pDevDesc dd); + * + * R_GE_gcontext parameters that should be honoured (if possible): + * col, gamma, lty, lwd + */ +#if R_USE_PROTOTYPES + void (*line)(double x1, double y1, double x2, double y2, + const pGEcontext gc, pDevDesc dd); +#else + void (*line)(); +#endif + /* + * device_MetricInfo should return height, depth, and + * width information for the given character in DEVICE + * units. + * Note: in an 8-bit locale, c is 'char'. + * In an mbcslocale, it is wchar_t, and at least some + * of code assumes that is UCS-2 (Windows, true) or UCS-4. + * This is used for formatting mathematical expressions + * and for exact centering of text (see GText) + * If the device cannot provide metric information then + * it MUST return 0.0 for ascent, descent, and width. + * An example is ... + * + * static void X11_MetricInfo(int c, + * const pGEcontext gc, + * double* ascent, double* descent, + * double* width, pDevDesc dd); + * + * R_GE_gcontext parameters that should be honoured (if possible): + * font, cex, ps + */ +#if R_USE_PROTOTYPES + void (*metricInfo)(int c, const pGEcontext gc, + double* ascent, double* descent, double* width, + pDevDesc dd); +#else + void (*metricInfo)(); +#endif + /* + * device_Mode is called whenever the graphics engine + * starts drawing (mode=1) or stops drawing (mode=0) + * GMode (in graphics.c) also says that + * mode = 2 (graphical input on) exists. + * The device is not required to do anything + * An example is ... + * + * static void X11_Mode(int mode, pDevDesc dd); + * + * As from R 2.14.0 this can be omitted or set to NULL. + */ +#if R_USE_PROTOTYPES + void (*mode)(int mode, pDevDesc dd); +#else + void (*mode)(); +#endif + /* + * device_NewPage is called whenever a new plot requires + * a new page. + * A new page might mean just clearing the + * device (e.g., X11) or moving to a new page + * (e.g., postscript) + * An example is ... + * + * + * static void X11_NewPage(const pGEcontext gc, + * pDevDesc dd); + * + */ +#if R_USE_PROTOTYPES + void (*newPage)(const pGEcontext gc, pDevDesc dd); +#else + void (*newPage)(); +#endif + /* + * device_Polygon should have the side-effect that a + * polygon is drawn using the given x and y values + * the polygon border should be drawn in the "col" + * colour and filled with the "fill" colour. + * If "col" is NA_INTEGER don't draw the border + * If "fill" is NA_INTEGER don't fill the polygon + * An example is ... + * + * static void X11_Polygon(int n, double *x, double *y, + * const pGEcontext gc, + * pDevDesc dd); + * + * R_GE_gcontext parameters that should be honoured (if possible): + * col, fill, gamma, lty, lwd + */ +#if R_USE_PROTOTYPES + void (*polygon)(int n, double *x, double *y, const pGEcontext gc, pDevDesc dd); +#else + void (*polygon)(); +#endif + /* + * device_Polyline should have the side-effect that a + * series of line segments are drawn using the given x + * and y values. + * An example is ... + * + * static void X11_Polyline(int n, double *x, double *y, + * const pGEcontext gc, + * pDevDesc dd); + * + * R_GE_gcontext parameters that should be honoured (if possible): + * col, gamma, lty, lwd + */ +#if R_USE_PROTOTYPES + void (*polyline)(int n, double *x, double *y, const pGEcontext gc, pDevDesc dd); +#else + void (*polyline)(); +#endif + /* + * device_Rect should have the side-effect that a + * rectangle is drawn with the given locations for its + * opposite corners. The border of the rectangle + * should be in the given "col" colour and the rectangle + * should be filled with the given "fill" colour. + * If "col" is NA_INTEGER then no border should be drawn + * If "fill" is NA_INTEGER then the rectangle should not + * be filled. + * An example is ... + * + * static void X11_Rect(double x0, double y0, double x1, double y1, + * const pGEcontext gc, + * pDevDesc dd); + * + */ +#if R_USE_PROTOTYPES + void (*rect)(double x0, double y0, double x1, double y1, + const pGEcontext gc, pDevDesc dd); +#else + void (*rect)(); +#endif + /* + * device_Path should draw one or more sets of points + * as a single path + * + * 'x' and 'y' give the points + * + * 'npoly' gives the number of polygons in the path + * MUST be at least 1 + * + * 'nper' gives the number of points in each polygon + * each value MUST be at least 2 + * + * 'winding' says whether to fill using the nonzero + * winding rule or the even-odd rule + * + * Added 2010-06-27 + * + * As from R 2.13.2 this can be left unimplemented as NULL. + */ +#if R_USE_PROTOTYPES + void (*path)(double *x, double *y, + int npoly, int *nper, + Rboolean winding, + const pGEcontext gc, pDevDesc dd); +#else + void (*path)(); +#endif + /* + * device_Raster should draw a raster image justified + * at the given location, + * size, and rotation (not all devices may be able to rotate?) + * + * 'raster' gives the image data BY ROW, with every four bytes + * giving one R colour (ABGR). + * + * 'x and 'y' give the bottom-left corner. + * + * 'rot' is in degrees (as per device_Text), with positive + * rotation anticlockwise from the positive x-axis. + * + * As from R 2.13.2 this can be left unimplemented as NULL. + */ +#if R_USE_PROTOTYPES + void (*raster)(unsigned int *raster, int w, int h, + double x, double y, + double width, double height, + double rot, + Rboolean interpolate, + const pGEcontext gc, pDevDesc dd); +#else + void (*raster)(); +#endif + /* + * device_Cap should return an integer matrix (R colors) + * representing the current contents of the device display. + * + * The result is expected to be ROW FIRST. + * + * This will only make sense for raster devices and can + * probably only be implemented for screen devices. + * + * added 2010-06-27 + * + * As from R 2.13.2 this can be left unimplemented as NULL. + * For earlier versions of R it should return R_NilValue. + */ +#if R_USE_PROTOTYPES + SEXP (*cap)(pDevDesc dd); +#else + SEXP (*cap)(); +#endif + /* + * device_Size is called whenever the device is + * resized. + * The function returns (left, right, bottom, and top) for the + * new device size. + * This is not usually called directly by the graphics + * engine because the detection of device resizes + * (e.g., a window resize) are usually detected by + * device-specific code. + * An example is ... + * + * static void X11_Size(double *left, double *right, + * double *bottom, double *top, + * pDevDesc dd); + * + * R_GE_gcontext parameters that should be honoured (if possible): + * col, fill, gamma, lty, lwd + * + * As from R 2.13.2 this can be left unimplemented as NULL. + */ +#if R_USE_PROTOTYPES + void (*size)(double *left, double *right, double *bottom, double *top, + pDevDesc dd); +#else + void (*size)(); +#endif + /* + * device_StrWidth should return the width of the given + * string in DEVICE units. + * An example is ... + * + * static double X11_StrWidth(const char *str, + * const pGEcontext gc, + * pDevDesc dd) + * + * R_GE_gcontext parameters that should be honoured (if possible): + * font, cex, ps + */ +#if R_USE_PROTOTYPES + double (*strWidth)(const char *str, const pGEcontext gc, pDevDesc dd); +#else + double (*strWidth)(); +#endif + /* + * device_Text should have the side-effect that the + * given text is drawn at the given location. + * The text should be rotated according to rot (degrees) + * An example is ... + * + * static void X11_Text(double x, double y, const char *str, + * double rot, double hadj, + * const pGEcontext gc, + * pDevDesc dd); + * + * R_GE_gcontext parameters that should be honoured (if possible): + * font, cex, ps, col, gamma + */ +#if R_USE_PROTOTYPES + void (*text)(double x, double y, const char *str, double rot, + double hadj, const pGEcontext gc, pDevDesc dd); +#else + void (*text)(); +#endif + /* + * device_onExit is called by GEonExit when the user has aborted + * some operation, and so an R_ProcessEvents call may not return normally. + * It need not be set to any value; if null, it will not be called. + * + * An example is ... + * + * static void GA_onExit(pDevDesc dd); + */ +#if R_USE_PROTOTYPES + void (*onExit)(pDevDesc dd); +#else + void (*onExit)(); +#endif + /* + * device_getEvent is no longer used, but the slot is kept for back + * compatibility of the structure. + */ + SEXP (*getEvent)(SEXP, const char *); + + /* --------- Optional features introduced in 2.7.0 --------- */ + + /* Does the device have a device-specific way to confirm a + new frame (for e.g. par(ask=TRUE))? + This should be NULL if it does not. + If it does, it returns TRUE if the device handled this, and + FALSE if it wants the engine to do so. + + There is an example in the windows() device. + + Can be left unimplemented as NULL. + */ +#if R_USE_PROTOTYPES + Rboolean (*newFrameConfirm)(pDevDesc dd); +#else + Rboolean (*newFrameConfirm)(); +#endif + + /* Some devices can plot UTF-8 text directly without converting + to the native encoding, e.g. windows(), quartz() .... + + If this flag is true, all text *not in the symbol font* is sent + in UTF8 to the textUTF8/strWidthUTF8 entry points. + + If the flag is TRUE, the metricInfo entry point should + accept negative values for 'c' and treat them as indicating + Unicode points (as well as positive values in a MBCS locale). + */ + Rboolean hasTextUTF8; /* and strWidthUTF8 */ +#if R_USE_PROTOTYPES + void (*textUTF8)(double x, double y, const char *str, double rot, + double hadj, const pGEcontext gc, pDevDesc dd); + double (*strWidthUTF8)(const char *str, const pGEcontext gc, pDevDesc dd); +#else + void (*textUTF8)(); + double (*strWidthUTF8)(); +#endif + Rboolean wantSymbolUTF8; + + /* Is rotated text good enough to be preferable to Hershey in + contour labels? Old default was FALSE. + */ + Rboolean useRotatedTextInContour; + + /* --------- Post-2.7.0 features --------- */ + + /* Added in 2.12.0: Changed graphics event handling. */ + + SEXP eventEnv; /* This is an environment holding event handlers. */ + /* + * eventHelper(dd, 1) is called by do_getGraphicsEvent before looking for a + * graphics event. It will then call R_ProcessEvents() and eventHelper(dd, 2) + * until this or another device returns sets a non-null result value in eventEnv, + * at which time eventHelper(dd, 0) will be called. + * + * An example is ... + * + * static SEXP GA_eventHelper(pDevDesc dd, int code); + + * Can be left unimplemented as NULL + */ +#if R_USE_PROTOTYPES + void (*eventHelper)(pDevDesc dd, int code); +#else + void (*eventHelper)(); +#endif + + /* added in 2.14.0, only used by screen devices. + + Allows graphics devices to have multiple levels of suspension: + when this reaches zero output is flushed. + + Can be left unimplemented as NULL. + */ +#if R_USE_PROTOTYPES + int (*holdflush)(pDevDesc dd, int level); +#else + int (*holdflush)(); +#endif + + /* added in 2.14.0, for dev.capabilities. + In all cases 0 means NA (unset). + */ + int haveTransparency; /* 1 = no, 2 = yes */ + int haveTransparentBg; /* 1 = no, 2 = fully, 3 = semi */ + int haveRaster; /* 1 = no, 2 = yes, 3 = except for missing values */ + int haveCapture, haveLocator; /* 1 = no, 2 = yes */ + + + /* Area for future expansion. + By zeroing this, devices are more likely to work if loaded + into a later version of R than that they were compiled under. + */ + char reserved[64]; +}; + + + /********************************************************/ + /* the device-driver entry point is given a device */ + /* description structure that it must set up. this */ + /* involves several important jobs ... */ + /* (1) it must ALLOCATE a new device-specific parameters*/ + /* structure and FREE that structure if anything goes */ + /* wrong (i.e., it won't report a successful setup to */ + /* the graphics engine (the graphics engine is NOT */ + /* responsible for allocating or freeing device-specific*/ + /* resources or parameters) */ + /* (2) it must initialise the device-specific resources */ + /* and parameters (mostly done by calling device_Open) */ + /* (3) it must initialise the generic graphical */ + /* parameters that are not initialised by GInit (because*/ + /* only the device knows what values they should have) */ + /* see Graphics.h for the official list of these */ + /* (4) it may reset generic graphics parameters that */ + /* have already been initialised by GInit (although you */ + /* should know what you are doing if you do this) */ + /* (5) it must attach the device-specific parameters */ + /* structure to the device description structure */ + /* e.g., dd->deviceSpecfic = (void *) xd; */ + /* (6) it must FREE the overall device description if */ + /* it wants to bail out to the top-level */ + /* the graphics engine is responsible for allocating */ + /* the device description and freeing it in most cases */ + /* but if the device driver freaks out it needs to do */ + /* the clean-up itself */ + /********************************************************/ + +/* moved from Rgraphics.h */ + +/* + * Some Notes on Color + * + * R uses a 24-bit color model. Colors are specified in 32-bit + * integers which are partitioned into 4 bytes as follows. + * + * <-- most sig least sig --> + * +-------------------------------+ + * | 0 | blue | green | red | + * +-------------------------------+ + * + * The red, green and blue bytes can be extracted as follows. + * + * red = ((color ) & 255) + * green = ((color >> 8) & 255) + * blue = ((color >> 16) & 255) + */ +/* + * Changes as from 1.4.0: use top 8 bits as an alpha channel. + * 0 = opaque, 255 = transparent. + */ +/* + * Changes as from 2.0.0: use top 8 bits as full alpha channel + * 255 = opaque, 0 = transparent + * [to conform with SVG, PDF and others] + * and everything in between is used + * [which means that NA is not stored as an internal colour; + * it is converted to R_RGBA(255, 255, 255, 0)] + */ + +#define R_RGB(r,g,b) ((r)|((g)<<8)|((b)<<16)|0xFF000000) +#define R_RGBA(r,g,b,a) ((r)|((g)<<8)|((b)<<16)|((a)<<24)) +#define R_RED(col) (((col) )&255) +#define R_GREEN(col) (((col)>> 8)&255) +#define R_BLUE(col) (((col)>>16)&255) +#define R_ALPHA(col) (((col)>>24)&255) +#define R_OPAQUE(col) (R_ALPHA(col) == 255) +#define R_TRANSPARENT(col) (R_ALPHA(col) == 0) + /* + * A transparent white + */ +#define R_TRANWHITE (R_RGBA(255, 255, 255, 0)) + + +/* used in various devices */ + +#define curDevice Rf_curDevice +#define killDevice Rf_killDevice +#define ndevNumber Rf_ndevNumber +#define NewFrameConfirm Rf_NewFrameConfirm +#define nextDevice Rf_nextDevice +#define NoDevices Rf_NoDevices +#define NumDevices Rf_NumDevices +#define prevDevice Rf_prevDevice +#define selectDevice Rf_selectDevice +#define AdobeSymbol2utf8 Rf_AdobeSymbol2utf8 + +/* Properly declared version of devNumber */ +int ndevNumber(pDevDesc ); + +/* Formerly in Rdevices.h */ + +/* How many devices exist ? (>= 1) */ +int NumDevices(void); + +/* Check for an available device slot */ +void R_CheckDeviceAvailable(void); +Rboolean R_CheckDeviceAvailableBool(void); + +/* Return the number of the current device. */ +int curDevice(void); + +/* Return the number of the next device. */ +int nextDevice(int); + +/* Return the number of the previous device. */ +int prevDevice(int); + +/* Make the specified device (specified by number) the current device */ +int selectDevice(int); + +/* Kill device which is identified by number. */ +void killDevice(int); + +int NoDevices(void); /* used in engine, graphics, plot, grid */ + +void NewFrameConfirm(pDevDesc); /* used in graphics.c, grid */ + + +/* Graphics events: defined in gevents.c */ + +/* These give the indices of some known keys */ + +typedef enum {knUNKNOWN = -1, + knLEFT = 0, knUP, knRIGHT, knDOWN, + knF1, knF2, knF3, knF4, knF5, knF6, knF7, knF8, knF9, knF10, + knF11, knF12, + knPGUP, knPGDN, knEND, knHOME, knINS, knDEL} R_KeyName; + +/* These are the three possible mouse events */ + +typedef enum {meMouseDown = 0, + meMouseUp, + meMouseMove} R_MouseEvent; + +#define leftButton 1 +#define middleButton 2 +#define rightButton 4 + +#define doKeybd Rf_doKeybd +#define doMouseEvent Rf_doMouseEvent + +void doMouseEvent(pDevDesc dd, R_MouseEvent event, + int buttons, double x, double y); +void doKeybd(pDevDesc dd, R_KeyName rkey, + const char *keyname); + + +/* For use in third-party devices when setting up a device: + * duplicates Defn.h which is used internally. + * (Tested in devNull.c) + */ + +#ifndef BEGIN_SUSPEND_INTERRUPTS +/* Macros for suspending interrupts */ +#define BEGIN_SUSPEND_INTERRUPTS do { \ + Rboolean __oldsusp__ = R_interrupts_suspended; \ + R_interrupts_suspended = TRUE; +#define END_SUSPEND_INTERRUPTS R_interrupts_suspended = __oldsusp__; \ + if (R_interrupts_pending && ! R_interrupts_suspended) \ + Rf_onintr(); \ +} while(0) + +#include <R_ext/libextern.h> +LibExtern Rboolean R_interrupts_suspended; +LibExtern int R_interrupts_pending; +extern void Rf_onintr(void); +LibExtern Rboolean mbcslocale; +#endif + +/* Useful for devices: translates Adobe symbol encoding to UTF-8 */ +extern void *AdobeSymbol2utf8(char*out, const char *in, int nwork); +/* Translates Unicode point to UTF-8 */ +extern size_t Rf_ucstoutf8(char *s, const unsigned int c); + +#ifdef __cplusplus +} +#endif + +#endif /* R_GRAPHICSDEVICE_ */ diff --git a/var_lib_genenet_bnw/localscore/GraphicsEngine.h b/var_lib_genenet_bnw/localscore/GraphicsEngine.h new file mode 100644 index 00000000..8d4a8748 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/GraphicsEngine.h @@ -0,0 +1,514 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 2001-11 The R Core Team. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +/* Used by graphics.c, grid and by third-party graphics devices */ + +#ifndef R_GRAPHICSENGINE_H_ +#define R_GRAPHICSENGINE_H_ + +#ifdef __cplusplus +extern "C" { +#endif + +/* + * The current graphics engine (including graphics device) API version + * MUST be integer + * + * This number should be bumped whenever there are changes to + * GraphicsEngine.h or GraphicsDevice.h so that add-on packages + * that compile against these headers (graphics systems such as + * graphics and grid; graphics devices such as gtkDevice, RSvgDevice) + * can detect any version mismatch. + * + * Version 1: Introduction of the version number. + * Version 2: GEDevDesc *dd dropped from GEcontourLines(). + * Version 3: R_GE_str2col() added to API. (r41887) + * Version 4: UTF-8 text hooks, useRotatedTextInContour, + * add newFrameConfirm() to NewDevDesc. + * New API: GEaddDevice[2] GEgetDevice, GEkillDevice, + * ndevNumber. (R 2.7.0) + * Version 5: Clean up 1.4.0/2.0.0 changes! + * Remove newDevStruct from GEDevDesc and NewDevDesc. + * Remove asp, dot(), hold(), open() from NewDevDesc. + * Move displayList, DLlastElt, savedSnapshot from + * NewDevDesc to GEDevDesc. + * Add 'ask' to GEDevDesc. (R 2.8.0) + * Version 6: Add dev_Raster() and dev_Cap() (R 2.11.0) + * Version 7: Change graphics event handling, adding eventEnv and eventHelper() + * to DevDesc. (R 2.12.0) + * Version 8: Add dev_Path() (R 2.12.0) + * Version 9: Add dev_HoldFlush(), haveTrans*, haveRaster, + * haveCapture, haveLocator. (R 2.14.0) + */ + +#define R_GE_version 9 + +int R_GE_getVersion(void); + +void R_GE_checkVersionOrDie(int version); + +/* The graphics engine will only accept locations and dimensions + * in native device coordinates, but it provides the following functions + * for converting between a couple of simple alternative coordinate + * systems and device coordinates: + * DEVICE = native units of the device + * NDC = Normalised device coordinates + * INCHES = inches (!) + * CM = centimetres (!!) + */ + +typedef enum { + GE_DEVICE = 0, /* native device coordinates (rasters) */ + GE_NDC = 1, /* normalised device coordinates x=(0,1), y=(0,1) */ + GE_INCHES = 2, + GE_CM = 3 +} GEUnit; + +#define MAX_GRAPHICS_SYSTEMS 24 + +typedef enum { + /* In response to this event, the registered graphics system + * should allocate and initialise the systemSpecific structure + * + * Should return R_NilValue on failure so that engine + * can tidy up memory allocation + */ + GE_InitState = 0, + /* This event gives the registered system a chance to undo + * anything done in the initialisation. + */ + GE_FinaliseState = 1, + /* This is sent by the graphics engine prior to initialising + * the display list. It give the graphics system the chance + * to squirrel away information it will need for redrawing the + * the display list + */ + GE_SaveState = 2, + /* This is sent by the graphics engine prior to replaying the + * display list. It gives the graphics system the chance to + * restore any information it saved on the GE_SaveState event + */ + GE_RestoreState = 6, + /* Copy system state information to the current device. + * This is used when copying graphics from one device to another + * so all the graphics system needs to do is to copy across + * the bits required for the display list to draw faithfully + * on the new device. + */ + GE_CopyState = 3, + /* Create a snapshot of the system state that is sufficient + * for the current "image" to be reproduced + */ + GE_SaveSnapshotState = 4, + /* Restore the system state that is saved by GE_SaveSnapshotState + */ + GE_RestoreSnapshotState = 5, + /* When replaying the display list, the graphics engine + * checks, after each replayed action, that the action + * produced valid output. This is the graphics system's + * chance to say that the output is crap (in which case the + * graphics engine will abort the display list replay). + */ + GE_CheckPlot = 7, + /* The device wants to scale the current pointsize + * (for scaling an image) + * This is not a nice general solution, but a quick fix for + * the Windows device. + */ + GE_ScalePS = 8 +} GEevent; + +/* + * Some line end/join constants + */ +typedef enum { + GE_ROUND_CAP = 1, + GE_BUTT_CAP = 2, + GE_SQUARE_CAP = 3 +} R_GE_lineend; + +typedef enum { + GE_ROUND_JOIN = 1, + GE_MITRE_JOIN = 2, + GE_BEVEL_JOIN = 3 +} R_GE_linejoin; + +/* + * A structure containing graphical parameters + * + * This is how graphical parameters are passed from graphics systems + * to the graphics engine AND from the graphics engine to graphics + * devices. + * + * Devices are not *required* to honour graphical parameters + * (e.g., alpha transparency is going to be tough for some) + */ +typedef struct { + /* + * Colours + * + * NOTE: Alpha transparency included in col & fill + */ + int col; /* pen colour (lines, text, borders, ...) */ + int fill; /* fill colour (for polygons, circles, rects, ...) */ + double gamma; /* Gamma correction */ + /* + * Line characteristics + */ + double lwd; /* Line width (roughly number of pixels) */ + int lty; /* Line type (solid, dashed, dotted, ...) */ + R_GE_lineend lend; /* Line end */ + R_GE_linejoin ljoin; /* line join */ + double lmitre; /* line mitre */ + /* + * Text characteristics + */ + double cex; /* Character expansion (font size = fontsize*cex) */ + double ps; /* Font size in points */ + double lineheight; /* Line height (multiply by font size) */ + int fontface; /* Font face (plain, italic, bold, ...) */ + char fontfamily[201]; /* Font family */ +} R_GE_gcontext; + +typedef R_GE_gcontext* pGEcontext; + + +#include <R_ext/GraphicsDevice.h> /* needed for DevDesc */ + +typedef struct _GEDevDesc GEDevDesc; + +typedef SEXP (* GEcallback)(GEevent, GEDevDesc *, SEXP); + +typedef struct { + /* An array of information about each graphics system that + * has registered with the graphics engine. + * This is used to store graphics state for each graphics + * system on each device. + */ + void *systemSpecific; + /* + * An array of function pointers, one per graphics system that + * has registered with the graphics engine. + * + * system_Callback is called when the graphics engine wants + * to give a graphics system the chance to play with its + * device-specific information (stored in systemSpecific) + * There are two parameters: an "event" to tell the graphics + * system why the graphics engine has called this function, + * and the systemSpecific pointer. The graphics engine + * has to pass the systemSpecific pointer because only + * the graphics engine will know what array index to use. + */ + GEcallback callback; +} GESystemDesc; + +struct _GEDevDesc { + /* + * Stuff that the devices can see (and modify). + * All detailed in GraphicsDevice.h + */ + pDevDesc dev; + /* + * Stuff about the device that only the graphics engine sees + * (the devices don't see it). + */ + Rboolean displayListOn; /* toggle for display list status */ + SEXP displayList; /* display list */ + SEXP DLlastElt; /* A pointer to the end of the display list + to avoid tranversing pairlists */ + SEXP savedSnapshot; /* The last element of the display list + * just prior to when the display list + * was last initialised + */ + Rboolean dirty; /* Has the device received any output? */ + Rboolean recordGraphics; /* Should a graphics call be stored + * on the display list? + * Set to FALSE by do_recordGraphics, + * do_dotcallgr, and do_Externalgr + * so that nested calls are not + * recorded on the display list + */ + /* + * Stuff about the device that only graphics systems see. + * The graphics engine has no idea what is in here. + * Used by graphics systems to store system state per device. + */ + GESystemDesc *gesd[MAX_GRAPHICS_SYSTEMS]; + + /* per-device setting for 'ask' (use NewFrameConfirm) */ + Rboolean ask; +}; + +typedef GEDevDesc* pGEDevDesc; + +/* functions from devices.c for use by graphics devices */ + +#define desc2GEDesc Rf_desc2GEDesc +/* map DevDesc to enclosing GEDevDesc */ +pGEDevDesc desc2GEDesc(pDevDesc dd); +int GEdeviceNumber(pGEDevDesc); +pGEDevDesc GEgetDevice(int); +void GEaddDevice(pGEDevDesc); +void GEaddDevice2(pGEDevDesc, const char *); +void GEkillDevice(pGEDevDesc); +pGEDevDesc GEcreateDevDesc(pDevDesc dev); + +void GEdestroyDevDesc(pGEDevDesc dd); +void *GEsystemState(pGEDevDesc dd, int index); +void GEregisterWithDevice(pGEDevDesc dd); +void GEregisterSystem(GEcallback callback, int *systemRegisterIndex); +void GEunregisterSystem(int registerIndex); +SEXP GEhandleEvent(GEevent event, pDevDesc dev, SEXP data); + +#define fromDeviceX GEfromDeviceX +#define toDeviceX GEtoDeviceX +#define fromDeviceY GEfromDeviceY +#define toDeviceY GEtoDeviceY +#define fromDeviceWidth GEfromDeviceWidth +#define toDeviceWidth GEtoDeviceWidth +#define fromDeviceHeight GEfromDeviceHeight +#define toDeviceHeight GEtoDeviceHeight + +double fromDeviceX(double value, GEUnit to, pGEDevDesc dd); +double toDeviceX(double value, GEUnit from, pGEDevDesc dd); +double fromDeviceY(double value, GEUnit to, pGEDevDesc dd); +double toDeviceY(double value, GEUnit from, pGEDevDesc dd); +double fromDeviceWidth(double value, GEUnit to, pGEDevDesc dd); +double toDeviceWidth(double value, GEUnit from, pGEDevDesc dd); +double fromDeviceHeight(double value, GEUnit to, pGEDevDesc dd); +double toDeviceHeight(double value, GEUnit from, pGEDevDesc dd); + +/*------------------------------------------------------------------- + * + * COLOUR CODE is concerned with the internals of R colour representation + * + * From colors.c, used in par.c, grid/src/gpar.c + */ + +#define RGBpar Rf_RGBpar +#define RGBpar3 Rf_RGBpar3 +#define col2name Rf_col2name +#define name2col Rf_name2col + +/* Convert an element of a R colour specification (which might be a + number or a string) into an internal colour specification. */ +unsigned int RGBpar(SEXP, int); +unsigned int RGBpar3(SEXP, int, unsigned int); + +/* Convert an internal colour specification to/from a colour name */ +const char *col2name(unsigned int col); /* used in par.c, grid */ +unsigned int name2col(const char *); /* used by plotmath.c */ + +/* Convert either a name or a #RRGGBB[AA] string to internal. + Because people were using it, it also converts "1", "2" ... + to a colour in the palette, and "0" to transparent white. +*/ +unsigned int R_GE_str2col(const char *s); + + + +/* + * Some Notes on Line Textures + * + * Line textures are stored as an array of 4-bit integers within + * a single 32-bit word. These integers contain the lengths of + * lines to be drawn with the pen alternately down and then up. + * The device should try to arrange that these values are measured + * in points if possible, although pixels is ok on most displays. + * + * If newlty contains a line texture description it is decoded + * as follows: + * + * ndash = 0; + * for(i=0 ; i<8 && newlty & 15 ; i++) { + * dashlist[ndash++] = newlty & 15; + * newlty = newlty>>4; + * } + * dashlist[0] = length of pen-down segment + * dashlist[1] = length of pen-up segment + * etc + * + * An integer containing a zero terminates the pattern. Hence + * ndash in this code fragment gives the length of the texture + * description. If a description contains an odd number of + * elements it is replicated to create a pattern with an + * even number of elements. (If this is a pain, do something + * different its not crucial). + * + */ + +/*--- The basic numbered & names line types; Here device-independent: + e.g. "dashed" == "44", "dotdash" == "1343" +*/ + +/* NB: was also in Rgraphics.h in R < 2.7.0 */ +#define LTY_BLANK -1 +#define LTY_SOLID 0 +#define LTY_DASHED 4 + (4<<4) +#define LTY_DOTTED 1 + (3<<4) +#define LTY_DOTDASH 1 + (3<<4) + (4<<8) + (3<<12) +#define LTY_LONGDASH 7 + (3<<4) +#define LTY_TWODASH 2 + (2<<4) + (6<<8) + (2<<12) + +R_GE_lineend GE_LENDpar(SEXP value, int ind); +SEXP GE_LENDget(R_GE_lineend lend); +R_GE_linejoin GE_LJOINpar(SEXP value, int ind); +SEXP GE_LJOINget(R_GE_linejoin ljoin); + +void GESetClip(double x1, double y1, double x2, double y2, pGEDevDesc dd); +void GENewPage(const pGEcontext gc, pGEDevDesc dd); +void GELine(double x1, double y1, double x2, double y2, + const pGEcontext gc, pGEDevDesc dd); +void GEPolyline(int n, double *x, double *y, + const pGEcontext gc, pGEDevDesc dd); +void GEPolygon(int n, double *x, double *y, + const pGEcontext gc, pGEDevDesc dd); +SEXP GEXspline(int n, double *x, double *y, double *s, Rboolean open, + Rboolean repEnds, Rboolean draw, + const pGEcontext gc, pGEDevDesc dd); +void GECircle(double x, double y, double radius, + const pGEcontext gc, pGEDevDesc dd); +void GERect(double x0, double y0, double x1, double y1, + const pGEcontext gc, pGEDevDesc dd); +void GEPath(double *x, double *y, + int npoly, int *nper, + Rboolean winding, + const pGEcontext gc, pGEDevDesc dd); +void GERaster(unsigned int *raster, int w, int h, + double x, double y, double width, double height, + double angle, Rboolean interpolate, + const pGEcontext gc, pGEDevDesc dd); +SEXP GECap(pGEDevDesc dd); +void GEText(double x, double y, const char * const str, cetype_t enc, + double xc, double yc, double rot, + const pGEcontext gc, pGEDevDesc dd); +void GEMode(int mode, pGEDevDesc dd); +void GESymbol(double x, double y, int pch, double size, + const pGEcontext gc, pGEDevDesc dd); +void GEPretty(double *lo, double *up, int *ndiv); +void GEMetricInfo(int c, const pGEcontext gc, + double *ascent, double *descent, double *width, + pGEDevDesc dd); +double GEStrWidth(const char *str, cetype_t enc, + const pGEcontext gc, pGEDevDesc dd); +double GEStrHeight(const char *str, cetype_t enc, + const pGEcontext gc, pGEDevDesc dd); +void GEStrMetric(const char *str, cetype_t enc, const pGEcontext gc, + double *ascent, double *descent, double *width, + pGEDevDesc dd); +int GEstring_to_pch(SEXP pch); + +/*------------------------------------------------------------------- + * + * LINE TEXTURE CODE is concerned with the internals of R + * line texture representation. + */ +unsigned int GE_LTYpar(SEXP, int); +SEXP GE_LTYget(unsigned int); + +/* + * Raster operations + */ +void R_GE_rasterScale(unsigned int *sraster, int sw, int sh, + unsigned int *draster, int dw, int dh); +void R_GE_rasterInterpolate(unsigned int *sraster, int sw, int sh, + unsigned int *draster, int dw, int dh); +void R_GE_rasterRotatedSize(int w, int h, double angle, + int *wnew, int *hnew); +void R_GE_rasterRotatedOffset(int w, int h, double angle, int botleft, + double *xoff, double *yoff); +void R_GE_rasterResizeForRotation(unsigned int *sraster, + int w, int h, + unsigned int *newRaster, + int wnew, int hnew, + const pGEcontext gc); +void R_GE_rasterRotate(unsigned int *sraster, int w, int h, double angle, + unsigned int *draster, const pGEcontext gc, + Rboolean perPixelAlpha); + + +/* + * From plotmath.c + */ +double GEExpressionWidth(SEXP expr, + const pGEcontext gc, pGEDevDesc dd); +double GEExpressionHeight(SEXP expr, + const pGEcontext gc, pGEDevDesc dd); +void GEExpressionMetric(SEXP expr, const pGEcontext gc, + double *ascent, double *descent, double *width, + pGEDevDesc dd); +void GEMathText(double x, double y, SEXP expr, + double xc, double yc, double rot, + const pGEcontext gc, pGEDevDesc dd); +/* + * (End from plotmath.c) + */ + +/* + * From plot3d.c : used in package clines + */ +SEXP GEcontourLines(double *x, int nx, double *y, int ny, + double *z, double *levels, int nl); +/* + * (End from plot3d.c) + */ + +/* + * From vfonts.c + */ +double R_GE_VStrWidth(const char *s, cetype_t enc, const pGEcontext gc, pGEDevDesc dd); + +double R_GE_VStrHeight(const char *s, cetype_t enc, const pGEcontext gc, pGEDevDesc dd); +void R_GE_VText(double x, double y, const char * const s, cetype_t enc, + double x_justify, double y_justify, double rotation, + const pGEcontext gc, pGEDevDesc dd); +/* + * (End from vfonts.c) + */ + +/* Also in Graphics.h */ +#define DEG2RAD 0.01745329251994329576 + +pGEDevDesc GEcurrentDevice(void); +Rboolean GEdeviceDirty(pGEDevDesc dd); +void GEdirtyDevice(pGEDevDesc dd); +Rboolean GEcheckState(pGEDevDesc dd); +Rboolean GErecording(SEXP call, pGEDevDesc dd); +void GErecordGraphicOperation(SEXP op, SEXP args, pGEDevDesc dd); +void GEinitDisplayList(pGEDevDesc dd); +void GEplayDisplayList(pGEDevDesc dd); +void GEcopyDisplayList(int fromDevice); +SEXP GEcreateSnapshot(pGEDevDesc dd); +void GEplaySnapshot(SEXP snapshot, pGEDevDesc dd); +void GEonExit(void); +void GEnullDevice(void); + + +/* From ../../main/plot.c, used by ../../library/grid/src/grid.c */ +#define CreateAtVector Rf_CreateAtVector +SEXP CreateAtVector(double*, double*, int, Rboolean); +/* From ../../main/graphics.c, used by ../../library/grDevices/src/axis_scales.c */ +#define GAxisPars Rf_GAxisPars +void GAxisPars(double *min, double *max, int *n, Rboolean log, int axis); + +#ifdef __cplusplus +} +#endif + +#endif /* R_GRAPHICSENGINE_ */ diff --git a/var_lib_genenet_bnw/localscore/Lapack.h b/var_lib_genenet_bnw/localscore/Lapack.h new file mode 100644 index 00000000..ad044ef7 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/Lapack.h @@ -0,0 +1,3072 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 2003-12 The R Core Team. + * Copyright (C) 2008 The R Foundation + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +/* + C declarations of LAPACK Fortran subroutines included in R. + Just those used (currently or previously) by C routines in R itself. + + Part of the API. + + R packages that use these should have PKG_LIBS in src/Makevars include + $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) + */ + + +#ifndef R_LAPACK_H +#define R_LAPACK_H + +#include <R_ext/RS.h> /* for F77_... */ +#include <R_ext/Complex.h> /* for Rcomplex */ +#include <R_ext/BLAS.h> + +/* + LAPACK function names are [dz]<name>(), where d denotes the real + version of the function, z the complex version. (Only + double-precision versions are used in R.) +*/ + +#ifdef __cplusplus +extern "C" { +#endif + +// Never defined by R itself. +#ifndef La_extern +#define La_extern extern +#endif + +/* Utilities for Lapack-using packages : */ + +/* matrix norms: converting typstr[] to one of {'M', 'O', 'I', 'F'} + * or signal error(): */ +La_extern char La_norm_type(const char *typstr); + +/* matrix (reciprocal) condition numbers: convert typstr[] to 'O'(ne) or 'I'(nf) + * or signal error(): */ +La_extern char La_rcond_type(const char *typstr); + + + +/* Selected Double Precision Lapack Routines + ======== + */ + +/* Double precision BiDiagonal matrices */ + +/* DBDSQR - compute the singular value decomposition (SVD) of a real */ +/* N-by-N (upper or lower) bidiagonal matrix B */ +La_extern void +F77_NAME(dbdsqr)(const char* uplo, const int* n, const int* ncvt, + const int* nru, const int* ncc, double* d, double* e, + double* vt, const int* ldvt, double* u, const int* ldu, + double* c, const int* ldc, double* work, int* info); +/* DDISNA - compute the reciprocal condition numbers for the */ +/* eigenvectors of a real symmetric or complex Hermitian matrix or */ +/* for the left or right singular vectors of a general m-by-n */ +/* matrix */ +La_extern void +F77_NAME(ddisna)(const char* job, const int* m, const int* n, + double* d, double* sep, int* info); + +/* Double precision General Banded matrices */ + +/* DGBBRD - reduce a real general m-by-n band matrix A to upper */ +/* bidiagonal form B by an orthogonal transformation */ +La_extern void +F77_NAME(dgbbrd)(const char* vect, const int* m, const int* n, + const int* ncc, const int* kl, const int* ku, + double* ab, const int* ldab, + double* d, double* e, double* q, + const int* ldq, double* pt, const int* ldpt, + double* c, const int* ldc, + double* work, int* info); +/* DGBCON - estimate the reciprocal of the condition number of a */ +/* real general band matrix A, in either the 1-norm or the */ +/* infinity-norm */ +La_extern void +F77_NAME(dgbcon)(const char* norm, const int* n, const int* kl, + const int* ku, double* ab, const int* ldab, + int* ipiv, const double* anorm, double* rcond, + double* work, int* iwork, int* info); +/* DGBEQU - compute row and column scalings intended to equilibrate */ +/* an M-by-N band matrix A and reduce its condition number */ +La_extern void +F77_NAME(dgbequ)(const int* m, const int* n, const int* kl, const int* ku, + double* ab, const int* ldab, double* r, double* c, + double* rowcnd, double* colcnd, double* amax, int* info); +/* DGBRFS - improve the computed solution to a system of linear */ +/* equations when the coefficient matrix is banded, and provides */ +/* error bounds and backward error estimates for the solution */ +La_extern void +F77_NAME(dgbrfs)(const char* trans, const int* n, const int* kl, + const int* ku, const int* nrhs, double* ab, + const int* ldab, double* afb, const int* ldafb, + int* ipiv, double* b, const int* ldb, + double* x, const int* ldx, double* ferr, double* berr, + double* work, int* iwork, int* info); +/* DGBSV - compute the solution to a real system of linear */ +/* equations A * X = B, where A is a band matrix of order N with */ +/* KL subdiagonals and KU superdiagonals, and X and B are */ +/* N-by-NRHS matrices */ +La_extern void +F77_NAME(dgbsv)(const int* n, const int* kl,const int* ku, + const int* nrhs, double* ab, const int* ldab, + int* ipiv, double* b, const int* ldb, int* info); +/* DGBSVX - use the LU factorization to compute the solution to a */ +/* real system of linear equations A * X = B or A**T * X = B */ +La_extern void +F77_NAME(dgbsvx)(const int* fact, const char* trans, + const int* n, const int* kl,const int* ku, + const int* nrhs, double* ab, const int* ldab, + double* afb, const int* ldafb, int* ipiv, + const char* equed, double* r, double* c, + double* b, const int* ldb, + double* x, const int* ldx, + double* rcond, double* ferr, double* berr, + double* work, int* iwork, int* info); +/* DGBTF2 - compute an LU factorization of a real m-by-n band */ +/* matrix A using partial pivoting with row interchanges */ +La_extern void +F77_NAME(dgbtf2)(const int* m, const int* n, const int* kl,const int* ku, + double* ab, const int* ldab, int* ipiv, int* info); +/* DGBTRF - compute an LU factorization of a real m-by-n band */ +/* matrix A using partial pivoting with row interchanges */ +La_extern void +F77_NAME(dgbtrf)(const int* m, const int* n, const int* kl,const int* ku, + double* ab, const int* ldab, int* ipiv, int* info); +/* DGBTRS - solve a system of linear equations A * X = B or */ +/* A' * X = B with a general band matrix A using the LU */ +/* factorization computed by DGBTRF */ +La_extern void +F77_NAME(dgbtrs)(const char* trans, const int* n, + const int* kl, const int* ku, const int* nrhs, + const double* ab, const int* ldab, const int* ipiv, + double* b, const int* ldb, int* info); + +/* Double precision GEneral matrices */ + +/* DGEBAK - form the right or left eigenvectors of a real general */ +/* matrix by backward transformation on the computed eigenvectors */ +/* of the balanced matrix output by DGEBAL */ +La_extern void +F77_NAME(dgebak)(const char* job, const char* side, const int* n, + const int* ilo, const int* ihi, double* scale, + const int* m, double* v, const int* ldv, int* info); +/* DGEBAL - balance a general real matrix A */ +La_extern void +F77_NAME(dgebal)(const char* job, const int* n, double* a, const int* lda, + int* ilo, int* ihi, double* scale, int* info); +/* DGEBD2 - reduce a real general m by n matrix A to upper or */ +/* lower bidiagonal form B by an orthogonal transformation */ +La_extern void +F77_NAME(dgebd2)(const int* m, const int* n, double* a, const int* lda, + double* d, double* e, double* tauq, double* taup, + double* work, int* info); +/* DGEBRD - reduce a general real M-by-N matrix A to upper or */ +/* lower bidiagonal form B by an orthogonal transformation */ +La_extern void +F77_NAME(dgebrd)(const int* m, const int* n, double* a, const int* lda, + double* d, double* e, double* tauq, double* taup, + double* work, const int* lwork, int* info); +/* DGECON - estimate the reciprocal of the condition number of a */ +/* general real matrix A, in either the 1-norm or the */ +/* infinity-norm, using the LU factorization computed by DGETRF */ +La_extern void +F77_NAME(dgecon)(const char* norm, const int* n, + const double* a, const int* lda, + const double* anorm, double* rcond, + double* work, int* iwork, int* info); +/* DGEEQU - compute row and column scalings intended to equilibrate */ +/* an M-by-N matrix A and reduce its condition number */ +La_extern void +F77_NAME(dgeequ)(const int* m, const int* n, double* a, const int* lda, + double* r, double* c, double* rowcnd, double* colcnd, + double* amax, int* info); +/* DGEES - compute for an N-by-N real nonsymmetric matrix A, the */ +/* eigenvalues, the real Schur form T, and, optionally, the matrix */ +/* of Schur vectors Z */ +La_extern void +F77_NAME(dgees)(const char* jobvs, const char* sort, + int (*select)(const double*, const double*), + const int* n, double* a, const int* lda, + int* sdim, double* wr, double* wi, + double* vs, const int* ldvs, + double* work, const int* lwork, int* bwork, int* info); +/* DGEESX - compute for an N-by-N real nonsymmetric matrix A, the */ +/* eigenvalues, the real Schur form T, and, optionally, the matrix */ +/* of Schur vectors Z */ +La_extern void +F77_NAME(dgeesx)(const char* jobvs, const char* sort, + int (*select)(const double*, const double*), + const char* sense, const int* n, double* a, + const int* lda, int* sdim, double* wr, double* wi, + double* vs, const int* ldvs, double* rconde, + double* rcondv, double* work, const int* lwork, + int* iwork, const int* liwork, int* bwork, int* info); +/* DGEEV - compute for an N-by-N real nonsymmetric matrix A, the */ +/* eigenvalues and, optionally, the left and/or right eigenvectors */ +La_extern void +F77_NAME(dgeev)(const char* jobvl, const char* jobvr, + const int* n, double* a, const int* lda, + double* wr, double* wi, double* vl, const int* ldvl, + double* vr, const int* ldvr, + double* work, const int* lwork, int* info); +/* DGEEVX - compute for an N-by-N real nonsymmetric matrix A, the */ +/* eigenvalues and, optionally, the left and/or right eigenvectors */ +La_extern void +F77_NAME(dgeevx)(const char* balanc, const char* jobvl, const char* jobvr, + const char* sense, const int* n, double* a, const int* lda, + double* wr, double* wi, double* vl, const int* ldvl, + double* vr, const int* ldvr, int* ilo, int* ihi, + double* scale, double* abnrm, double* rconde, double* rcondv, + double* work, const int* lwork, int* iwork, int* info); +/* DGEGV - compute for a pair of n-by-n real nonsymmetric */ +/* matrices A and B, the generalized eigenvalues (alphar +/- */ +/* alphai*i, beta);, and optionally, the left and/or right */ +/* generalized eigenvectors (VL and VR); */ +La_extern void +F77_NAME(dgegv)(const char* jobvl, const char* jobvr, + const int* n, double* a, const int* lda, + double* b, const int* ldb, + double* alphar, double* alphai, + const double* beta, double* vl, const int* ldvl, + double* vr, const int* ldvr, + double* work, const int* lwork, int* info); +/* DGEHD2 - reduce a real general matrix A to upper Hessenberg */ +/* form H by an orthogonal similarity transformation */ +La_extern void +F77_NAME(dgehd2)(const int* n, const int* ilo, const int* ihi, + double* a, const int* lda, double* tau, + double* work, int* info); +/* DGEHRD - reduce a real general matrix A to upper Hessenberg */ +/* form H by an orthogonal similarity transformation */ +La_extern void +F77_NAME(dgehrd)(const int* n, const int* ilo, const int* ihi, + double* a, const int* lda, double* tau, + double* work, const int* lwork, int* info); +/* DGELQ2 - compute an LQ factorization of a real m by n matrix A */ +La_extern void +F77_NAME(dgelq2)(const int* m, const int* n, + double* a, const int* lda, double* tau, + double* work, int* info); +/* DGELQF - compute an LQ factorization of a real M-by-N matrix A */ +La_extern void +F77_NAME(dgelqf)(const int* m, const int* n, + double* a, const int* lda, double* tau, + double* work, const int* lwork, int* info); +/* DGELS - solve overdetermined or underdetermined real linear */ +/* systems involving an M-by-N matrix A, or its transpose, using a */ +/* QR or LQ factorization of A */ +La_extern void +F77_NAME(dgels)(const char* trans, const int* m, const int* n, + const int* nrhs, double* a, const int* lda, + double* b, const int* ldb, + double* work, const int* lwork, int* info); +/* DGELSS - compute the minimum norm solution to a real linear */ +/* least squares problem */ +La_extern void +F77_NAME(dgelss)(const int* m, const int* n, const int* nrhs, + double* a, const int* lda, double* b, const int* ldb, + double* s, double* rcond, int* rank, + double* work, const int* lwork, int* info); +/* DGELSY - compute the minimum-norm solution to a real linear */ +/* least squares problem */ +La_extern void +F77_NAME(dgelsy)(const int* m, const int* n, const int* nrhs, + double* a, const int* lda, double* b, const int* ldb, + int* jpvt, const double* rcond, int* rank, + double* work, const int* lwork, int* info); +/* DGEQL2 - compute a QL factorization of a real m by n matrix A */ +La_extern void +F77_NAME(dgeql2)(const int* m, const int* n, double* a, const int* lda, + double* tau, double* work, int* info); +/* DGEQLF - compute a QL factorization of a real M-by-N matrix A */ +La_extern void +F77_NAME(dgeqlf)(const int* m, const int* n, + double* a, const int* lda, double* tau, + double* work, const int* lwork, int* info); +/* DGEQP3 - compute a QR factorization with column pivoting of a */ +/* real M-by-N matrix A using level 3 BLAS */ +La_extern void +F77_NAME(dgeqp3)(const int* m, const int* n, double* a, const int* lda, + int* jpvt, double* tau, double* work, const int* lwork, + int* info); +/* DGEQPF - compute a QR factorization with column pivoting of a */ +/* real M-by-N matrix A */ +La_extern void +F77_NAME(dgeqpf)(const int* m, const int* n, double* a, const int* lda, + int* jpvt, double* tau, double* work, int* info); +/* DGEQR2 - compute a QR factorization of a real m by n matrix A */ +La_extern void +F77_NAME(dgeqr2)(const int* m, const int* n, double* a, const int* lda, + double* tau, double* work, int* info); +/* DGEQRF - compute a QR factorization of a real M-by-N matrix A */ +La_extern void +F77_NAME(dgeqrf)(const int* m, const int* n, double* a, const int* lda, + double* tau, double* work, const int* lwork, int* info); +/* DGERFS - improve the computed solution to a system of linear */ +/* equations and provides error bounds and backward error */ +/* estimates for the solution */ +La_extern void +F77_NAME(dgerfs)(const char* trans, const int* n, const int* nrhs, + double* a, const int* lda, double* af, const int* ldaf, + int* ipiv, double* b, const int* ldb, + double* x, const int* ldx, double* ferr, double* berr, + double* work, int* iwork, int* info); +/* DGERQ2 - compute an RQ factorization of a real m by n matrix A */ +La_extern void +F77_NAME(dgerq2)(const int* m, const int* n, double* a, const int* lda, + double* tau, double* work, int* info); +/* DGERQF - compute an RQ factorization of a real M-by-N matrix A */ +La_extern void +F77_NAME(dgerqf)(const int* m, const int* n, double* a, const int* lda, + double* tau, double* work, const int* lwork, int* info); +/* DGESV - compute the solution to a real system of linear */ +/* equations A * X = B, */ +La_extern void +F77_NAME(dgesv)(const int* n, const int* nrhs, double* a, const int* lda, + int* ipiv, double* b, const int* ldb, int* info); +/* DGESVD - compute the singular value decomposition (SVD); of a */ +/* real M-by-N matrix A, optionally computing the left and/or */ +/* right singular vectors */ +La_extern void +F77_NAME(dgesvd)(const char* jobu, const char* jobvt, const int* m, + const int* n, double* a, const int* lda, double* s, + double* u, const int* ldu, double* vt, const int* ldvt, + double* work, const int* lwork, int* info); +/* DGESVX - use the LU factorization to compute the solution to a */ +/* real system of linear equations A * X = B, */ +La_extern void +F77_NAME(dgesvx)(const int* fact, const char* trans, const int* n, + const int* nrhs, double* a, const int* lda, + double* af, const int* ldaf, int* ipiv, + char *equed, double* r, double* c, + double* b, const int* ldb, + double* x, const int* ldx, + double* rcond, double* ferr, double* berr, + double* work, int* iwork, int* info); +/* DGETF2 - compute an LU factorization of a general m-by-n */ +/* matrix A using partial pivoting with row interchanges */ +La_extern void +F77_NAME(dgetf2)(const int* m, const int* n, double* a, const int* lda, + int* ipiv, int* info); +/* DGETRF - compute an LU factorization of a general M-by-N */ +/* matrix A using partial pivoting with row interchanges */ +La_extern void +F77_NAME(dgetrf)(const int* m, const int* n, double* a, const int* lda, + int* ipiv, int* info); +/* DGETRI - compute the inverse of a matrix using the LU */ +/* factorization computed by DGETRF */ +La_extern void +F77_NAME(dgetri)(const int* n, double* a, const int* lda, + int* ipiv, double* work, const int* lwork, int* info); +/* DGETRS - solve a system of linear equations A * X = B or A' * */ +/* X = B with a general N-by-N matrix A using the LU factorization */ +/* computed by DGETRF */ +La_extern void +F77_NAME(dgetrs)(const char* trans, const int* n, const int* nrhs, + const double* a, const int* lda, const int* ipiv, + double* b, const int* ldb, int* info); + +/* Double precision General matrices Generalized problems */ + +/* DGGBAK - form the right or left eigenvectors of a real */ +/* generalized eigenvalue problem A*x = lambda*B*x, by backward */ +/* transformation on the computed eigenvectors of the balanced */ +/* pair of matrices output by DGGBAL */ +La_extern void +F77_NAME(dggbak)(const char* job, const char* side, + const int* n, const int* ilo, const int* ihi, + double* lscale, double* rscale, const int* m, + double* v, const int* ldv, int* info); +/* DGGBAL - balance a pair of general real matrices (A,B); */ +La_extern void +F77_NAME(dggbal)(const char* job, const int* n, double* a, const int* lda, + double* b, const int* ldb, int* ilo, int* ihi, + double* lscale, double* rscale, double* work, int* info); +/* DGGES - compute for a pair of N-by-N real nonsymmetric */ +/* matrices A, B the generalized eigenvalues, the generalized */ +/* real Schur form (S,T), optionally, the left and/or right matrices */ +/* of Schur vectors (VSL and VSR)*/ +La_extern void +F77_NAME(dgges)(const char* jobvsl, const char* jobvsr, const char* sort, + int (*delztg)(double*, double*, double*), + const int* n, double* a, const int* lda, + double* b, const int* ldb, double* alphar, + double* alphai, const double* beta, + double* vsl, const int* ldvsl, + double* vsr, const int* ldvsr, + double* work, const int* lwork, int* bwork, int* info); + +/* DGGGLM - solve a general Gauss-Markov linear model (GLM) problem */ +La_extern void +F77_NAME(dggglm)(const int* n, const int* m, const int* p, + double* a, const int* lda, double* b, const int* ldb, + double* d, double* x, double* y, + double* work, const int* lwork, int* info); +/* DGGHRD - reduce a pair of real matrices (A,B); to generalized */ +/* upper Hessenberg form using orthogonal transformations, where A */ +/* is a general matrix and B is upper triangular */ +La_extern void +F77_NAME(dgghrd)(const char* compq, const char* compz, const int* n, + const int* ilo, const int* ihi, double* a, const int* lda, + double* b, const int* ldb, double* q, const int* ldq, + double* z, const int* ldz, int* info); +/* DGGLSE - solve the linear equality-constrained least squares */ +/* (LSE) problem */ +La_extern void +F77_NAME(dgglse)(const int* m, const int* n, const int* p, + double* a, const int* lda, + double* b, const int* ldb, + double* c, double* d, double* x, + double* work, const int* lwork, int* info); +/* DGGQRF - compute a generalized QR factorization of an N-by-M */ +/* matrix A and an N-by-P matrix B */ +La_extern void +F77_NAME(dggqrf)(const int* n, const int* m, const int* p, + double* a, const int* lda, double* taua, + double* b, const int* ldb, double* taub, + double* work, const int* lwork, int* info); +/* DGGRQF - compute a generalized RQ factorization of an M-by-N */ +/* matrix A and a P-by-N matrix B */ +La_extern void +F77_NAME(dggrqf)(const int* m, const int* p, const int* n, + double* a, const int* lda, double* taua, + double* b, const int* ldb, double* taub, + double* work, const int* lwork, int* info); +/* DGGSVD - compute the generalized singular value decomposition */ +/* (GSVD) of an M-by-N real matrix A and P-by-N real matrix B */ +La_extern void +F77_NAME(dggsvd)(const char* jobu, const char* jobv, const char* jobq, + const int* m, const int* n, const int* p, + const int* k, const int* l, + double* a, const int* lda, + double* b, const int* ldb, + const double* alpha, const double* beta, + double* u, const int* ldu, + double* v, const int* ldv, + double* q, const int* ldq, + double* work, int* iwork, int* info); + +/* Double precision General Tridiagonal matrices */ + +/* DGTCON - estimate the reciprocal of the condition number of a real */ +/* tridiagonal matrix A using the LU factorization as computed by DGTTRF */ +La_extern void +F77_NAME(dgtcon)(const char* norm, const int* n, double* dl, double* d, + double* du, double* du2, int* ipiv, const double* anorm, + double* rcond, double* work, int* iwork, int* info); +/* DGTRFS - improve the computed solution to a system of linear equations */ +/* when the coefficient matrix is tridiagonal, and provides error bounds */ +/* and backward error estimates for the solution */ +La_extern void +F77_NAME(dgtrfs)(const char* trans, const int* n, const int* nrhs, + double* dl, double* d, double* du, double* dlf, + double* df, double* duf, double* du2, + int* ipiv, double* b, const int* ldb, + double* x, const int* ldx, + double* ferr, double* berr, + double* work, int* iwork, int* info); +/* DGTSV - solve the equation A*X = B, */ +La_extern void +F77_NAME(dgtsv)(const int* n, const int* nrhs, + double* dl, double* d, double* du, + double* b, const int* ldb, int* info); +/* DGTSVX - use the LU factorization to compute the solution to a */ +/* real system of linear equations A * X = B or A**T * X = B, */ +La_extern void +F77_NAME(dgtsvx)(const int* fact, const char* trans, + const int* n, const int* nrhs, + double* dl, double* d, double* du, + double* dlf, double* df, double* duf, + double* du2, int* ipiv, + double* b, const int* ldb, + double* x, const int* ldx, + double* rcond, double* ferr, double* berr, + double* work, int* iwork, int* info); +/* DGTTRF - compute an LU factorization of a real tridiagonal matrix */ +/* A using elimination with partial pivoting and row interchanges */ +La_extern void +F77_NAME(dgttrf)(const int* n, double* dl, double* d, + double* du, double* du2, int* ipiv, int* info); +/* DGTTRS - solve one of the systems of equations A*X = B or */ +/* A'*X = B, */ +La_extern void +F77_NAME(dgttrs)(const char* trans, const int* n, const int* nrhs, + double* dl, double* d, double* du, double* du2, + int* ipiv, double* b, const int* ldb, int* info); + +/* Double precision Orthogonal matrices */ + +/* DOPGTR - generate a real orthogonal matrix Q which is defined */ +/* as the product of n-1 elementary reflectors H(i); of order n, */ +/* as returned by DSPTRD using packed storage */ +La_extern void +F77_NAME(dopgtr)(const char* uplo, const int* n, + const double* ap, const double* tau, + double* q, const int* ldq, + double* work, int* info); +/* DOPMTR - overwrite the general real M-by-N matrix C with */ +/* SIDE = 'L' SIDE = 'R' TRANS = 'N' */ +La_extern void +F77_NAME(dopmtr)(const char* side, const char* uplo, + const char* trans, const int* m, const int* n, + const double* ap, const double* tau, + double* c, const int* ldc, + double* work, int* info); +/* DORG2L - generate an m by n real matrix Q with orthonormal */ +/* columns, */ +La_extern void +F77_NAME(dorg2l)(const int* m, const int* n, const int* k, + double* a, const int* lda, + const double* tau, double* work, int* info); +/* DORG2R - generate an m by n real matrix Q with orthonormal */ +/* columns, */ +La_extern void +F77_NAME(dorg2r)(const int* m, const int* n, const int* k, + double* a, const int* lda, + const double* tau, double* work, int* info); +/* DORGBR - generate one of the real orthogonal matrices Q or */ +/* P**T determined by DGEBRD when reducing a real matrix A to */ +/* bidiagonal form */ +La_extern void +F77_NAME(dorgbr)(const char* vect, const int* m, + const int* n, const int* k, + double* a, const int* lda, + const double* tau, double* work, + const int* lwork, int* info); +/* DORGHR - generate a real orthogonal matrix Q which is defined */ +/* as the product of IHI-ILO elementary reflectors of order N, as */ +/* returned by DGEHRD */ +La_extern void +F77_NAME(dorghr)(const int* n, const int* ilo, const int* ihi, + double* a, const int* lda, const double* tau, + double* work, const int* lwork, int* info); +/* DORGL2 - generate an m by n real matrix Q with orthonormal */ +/* rows, */ +La_extern void +F77_NAME(dorgl2)(const int* m, const int* n, const int* k, + double* a, const int* lda, const double* tau, + double* work, int* info); +/* DORGLQ - generate an M-by-N real matrix Q with orthonormal */ +/* rows, */ +La_extern void +F77_NAME(dorglq)(const int* m, const int* n, const int* k, + double* a, const int* lda, + const double* tau, double* work, + const int* lwork, int* info); +/* DORGQL - generate an M-by-N real matrix Q with orthonormal */ +/* columns, */ +La_extern void +F77_NAME(dorgql)(const int* m, const int* n, const int* k, + double* a, const int* lda, + const double* tau, double* work, + const int* lwork, int* info); +/* DORGQR - generate an M-by-N real matrix Q with orthonormal */ +/* columns, */ +La_extern void +F77_NAME(dorgqr)(const int* m, const int* n, const int* k, + double* a, const int* lda, const double* tau, + double* work, const int* lwork, int* info); +/* DORGR2 - generate an m by n real matrix Q with orthonormal */ +/* rows, */ +La_extern void +F77_NAME(dorgr2)(const int* m, const int* n, const int* k, + double* a, const int* lda, const double* tau, + double* work, int* info); +/* DORGRQ - generate an M-by-N real matrix Q with orthonormal rows */ +La_extern void +F77_NAME(dorgrq)(const int* m, const int* n, const int* k, + double* a, const int* lda, const double* tau, + double* work, const int* lwork, int* info); +/* DORGTR - generate a real orthogonal matrix Q which is defined */ +/* as the product of n-1 elementary reflectors of order const int* n, as */ +/* returned by DSYTRD */ +La_extern void +F77_NAME(dorgtr)(const char* uplo, const int* n, + double* a, const int* lda, const double* tau, + double* work, const int* lwork, int* info); +/* DORM2L - overwrite the general real m by n matrix C with Q * */ +/* C if SIDE = 'L' and TRANS = 'N', or Q'* C if SIDE = 'L' and */ +/* TRANS = 'T', or C * Q if SIDE = 'R' and TRANS = 'N', or C * */ +/* Q' if SIDE = 'R' and TRANS = 'T', */ +La_extern void +F77_NAME(dorm2l)(const char* side, const char* trans, + const int* m, const int* n, const int* k, + const double* a, const int* lda, + const double* tau, double* c, const int* ldc, + double* work, int* info); +/* DORM2R - overwrite the general real m by n matrix C with Q * C */ +/* if SIDE = 'L' and TRANS = 'N', or Q'* C if SIDE = 'L' and */ +/* TRANS = 'T', or C * Q if SIDE = 'R' and TRANS = 'N', or C * */ +/* Q' if SIDE = 'R' and TRANS = 'T', */ +La_extern void +F77_NAME(dorm2r)(const char* side, const char* trans, + const int* m, const int* n, const int* k, + const double* a, const int* lda, const double* tau, + double* c, const int* ldc, double* work, int* info); +/* DORMBR - VECT = 'Q', DORMBR overwrites the general real M-by-N */ +/* matrix C with SIDE = 'L' SIDE = 'R' TRANS = 'N' */ +La_extern void +F77_NAME(dormbr)(const char* vect, const char* side, const char* trans, + const int* m, const int* n, const int* k, + const double* a, const int* lda, const double* tau, + double* c, const int* ldc, + double* work, const int* lwork, int* info); +/* DORMHR - overwrite the general real M-by-N matrix C with */ +/* SIDE = 'L' SIDE = 'R' TRANS = 'N' */ +La_extern void +F77_NAME(dormhr)(const char* side, const char* trans, const int* m, + const int* n, const int* ilo, const int* ihi, + const double* a, const int* lda, const double* tau, + double* c, const int* ldc, + double* work, const int* lwork, int* info); +/* DORML2 - overwrite the general real m by n matrix C with Q * */ +/* C if SIDE = 'L' and TRANS = 'N', or Q'* C if SIDE = 'L' and */ +/* TRANS = 'T', or C * Q if SIDE = 'R' and TRANS = 'N', or C * */ +/* Q' if SIDE = 'R' and TRANS = 'T', */ +La_extern void +F77_NAME(dorml2)(const char* side, const char* trans, + const int* m, const int* n, const int* k, + const double* a, const int* lda, const double* tau, + double* c, const int* ldc, double* work, int* info); +/* DORMLQ - overwrite the general real M-by-N matrix C with */ +/* SIDE = 'L' SIDE = 'R' TRANS = 'N' */ +La_extern void +F77_NAME(dormlq)(const char* side, const char* trans, + const int* m, const int* n, const int* k, + const double* a, const int* lda, + const double* tau, double* c, const int* ldc, + double* work, const int* lwork, int* info); +/* DORMQL - overwrite the general real M-by-N matrix C with */ +/* SIDE = 'L' SIDE = 'R' TRANS = 'N' */ +La_extern void +F77_NAME(dormql)(const char* side, const char* trans, + const int* m, const int* n, const int* k, + const double* a, const int* lda, + const double* tau, double* c, const int* ldc, + double* work, const int* lwork, int* info); +/* DORMQR - overwrite the general real M-by-N matrix C with SIDE = */ +/* 'L' SIDE = 'R' TRANS = 'N' */ +La_extern void +F77_NAME(dormqr)(const char* side, const char* trans, + const int* m, const int* n, const int* k, + const double* a, const int* lda, + const double* tau, double* c, const int* ldc, + double* work, const int* lwork, int* info); +/* DORMR2 - overwrite the general real m by n matrix C with Q * */ +/* C if SIDE = 'L' and TRANS = 'N', or Q'* C if SIDE = 'L' and */ +/* TRANS = 'T', or C * Q if SIDE = 'R' and TRANS = 'N', or C * */ +/* Q' if SIDE = 'R' and TRANS = 'T', */ +La_extern void +F77_NAME(dormr2)(const char* side, const char* trans, + const int* m, const int* n, const int* k, + const double* a, const int* lda, + const double* tau, double* c, const int* ldc, + double* work, int* info); +/* DORMRQ - overwrite the general real M-by-N matrix C with */ +/* SIDE = 'L' SIDE = 'R' TRANS = 'N' */ +La_extern void +F77_NAME(dormrq)(const char* side, const char* trans, + const int* m, const int* n, const int* k, + const double* a, const int* lda, + const double* tau, double* c, const int* ldc, + double* work, const int* lwork, int* info); +/* DORMTR - overwrite the general real M-by-N matrix C with */ +/* SIDE = 'L' SIDE = 'R' TRANS = 'N' */ +La_extern void +F77_NAME(dormtr)(const char* side, const char* uplo, + const char* trans, const int* m, const int* n, + const double* a, const int* lda, + const double* tau, double* c, const int* ldc, + double* work, const int* lwork, int* info); + +/* Double precision Positive definite Band matrices */ + +/* DPBCON - estimate the reciprocal of the condition number (in */ +/* the 1-norm); of a real symmetric positive definite band matrix */ +/* using the Cholesky factorization A = U**T*U or A = L*L**T */ +/* computed by DPBTRF */ +La_extern void +F77_NAME(dpbcon)(const char* uplo, const int* n, const int* kd, + const double* ab, const int* ldab, + const double* anorm, double* rcond, + double* work, int* iwork, int* info); +/* DPBEQU - compute row and column scalings intended to */ +/* equilibrate a symmetric positive definite band matrix A and */ +/* reduce its condition number (with respect to the two-norm); */ +La_extern void +F77_NAME(dpbequ)(const char* uplo, const int* n, const int* kd, + const double* ab, const int* ldab, + double* s, double* scond, double* amax, int* info); +/* DPBRFS - improve the computed solution to a system of linear */ +/* equations when the coefficient matrix is symmetric positive */ +/* definite and banded, and provides error bounds and backward */ +/* error estimates for the solution */ +La_extern void +F77_NAME(dpbrfs)(const char* uplo, const int* n, + const int* kd, const int* nrhs, + const double* ab, const int* ldab, + const double* afb, const int* ldafb, + const double* b, const int* ldb, + double* x, const int* ldx, + double* ferr, double* berr, + double* work, int* iwork, int* info); +/* DPBSTF - compute a split Cholesky factorization of a real */ +/* symmetric positive definite band matrix A */ +La_extern void +F77_NAME(dpbstf)(const char* uplo, const int* n, const int* kd, + double* ab, const int* ldab, int* info); +/* DPBSV - compute the solution to a real system of linear */ +/* equations A * X = B, */ +La_extern void +F77_NAME(dpbsv)(const char* uplo, const int* n, + const int* kd, const int* nrhs, + double* ab, const int* ldab, + double* b, const int* ldb, int* info); +/* DPBSVX - use the Cholesky factorization A = U**T*U or A = */ +/* L*L**T to compute the solution to a real system of linear */ +/* equations A * X = B, */ +La_extern void +F77_NAME(dpbsvx)(const int* fact, const char* uplo, const int* n, + const int* kd, const int* nrhs, + double* ab, const int* ldab, + double* afb, const int* ldafb, + char* equed, double* s, + double* b, const int* ldb, + double* x, const int* ldx, double* rcond, + double* ferr, double* berr, + double* work, int* iwork, int* info); +/* DPBTF2 - compute the Cholesky factorization of a real */ +/* symmetric positive definite band matrix A */ +La_extern void +F77_NAME(dpbtf2)(const char* uplo, const int* n, const int* kd, + double* ab, const int* ldab, int* info); +/* DPBTRF - compute the Cholesky factorization of a real */ +/* symmetric positive definite band matrix A */ +La_extern void +F77_NAME(dpbtrf)(const char* uplo, const int* n, const int* kd, + double* ab, const int* ldab, int* info); +/* DPBTRS - solve a system of linear equations A*X = B with a */ +/* symmetric positive definite band matrix A using the Cholesky */ +/* factorization A = U**T*U or A = L*L**T computed by DPBTRF */ +La_extern void +F77_NAME(dpbtrs)(const char* uplo, const int* n, + const int* kd, const int* nrhs, + const double* ab, const int* ldab, + double* b, const int* ldb, int* info); + +/* Double precision Positive definite matrices */ + +/* DPOCON - estimate the reciprocal of the condition number (in */ +/* the 1-norm); of a real symmetric positive definite matrix using */ +/* the Cholesky factorization A = U**T*U or A = L*L**T computed by */ +/* DPOTRF */ +La_extern void +F77_NAME(dpocon)(const char* uplo, const int* n, + const double* a, const int* lda, + const double* anorm, double* rcond, + double* work, int* iwork, int* info); +/* DPOEQU - compute row and column scalings intended to */ +/* equilibrate a symmetric positive definite matrix A and reduce */ +/* its condition number (with respect to the two-norm); */ +La_extern void +F77_NAME(dpoequ)(const int* n, const double* a, const int* lda, + double* s, double* scond, double* amax, int* info); +/* DPORFS - improve the computed solution to a system of linear */ +/* equations when the coefficient matrix is symmetric positive */ +/* definite, */ +La_extern void +F77_NAME(dporfs)(const char* uplo, const int* n, const int* nrhs, + const double* a, const int* lda, + const double* af, const int* ldaf, + const double* b, const int* ldb, + double* x, const int* ldx, + double* ferr, double* berr, + double* work, int* iwork, int* info); +/* DPOSV - compute the solution to a real system of linear */ +/* equations A * X = B, */ +La_extern void +F77_NAME(dposv)(const char* uplo, const int* n, const int* nrhs, + double* a, const int* lda, + double* b, const int* ldb, int* info); +/* DPOSVX - use the Cholesky factorization A = U**T*U or A = */ +/* L*L**T to compute the solution to a real system of linear */ +/* equations A * X = B, */ +La_extern void +F77_NAME(dposvx)(const int* fact, const char* uplo, + const int* n, const int* nrhs, + double* a, const int* lda, + double* af, const int* ldaf, char* equed, + double* s, double* b, const int* ldb, + double* x, const int* ldx, double* rcond, + double* ferr, double* berr, double* work, + int* iwork, int* info); +/* DPOTF2 - compute the Cholesky factorization of a real */ +/* symmetric positive definite matrix A */ +La_extern void +F77_NAME(dpotf2)(const char* uplo, const int* n, + double* a, const int* lda, int* info); +/* DPOTRF - compute the Cholesky factorization of a real */ +/* symmetric positive definite matrix A */ +La_extern void +F77_NAME(dpotrf)(const char* uplo, const int* n, + double* a, const int* lda, int* info); +/* DPOTRI - compute the inverse of a real symmetric positive */ +/* definite matrix A using the Cholesky factorization A = U**T*U */ +/* or A = L*L**T computed by DPOTRF */ +La_extern void +F77_NAME(dpotri)(const char* uplo, const int* n, + double* a, const int* lda, int* info); +/* DPOTRS - solve a system of linear equations A*X = B with a */ +/* symmetric positive definite matrix A using the Cholesky */ +/* factorization A = U**T*U or A = L*L**T computed by DPOTRF */ +La_extern void +F77_NAME(dpotrs)(const char* uplo, const int* n, + const int* nrhs, const double* a, const int* lda, + double* b, const int* ldb, int* info); +/* DPPCON - estimate the reciprocal of the condition number (in */ +/* the 1-norm); of a real symmetric positive definite packed */ +/* matrix using the Cholesky factorization A = U**T*U or A = */ +/* L*L**T computed by DPPTRF */ +La_extern void +F77_NAME(dppcon)(const char* uplo, const int* n, + const double* ap, const double* anorm, double* rcond, + double* work, int* iwork, int* info); +/* DPPEQU - compute row and column scalings intended to */ +/* equilibrate a symmetric positive definite matrix A in packed */ +/* storage and reduce its condition number (with respect to the */ +/* two-norm); */ +La_extern void +F77_NAME(dppequ)(const char* uplo, const int* n, + const double* ap, double* s, double* scond, + double* amax, int* info); + +/* Double precision Positive definite matrices in Packed storage */ + +/* DPPRFS - improve the computed solution to a system of linear */ +/* equations when the coefficient matrix is symmetric positive */ +/* definite and packed, and provides error bounds and backward */ +/* error estimates for the solution */ +La_extern void +F77_NAME(dpprfs)(const char* uplo, const int* n, const int* nrhs, + const double* ap, const double* afp, + const double* b, const int* ldb, + double* x, const int* ldx, + double* ferr, double* berr, + double* work, int* iwork, int* info); +/* DPPSV - compute the solution to a real system of linear */ +/* equations A * X = B, */ +La_extern void +F77_NAME(dppsv)(const char* uplo, const int* n, + const int* nrhs, const double* ap, + double* b, const int* ldb, int* info); +/* DPPSVX - use the Cholesky factorization A = U**T*U or A = */ +/* L*L**T to compute the solution to a real system of linear */ +/* equations A * X = B, */ +La_extern void +F77_NAME(dppsvx)(const int* fact, const char* uplo, + const int* n, const int* nrhs, double* ap, + double* afp, char* equed, double* s, + double* b, const int* ldb, + double* x, const int* ldx, + double* rcond, double* ferr, double* berr, + double* work, int* iwork, int* info); +/* DPPTRF - compute the Cholesky factorization of a real */ +/* symmetric positive definite matrix A stored in packed format */ +La_extern void +F77_NAME(dpptrf)(const char* uplo, const int* n, double* ap, int* info); +/* DPPTRI - compute the inverse of a real symmetric positive */ +/* definite matrix A using the Cholesky factorization A = U**T*U */ +/* or A = L*L**T computed by DPPTRF */ +La_extern void +F77_NAME(dpptri)(const char* uplo, const int* n, double* ap, int* info); +/* DPPTRS - solve a system of linear equations A*X = B with a */ +/* symmetric positive definite matrix A in packed storage using */ +/* the Cholesky factorization A = U**T*U or A = L*L**T computed by */ +/* DPPTRF */ +La_extern void +F77_NAME(dpptrs)(const char* uplo, const int* n, + const int* nrhs, const double* ap, + double* b, const int* ldb, int* info); + +/* Double precision symmetric Positive definite Tridiagonal matrices */ + +/* DPTCON - compute the reciprocal of the condition number (in */ +/* the 1-norm); of a real symmetric positive definite tridiagonal */ +/* matrix using the factorization A = L*D*L**T or A = U**T*D*U */ +/* computed by DPTTRF */ +La_extern void +F77_NAME(dptcon)(const int* n, + const double* d, const double* e, + const double* anorm, double* rcond, + double* work, int* info); +/* DPTEQR - compute all eigenvalues and, optionally, eigenvectors */ +/* of a symmetric positive definite tridiagonal matrix by first */ +/* factoring the matrix using DPTTRF, and then calling DBDSQR to */ +/* compute the singular values of the bidiagonal factor */ +La_extern void +F77_NAME(dpteqr)(const char* compz, const int* n, double* d, + double* e, double* z, const int* ldz, + double* work, int* info); +/* DPTRFS - improve the computed solution to a system of linear */ +/* equations when the coefficient matrix is symmetric positive */ +/* definite and tridiagonal, and provides error bounds and */ +/* backward error estimates for the solution */ +La_extern void +F77_NAME(dptrfs)(const int* n, const int* nrhs, + const double* d, const double* e, + const double* df, const double* ef, + const double* b, const int* ldb, + double* x, const int* ldx, + double* ferr, double* berr, + double* work, int* info); +/* DPTSV - compute the solution to a real system of linear */ +/* equations A*X = B, where A is an N-by-N symmetric positive */ +/* definite tridiagonal matrix, and X and B are N-by-NRHS matrices */ +La_extern void +F77_NAME(dptsv)(const int* n, const int* nrhs, double* d, + double* e, double* b, const int* ldb, int* info); +/* DPTSVX - use the factorization A = L*D*L**T to compute the */ +/* solution to a real system of linear equations A*X = B, where A */ +/* is an N-by-N symmetric positive definite tridiagonal matrix and */ +/* X and B are N-by-NRHS matrices */ +La_extern void +F77_NAME(dptsvx)(const int* fact, const int* n, + const int* nrhs, + const double* d, const double* e, + double* df, double* ef, + const double* b, const int* ldb, + double* x, const int* ldx, double* rcond, + double* ferr, double* berr, + double* work, int* info); +/* DPTTRF - compute the factorization of a real symmetric */ +/* positive definite tridiagonal matrix A */ +La_extern void +F77_NAME(dpttrf)(const int* n, double* d, double* e, int* info); +/* DPTTRS - solve a system of linear equations A * X = B with a */ +/* symmetric positive definite tridiagonal matrix A using the */ +/* factorization A = L*D*L**T or A = U**T*D*U computed by DPTTRF */ +La_extern void +F77_NAME(dpttrs)(const int* n, const int* nrhs, + const double* d, const double* e, + double* b, const int* ldb, int* info); +/* DRSCL - multiply an n-element real vector x by the real scalar */ +/* 1/a */ +La_extern void +F77_NAME(drscl)(const int* n, const double* da, + double* x, const int* incx); + +/* Double precision Symmetric Band matrices */ + +/* DSBEV - compute all the eigenvalues and, optionally, */ +/* eigenvectors of a real symmetric band matrix A */ +La_extern void +F77_NAME(dsbev)(const char* jobz, const char* uplo, + const int* n, const int* kd, + double* ab, const int* ldab, + double* w, double* z, const int* ldz, + double* work, int* info); +/* DSBEVD - compute all the eigenvalues and, optionally, */ +/* eigenvectors of a real symmetric band matrix A */ +La_extern void +F77_NAME(dsbevd)(const char* jobz, const char* uplo, + const int* n, const int* kd, + double* ab, const int* ldab, + double* w, double* z, const int* ldz, + double* work, const int* lwork, + int* iwork, const int* liwork, int* info); +/* DSBEVX - compute selected eigenvalues and, optionally, */ +/* eigenvectors of a real symmetric band matrix A */ +La_extern void +F77_NAME(dsbevx)(const char* jobz, const char* range, + const char* uplo, const int* n, const int* kd, + double* ab, const int* ldab, + double* q, const int* ldq, + const double* vl, const double* vu, + const int* il, const int* iu, + const double* abstol, + int* m, double* w, + double* z, const int* ldz, + double* work, int* iwork, + int* ifail, int* info); +/* DSBGST - reduce a real symmetric-definite banded generalized */ +/* eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y, */ +La_extern void +F77_NAME(dsbgst)(const char* vect, const char* uplo, + const int* n, const int* ka, const int* kb, + double* ab, const int* ldab, + double* bb, const int* ldbb, + double* x, const int* ldx, + double* work, int* info); +/* DSBGV - compute all the eigenvalues, and optionally, the */ +/* eigenvectors of a real generalized symmetric-definite banded */ +/* eigenproblem, of the form A*x=(lambda);*B*x */ +La_extern void +F77_NAME(dsbgv)(const char* jobz, const char* uplo, + const int* n, const int* ka, const int* kb, + double* ab, const int* ldab, + double* bb, const int* ldbb, + double* w, double* z, const int* ldz, + double* work, int* info); +/* DSBTRD - reduce a real symmetric band matrix A to symmetric */ +/* tridiagonal form T by an orthogonal similarity transformation */ +La_extern void +F77_NAME(dsbtrd)(const char* vect, const char* uplo, + const int* n, const int* kd, + double* ab, const int* ldab, + double* d, double* e, + double* q, const int* ldq, + double* work, int* info); + +/* Double precision Symmetric Packed matrices */ + +/* DSPCON - estimate the reciprocal of the condition number (in */ +/* the 1-norm); of a real symmetric packed matrix A using the */ +/* factorization A = U*D*U**T or A = L*D*L**T computed by DSPTRF */ +La_extern void +F77_NAME(dspcon)(const char* uplo, const int* n, + const double* ap, const int* ipiv, + const double* anorm, double* rcond, + double* work, int* iwork, int* info); +/* DSPEV - compute all the eigenvalues and, optionally, */ +/* eigenvectors of a real symmetric matrix A in packed storage */ +La_extern void +F77_NAME(dspev)(const char* jobz, const char* uplo, const int* n, + double* ap, double* w, double* z, const int* ldz, + double* work, int* info); +/* DSPEVD - compute all the eigenvalues and, optionally, */ +/* eigenvectors of a real symmetric matrix A in packed storage */ +La_extern void +F77_NAME(dspevd)(const char* jobz, const char* uplo, + const int* n, double* ap, double* w, + double* z, const int* ldz, + double* work, const int* lwork, + int* iwork, const int* liwork, int* info); +/* DSPEVX - compute selected eigenvalues and, optionally, */ +/* eigenvectors of a real symmetric matrix A in packed storage */ +La_extern void +F77_NAME(dspevx)(const char* jobz, const char* range, + const char* uplo, const int* n, double* ap, + const double* vl, const double* vu, + const int* il, const int* iu, + const double* abstol, + int* m, double* w, + double* z, const int* ldz, + double* work, int* iwork, + int* ifail, int* info); +/* DSPGST - reduce a real symmetric-definite generalized */ +/* eigenproblem to standard form, using packed storage */ +La_extern void +F77_NAME(dspgst)(const int* itype, const char* uplo, + const int* n, double* ap, double* bp, int* info); +/* DSPGV - compute all the eigenvalues and, optionally, the */ +/* eigenvectors of a real generalized symmetric-definite */ +/* eigenproblem, of the form A*x=(lambda)*B*x, A*Bx=(lambda)*x, */ +/* or B*A*x=(lambda)*x */ +La_extern void +F77_NAME(dspgv)(const int* itype, const char* jobz, + const char* uplo, const int* n, + double* ap, double* bp, double* w, + double* z, const int* ldz, + double* work, int* info); + +/* DSPRFS - improve the computed solution to a system of linear */ +/* equations when the coefficient matrix is symmetric indefinite */ +/* and packed, and provides error bounds and backward error */ +/* estimates for the solution */ +La_extern void +F77_NAME(dsprfs)(const char* uplo, const int* n, + const int* nrhs, const double* ap, + const double* afp, const int* ipiv, + const double* b, const int* ldb, + double* x, const int* ldx, + double* ferr, double* berr, + double* work, int* iwork, int* info); + +/* DSPSV - compute the solution to a real system of linear */ +/* equations A * X = B, */ +La_extern void +F77_NAME(dspsv)(const char* uplo, const int* n, + const int* nrhs, double* ap, int* ipiv, + double* b, const int* ldb, int* info); + +/* DSPSVX - use the diagonal pivoting factorization A = U*D*U**T */ +/* or A = L*D*L**T to compute the solution to a real system of */ +/* linear equations A * X = B, where A is an N-by-N symmetric */ +/* matrix stored in packed format and X and B are N-by-NRHS */ +/* matrices */ +La_extern void +F77_NAME(dspsvx)(const int* fact, const char* uplo, + const int* n, const int* nrhs, + const double* ap, double* afp, int* ipiv, + const double* b, const int* ldb, + double* x, const int* ldx, + double* rcond, double* ferr, double* berr, + double* work, int* iwork, int* info); + +/* DSPTRD - reduce a real symmetric matrix A stored in packed */ +/* form to symmetric tridiagonal form T by an orthogonal */ +/* similarity transformation */ +La_extern void +F77_NAME(dsptrd)(const char* uplo, const int* n, + double* ap, double* d, double* e, + double* tau, int* info); + +/* DSPTRF - compute the factorization of a real symmetric matrix */ +/* A stored in packed format using the Bunch-Kaufman diagonal */ +/* pivoting method */ +La_extern void +F77_NAME(dsptrf)(const char* uplo, const int* n, + double* ap, int* ipiv, int* info); + +/* DSPTRI - compute the inverse of a real symmetric indefinite */ +/* matrix A in packed storage using the factorization A = U*D*U**T */ +/* or A = L*D*L**T computed by DSPTRF */ +La_extern void +F77_NAME(dsptri)(const char* uplo, const int* n, + double* ap, const int* ipiv, + double* work, int* info); + +/* DSPTRS - solve a system of linear equations A*X = B with a */ +/* real symmetric matrix A stored in packed format using the */ +/* factorization A = U*D*U**T or A = L*D*L**T computed by DSPTRF */ +La_extern void +F77_NAME(dsptrs)(const char* uplo, const int* n, + const int* nrhs, const double* ap, + const int* ipiv, double* b, const int* ldb, int* info); + +/* Double precision Symmetric Tridiagonal matrices */ + +/* DSTEBZ - compute the eigenvalues of a symmetric tridiagonal */ +/* matrix T */ +La_extern void +F77_NAME(dstebz)(const char* range, const char* order, const int* n, + const double* vl, const double* vu, + const int* il, const int* iu, + const double *abstol, + const double* d, const double* e, + int* m, int* nsplit, double* w, + int* iblock, int* isplit, + double* work, int* iwork, + int* info); +/* DSTEDC - compute all eigenvalues and, optionally, eigenvectors */ +/* of a symmetric tridiagonal matrix using the divide and conquer */ +/* method */ +La_extern void +F77_NAME(dstedc)(const char* compz, const int* n, + double* d, double* e, + double* z, const int* ldz, + double* work, const int* lwork, + int* iwork, const int* liwork, int* info); +/* DSTEIN - compute the eigenvectors of a real symmetric */ +/* tridiagonal matrix T corresponding to specified eigenvalues, */ +/* using inverse iteration */ +La_extern void +F77_NAME(dstein)(const int* n, const double* d, const double* e, + const int* m, const double* w, + const int* iblock, const int* isplit, + double* z, const int* ldz, + double* work, int* iwork, + int* ifail, int* info); +/* DSTEQR - compute all eigenvalues and, optionally, eigenvectors */ +/* of a symmetric tridiagonal matrix using the implicit QL or QR */ +/* method */ +La_extern void +F77_NAME(dsteqr)(const char* compz, const int* n, double* d, double* e, + double* z, const int* ldz, double* work, int* info); +/* DSTERF - compute all eigenvalues of a symmetric tridiagonal */ +/* matrix using the Pal-Walker-Kahan variant of the QL or QR */ +/* algorithm */ +La_extern void +F77_NAME(dsterf)(const int* n, double* d, double* e, int* info); +/* DSTEV - compute all eigenvalues and, optionally, eigenvectors */ +/* of a real symmetric tridiagonal matrix A */ +La_extern void +F77_NAME(dstev)(const char* jobz, const int* n, + double* d, double* e, + double* z, const int* ldz, + double* work, int* info); +/* DSTEVD - compute all eigenvalues and, optionally, eigenvectors */ +/* of a real symmetric tridiagonal matrix */ +La_extern void +F77_NAME(dstevd)(const char* jobz, const int* n, + double* d, double* e, + double* z, const int* ldz, + double* work, const int* lwork, + int* iwork, const int* liwork, int* info); +/* DSTEVX - compute selected eigenvalues and, optionally, */ +/* eigenvectors of a real symmetric tridiagonal matrix A */ +La_extern void +F77_NAME(dstevx)(const char* jobz, const char* range, + const int* n, double* d, double* e, + const double* vl, const double* vu, + const int* il, const int* iu, + const double* abstol, + int* m, double* w, + double* z, const int* ldz, + double* work, int* iwork, + int* ifail, int* info); + +/* Double precision SYmmetric matrices */ + +/* DSYCON - estimate the reciprocal of the condition number (in */ +/* the 1-norm); of a real symmetric matrix A using the */ +/* factorization A = U*D*U**T or A = L*D*L**T computed by DSYTRF */ +La_extern void +F77_NAME(dsycon)(const char* uplo, const int* n, + const double* a, const int* lda, + const int* ipiv, + const double* anorm, double* rcond, + double* work, int* iwork, int* info); +/* DSYEV - compute all eigenvalues and, optionally, eigenvectors */ +/* of a real symmetric matrix A */ +La_extern void +F77_NAME(dsyev)(const char* jobz, const char* uplo, + const int* n, double* a, const int* lda, + double* w, double* work, const int* lwork, int* info); +/* DSYEVD - compute all eigenvalues and, optionally, eigenvectors */ +/* of a real symmetric matrix A */ +La_extern void +F77_NAME(dsyevd)(const char* jobz, const char* uplo, + const int* n, double* a, const int* lda, + double* w, double* work, const int* lwork, + int* iwork, const int* liwork, int* info); +/* DSYEVX - compute selected eigenvalues and, optionally, */ +/* eigenvectors of a real symmetric matrix A */ +La_extern void +F77_NAME(dsyevx)(const char* jobz, const char* range, + const char* uplo, const int* n, + double* a, const int* lda, + const double* vl, const double* vu, + const int* il, const int* iu, + const double* abstol, + int* m, double* w, + double* z, const int* ldz, + double* work, const int* lwork, int* iwork, + int* ifail, int* info); +/* DSYEVR - compute all eigenvalues and, optionally, eigenvectors */ +/* of a real symmetric matrix A */ +La_extern void +F77_NAME(dsyevr)(const char *jobz, const char *range, const char *uplo, + const int *n, double *a, const int *lda, + const double *vl, const double *vu, + const int *il, const int *iu, + const double *abstol, int *m, double *w, + double *z, const int *ldz, int *isuppz, + double *work, const int *lwork, + int *iwork, const int *liwork, + int *info); +/* DSYGS2 - reduce a real symmetric-definite generalized */ +/* eigenproblem to standard form */ +La_extern void +F77_NAME(dsygs2)(const int* itype, const char* uplo, + const int* n, double* a, const int* lda, + const double* b, const int* ldb, int* info); +/* DSYGST - reduce a real symmetric-definite generalized */ +/* eigenproblem to standard form */ +La_extern void +F77_NAME(dsygst)(const int* itype, const char* uplo, + const int* n, double* a, const int* lda, + const double* b, const int* ldb, int* info); +/* DSYGV - compute all the eigenvalues, and optionally, the */ +/* eigenvectors of a real generalized symmetric-definite */ +/* eigenproblem, of the form A*x=(lambda);*B*x, A*Bx=(lambda);*x, */ +/* or B*A*x=(lambda);*x */ +La_extern void +F77_NAME(dsygv)(const int* itype, const char* jobz, + const char* uplo, const int* n, + double* a, const int* lda, + double* b, const int* ldb, + double* w, double* work, const int* lwork, + int* info); +/* DSYRFS - improve the computed solution to a system of linear */ +/* equations when the coefficient matrix is symmetric indefinite, */ +/* and provides error bounds and backward error estimates for the */ +/* solution */ +La_extern void +F77_NAME(dsyrfs)(const char* uplo, const int* n, + const int* nrhs, + const double* a, const int* lda, + const double* af, const int* ldaf, + const int* ipiv, + const double* b, const int* ldb, + double* x, const int* ldx, + double* ferr, double* berr, + double* work, int* iwork, int* info); + +/* DSYSV - compute the solution to a real system of linear */ +/* equations A * X = B, */ +La_extern void +F77_NAME(dsysv)(const char* uplo, const int* n, + const int* nrhs, + double* a, const int* lda, int* ipiv, + double* b, const int* ldb, + double* work, const int* lwork, int* info); + +/* DSYSVX - use the diagonal pivoting factorization to compute */ +/* the solution to a real system of linear equations A * X = B, */ +La_extern void +F77_NAME(dsysvx)(const int* fact, const char* uplo, + const int* n, const int* nrhs, + const double* a, const int* lda, + double* af, const int* ldaf, int* ipiv, + const double* b, const int* ldb, + double* x, const int* ldx, double* rcond, + double* ferr, double* berr, + double* work, const int* lwork, + int* iwork, int* info); + +/* DSYTD2 - reduce a real symmetric matrix A to symmetric */ +/* tridiagonal form T by an orthogonal similarity transformation */ +La_extern void +F77_NAME(dsytd2)(const char* uplo, const int* n, + double* a, const int* lda, + double* d, double* e, double* tau, + int* info); + +/* DSYTF2 - compute the factorization of a real symmetric matrix */ +/* A using the Bunch-Kaufman diagonal pivoting method */ +La_extern void +F77_NAME(dsytf2)(const char* uplo, const int* n, + double* a, const int* lda, + int* ipiv, int* info); + +/* DSYTRD - reduce a real symmetric matrix A to real symmetric */ +/* tridiagonal form T by an orthogonal similarity transformation */ +La_extern void +F77_NAME(dsytrd)(const char* uplo, const int* n, + double* a, const int* lda, + double* d, double* e, double* tau, + double* work, const int* lwork, int* info); + +/* DSYTRF - compute the factorization of a real symmetric matrix */ +/* A using the Bunch-Kaufman diagonal pivoting method */ +La_extern void +F77_NAME(dsytrf)(const char* uplo, const int* n, + double* a, const int* lda, int* ipiv, + double* work, const int* lwork, int* info); + +/* DSYTRI - compute the inverse of a real symmetric indefinite */ +/* matrix A using the factorization A = U*D*U**T or A = L*D*L**T */ +/* computed by DSYTRF */ +La_extern void +F77_NAME(dsytri)(const char* uplo, const int* n, + double* a, const int* lda, const int* ipiv, + double* work, int* info); + +/* DSYTRS - solve a system of linear equations A*X = B with a */ +/* real symmetric matrix A using the factorization A = U*D*U**T or */ +/* A = L*D*L**T computed by DSYTRF */ +La_extern void +F77_NAME(dsytrs)(const char* uplo, const int* n, + const int* nrhs, + const double* a, const int* lda, + const int* ipiv, + double* b, const int* ldb, int* info); + +/* Double precision Triangular Band matrices */ + +/* DTBCON - estimate the reciprocal of the condition number of a */ +/* triangular band matrix A, in either the 1-norm or the */ +/* infinity-norm */ +La_extern void +F77_NAME(dtbcon)(const char* norm, const char* uplo, + const char* diag, const int* n, const int* kd, + const double* ab, const int* ldab, + double* rcond, double* work, + int* iwork, int* info); +/* DTBRFS - provide error bounds and backward error estimates for */ +/* the solution to a system of linear equations with a triangular */ +/* band coefficient matrix */ +La_extern void +F77_NAME(dtbrfs)(const char* uplo, const char* trans, + const char* diag, const int* n, const int* kd, + const int* nrhs, + const double* ab, const int* ldab, + const double* b, const int* ldb, + double* x, const int* ldx, + double* ferr, double* berr, + double* work, int* iwork, int* info); +/* DTBTRS - solve a triangular system of the form A * X = B or */ +/* A**T * X = B, */ +La_extern void +F77_NAME(dtbtrs)(const char* uplo, const char* trans, + const char* diag, const int* n, + const int* kd, const int* nrhs, + const double* ab, const int* ldab, + double* b, const int* ldb, int* info); + +/* Double precision Triangular matrices Generalized problems */ + +/* DTGEVC - compute some or all of the right and/or left */ +/* generalized eigenvectors of a pair of real upper triangular */ +/* matrices (A,B); */ +La_extern void +F77_NAME(dtgevc)(const char* side, const char* howmny, + const int* select, const int* n, + const double* a, const int* lda, + const double* b, const int* ldb, + double* vl, const int* ldvl, + double* vr, const int* ldvr, + const int* mm, int* m, double* work, int* info); + +/* DTGSJA - compute the generalized singular value decomposition */ +/* (GSVD); of two real upper triangular (or trapezoidal); matrices */ +/* A and B */ +La_extern void +F77_NAME(dtgsja)(const char* jobu, const char* jobv, const char* jobq, + const int* m, const int* p, const int* n, + const int* k, const int* l, + double* a, const int* lda, + double* b, const int* ldb, + const double* tola, const double* tolb, + double* alpha, double* beta, + double* u, const int* ldu, + double* v, const int* ldv, + double* q, const int* ldq, + double* work, int* ncycle, int* info); + +/* Double precision Triangular matrices Packed storage */ + +/* DTPCON - estimate the reciprocal of the condition number of a */ +/* packed triangular matrix A, in either the 1-norm or the */ +/* infinity-norm */ +La_extern void +F77_NAME(dtpcon)(const char* norm, const char* uplo, + const char* diag, const int* n, + const double* ap, double* rcond, + double* work, int* iwork, int* info); + +/* DTPRFS - provide error bounds and backward error estimates for */ +/* the solution to a system of linear equations with a triangular */ +/* packed coefficient matrix */ +La_extern void +F77_NAME(dtprfs)(const char* uplo, const char* trans, + const char* diag, const int* n, + const int* nrhs, const double* ap, + const double* b, const int* ldb, + double* x, const int* ldx, + double* ferr, double* berr, + double* work, int* iwork, int* info); + +/* Double precision TRiangular matrices */ + +/* DTPTRI - compute the inverse of a real upper or lower */ +/* triangular matrix A stored in packed format */ +La_extern void +F77_NAME(dtptri)(const char* uplo, const char* diag, + const int* n, double* ap, int* info); + +/* DTPTRS - solve a triangular system of the form A * X = B or */ +/* A**T * X = B, */ +La_extern void +F77_NAME(dtptrs)(const char* uplo, const char* trans, + const char* diag, const int* n, + const int* nrhs, const double* ap, + double* b, const int* ldb, int* info); + +/* DTRCON - estimate the reciprocal of the condition number of a */ +/* triangular matrix A, in either the 1-norm or the infinity-norm */ +La_extern void +F77_NAME(dtrcon)(const char* norm, const char* uplo, + const char* diag, const int* n, + const double* a, const int* lda, + double* rcond, double* work, + int* iwork, int* info); + +/* DTREVC - compute some or all of the right and/or left */ +/* eigenvectors of a real upper quasi-triangular matrix T */ +La_extern void +F77_NAME(dtrevc)(const char* side, const char* howmny, + const int* select, const int* n, + const double* t, const int* ldt, + double* vl, const int* ldvl, + double* vr, const int* ldvr, + const int* mm, int* m, double* work, int* info); + +/* DTREXC - reorder the real Schur factorization of a real matrix */ +/* A = Q*T*Q**T, so that the diagonal block of T with row index */ +/* IFST is moved to row ILST */ +La_extern void +F77_NAME(dtrexc)(const char* compq, const int* n, + double* t, const int* ldt, + double* q, const int* ldq, + int* ifst, int* ILST, + double* work, int* info); + +/* DTRRFS - provide error bounds and backward error estimates for */ +/* the solution to a system of linear equations with a triangular */ +/* coefficient matrix */ +La_extern void +F77_NAME(dtrrfs)(const char* uplo, const char* trans, + const char* diag, const int* n, const int* nrhs, + const double* a, const int* lda, + const double* b, const int* ldb, + double* x, const int* ldx, + double* ferr, double* berr, + double* work, int* iwork, int* info); + +/* DTRSEN - reorder the real Schur factorization of a real matrix */ +/* A = Q*T*Q**T, so that a selected cluster of eigenvalues appears */ +/* in the leading diagonal blocks of the upper quasi-triangular */ +/* matrix T, */ +La_extern void +F77_NAME(dtrsen)(const char* job, const char* compq, + const int* select, const int* n, + double* t, const int* ldt, + double* q, const int* ldq, + double* wr, double* wi, + int* m, double* s, double* sep, + double* work, const int* lwork, + int* iwork, const int* liwork, int* info); + +/* DTRSNA - estimate reciprocal condition numbers for specified */ +/* eigenvalues and/or right eigenvectors of a real upper */ +/* quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q */ +/* orthogonal); */ +La_extern void +F77_NAME(dtrsna)(const char* job, const char* howmny, + const int* select, const int* n, + const double* t, const int* ldt, + const double* vl, const int* ldvl, + const double* vr, const int* ldvr, + double* s, double* sep, const int* mm, + int* m, double* work, const int* lwork, + int* iwork, int* info); + +/* DTRSYL - solve the real Sylvester matrix equation */ +La_extern void +F77_NAME(dtrsyl)(const char* trana, const char* tranb, + const int* isgn, const int* m, const int* n, + const double* a, const int* lda, + const double* b, const int* ldb, + double* c, const int* ldc, + double* scale, int* info); + +/* DTRTI2 - compute the inverse of a real upper or lower */ +/* triangular matrix */ +La_extern void +F77_NAME(dtrti2)(const char* uplo, const char* diag, + const int* n, double* a, const int* lda, + int* info); + +/* DTRTRI - compute the inverse of a real upper or lower */ +/* triangular matrix A */ +La_extern void +F77_NAME(dtrtri)(const char* uplo, const char* diag, + const int* n, double* a, const int* lda, + int* info); + +/* DTRTRS - solve a triangular system of the form A * X = B or */ +/* A**T * X = B */ +La_extern void +F77_NAME(dtrtrs)(const char* uplo, const char* trans, + const char* diag, const int* n, const int* nrhs, + const double* a, const int* lda, + double* b, const int* ldb, int* info); + +/* DTZRQF - reduce the M-by-N ( M<=N ); real upper trapezoidal */ +/* matrix A to upper triangular form by means of orthogonal */ +/* transformations */ +La_extern void +F77_NAME(dtzrqf)(const int* m, const int* n, + double* a, const int* lda, + double* tau, int* info); + + + +/* Double precision utilties in Lapack */ +/* DHGEQZ - implement a single-/double-shift version of the QZ */ +/* method for finding the generalized eigenvalues */ +/* w(j);=(ALPHAR(j); + i*ALPHAI(j););/BETAR(j); of the equation */ +/* det( A - w(i); B ); = 0 In addition, the pair A,B may be */ +/* reduced to generalized Schur form */ +La_extern void +F77_NAME(dhgeqz)(const char* job, const char* compq, const char* compz, + const int* n, const int *ILO, const int* IHI, + double* a, const int* lda, + double* b, const int* ldb, + double* alphar, double* alphai, const double* beta, + double* q, const int* ldq, + double* z, const int* ldz, + double* work, const int* lwork, int* info); +/* DHSEIN - use inverse iteration to find specified right and/or */ +/* left eigenvectors of a real upper Hessenberg matrix H */ +La_extern void +F77_NAME(dhsein)(const char* side, const char* eigsrc, + const char* initv, int* select, + const int* n, double* h, const int* ldh, + double* wr, double* wi, + double* vl, const int* ldvl, + double* vr, const int* ldvr, + const int* mm, int* m, double* work, + int* ifaill, int* ifailr, int* info); +/* DHSEQR - compute the eigenvalues of a real upper Hessenberg */ +/* matrix H and, optionally, the matrices T and Z from the Schur */ +/* decomposition H = Z T Z**T, where T is an upper */ +/* quasi-triangular matrix (the Schur form);, and Z is the */ +/* orthogonal matrix of Schur vectors */ +La_extern void +F77_NAME(dhseqr)(const char* job, const char* compz, const int* n, + const int* ilo, const int* ihi, + double* h, const int* ldh, + double* wr, double* wi, + double* z, const int* ldz, + double* work, const int* lwork, int* info); +/* DLABAD - take as input the values computed by SLAMCH for */ +/* underflow and overflow, and returns the square root of each of */ +/* these values if the log of LARGE is sufficiently large */ +La_extern void +F77_NAME(dlabad)(double* small, double* large); +/* DLABRD - reduce the first NB rows and columns of a real */ +/* general m by n matrix A to upper or lower bidiagonal form by an */ +/* orthogonal transformation Q' * A * P, and returns the matrices */ +/* X and Y which are needed to apply the transformation to the */ +/* unreduced part of A */ +La_extern void +F77_NAME(dlabrd)(const int* m, const int* n, const int* nb, + double* a, const int* lda, double* d, double* e, + double* tauq, double* taup, + double* x, const int* ldx, double* y, const int* ldy); +/* DLACON - estimate the 1-norm of a square, real matrix A */ +La_extern void +F77_NAME(dlacon)(const int* n, double* v, double* x, + int* isgn, double* est, int* kase); +/* DLACPY - copy all or part of a two-dimensional matrix A to */ +/* another matrix B */ +La_extern void +F77_NAME(dlacpy)(const char* uplo, const int* m, const int* n, + const double* a, const int* lda, + double* b, const int* ldb); +/* DLADIV - perform complex division in real arithmetic */ +La_extern void +F77_NAME(dladiv)(const double* a, const double* b, + const double* c, const double* d, + double* p, double* q); +/* DLAE2 - compute the eigenvalues of a 2-by-2 symmetric matrix [ A B ] */ +/* [ B C ] */ +La_extern void +F77_NAME(dlae2)(const double* a, const double* b, const double* c, + double* rt1, double* rt2); +/* DLAEBZ - contain the iteration loops which compute and use the */ +/* function N(w);, which is the count of eigenvalues of a */ +/* symmetric tridiagonal matrix T less than or equal to its */ +/* argument w */ +La_extern void +F77_NAME(dlaebz)(const int* ijob, const int* nitmax, const int* n, + const int* mmax, const int* minp, const int* nbmin, + const double* abstol, const double* reltol, + const double* pivmin, double* d, double* e, + double* e2, int* nval, double* ab, double* c, + int* mout, int* nab, double* work, int* iwork, + int* info); +/* DLAED0 - compute all eigenvalues and corresponding */ +/* eigenvectors of a symmetric tridiagonal matrix using the divide */ +/* and conquer method */ +La_extern void +F77_NAME(dlaed0)(const int* icompq, const int* qsiz, const int* n, + double* d, double* e, double* q, const int* ldq, + double* qstore, const int* ldqs, + double* work, int* iwork, int* info); +/* DLAED1 - compute the updated eigensystem of a diagonal matrix */ +/* after modification by a rank-one symmetric matrix */ +La_extern void +F77_NAME(dlaed1)(const int* n, double* d, double* q, const int* ldq, + int* indxq, const double* rho, const int* cutpnt, + double* work, int* iwork, int* info); +/* DLAED2 - merge the two sets of eigenvalues together into a */ +/* single sorted set */ +La_extern void +F77_NAME(dlaed2)(const int* k, const int* n, double* d, + double* q, const int* ldq, int* indxq, + double* rho, const int* cutpnt, double* z, + double* dlamda, double* q2, const int *ldq2, + int* indxc, int* w, int* indxp, int* indx, + int* coltyp, int* info); +/* DLAED3 - find the roots of the secular equation, as defined by */ +/* the values in double* d, W, and RHO, between KSTART and KSTOP */ +La_extern void +F77_NAME(dlaed3)(const int* k, const int* kstart, + const int *kstop, const int* n, + double* d, double* q, const int* ldq, + const double* rho, const int* cutpnt, + double* dlamda, int* q2, const int* ldq2, + int* indxc, int* ctot, double* w, + double* s, const int* lds, int* info); +/* DLAED4 - subroutine computes the I-th updated eigenvalue of a */ +/* symmetric rank-one modification to a diagonal matrix whose */ +/* elements are given in the array d, and that D(i); < D(j); for */ +/* i < j and that RHO > 0 */ +La_extern void +F77_NAME(dlaed4)(const int* n, const int* i, const double* d, + const double* z, const double* delta, + const double* rho, double* dlam, int* info); +/* DLAED5 - subroutine computes the I-th eigenvalue of a */ +/* symmetric rank-one modification of a 2-by-2 diagonal matrix */ +/* diag( D ); + RHO The diagonal elements in the array D are */ +/* assumed to satisfy D(i); < D(j); for i < j */ +La_extern void +F77_NAME(dlaed5)(const int* i, const double* d, const double* z, + double* delta, const double* rho, double* dlam); +/* DLAED6 - compute the positive or negative root (closest to the */ +/* origin); of z(1); z(2); z(3); f(x); = rho + --------- + */ +/* ---------- + --------- d(1);-x d(2);-x d(3);-x It is assumed */ +/* that if ORGATI = .true */ +La_extern void +F77_NAME(dlaed6)(const int* kniter, const int* orgati, + const double* rho, const double* d, + const double* z, const double* finit, + double* tau, int* info); +/* DLAED7 - compute the updated eigensystem of a diagonal matrix */ +/* after modification by a rank-one symmetric matrix */ +La_extern void +F77_NAME(dlaed7)(const int* icompq, const int* n, + const int* qsiz, const int* tlvls, + const int* curlvl, const int* curpbm, + double* d, double* q, const int* ldq, + int* indxq, const double* rho, const int* cutpnt, + double* qstore, double* qptr, const int* prmptr, + const int* perm, const int* givptr, + const int* givcol, const double* givnum, + double* work, int* iwork, int* info); +/* DLAED8 - merge the two sets of eigenvalues together into a */ +/* single sorted set */ +La_extern void +F77_NAME(dlaed8)(const int* icompq, const int* k, + const int* n, const int* qsiz, + double* d, double* q, const int* ldq, + const int* indxq, double* rho, + const int* cutpnt, const double* z, + double* dlamda, double* q2, const int* ldq2, + double* w, int* perm, int* givptr, + int* givcol, double* givnum, int* indxp, + int* indx, int* info); +/* DLAED9 - find the roots of the secular equation, as defined by */ +/* the values in double* d, Z, and RHO, between KSTART and KSTOP */ +La_extern void +F77_NAME(dlaed9)(const int* k, const int* kstart, const int* kstop, + const int* n, double* d, double* q, const int* ldq, + const double* rho, const double* dlamda, + const double* w, double* s, const int* lds, int* info); +/* DLAEDA - compute the Z vector corresponding to the merge step */ +/* in the CURLVLth step of the merge process with TLVLS steps for */ +/* the CURPBMth problem */ +La_extern void +F77_NAME(dlaeda)(const int* n, const int* tlvls, const int* curlvl, + const int* curpbm, const int* prmptr, const int* perm, + const int* givptr, const int* givcol, + const double* givnum, const double* q, + const int* qptr, double* z, double* ztemp, int* info); +/* DLAEIN - use inverse iteration to find a right or left */ +/* eigenvector corresponding to the eigenvalue (WR,WI); of a real */ +/* upper Hessenberg matrix H */ +La_extern void +F77_NAME(dlaein)(const int* rightv, const int* noinit, const int* n, + const double* h, const int* ldh, + const double* wr, const double* wi, + double* vr, double* vi, + double* b, const int* ldb, double* work, + const double* eps3, const double* smlnum, + const double* bignum, int* info); +/* DLAEV2 - compute the eigendecomposition of a 2-by-2 symmetric */ +/* matrix [ A B ] [ B C ] */ +La_extern void +F77_NAME(dlaev2)(const double* a, const double* b, const double* c, + double* rt1, double* rt2, double* cs1, double *sn1); +/* DLAEXC - swap adjacent diagonal blocks T11 and T22 of order 1 */ +/* or 2 in an upper quasi-triangular matrix T by an orthogonal */ +/* similarity transformation */ +La_extern void +F77_NAME(dlaexc)(const int* wantq, const int* n, double* t, const int* ldt, + double* q, const int* ldq, const int* j1, + const int* n1, const int* n2, double* work, int* info); +/* DLAG2 - compute the eigenvalues of a 2 x 2 generalized */ +/* eigenvalue problem A - w B, with scaling as necessary to aextern void */ +/* over-/underflow */ +La_extern void +F77_NAME(dlag2)(const double* a, const int* lda, const double* b, + const int* ldb, const double* safmin, + double* scale1, double* scale2, + double* wr1, double* wr2, double* wi); +/* DLAGS2 - compute 2-by-2 orthogonal matrices U, V and Q, such */ +/* that if ( UPPER ); then U'*A*Q = U'*( A1 A2 );*Q = ( x 0 ); */ +/* ( 0 A3 ); ( x x ); and V'*B*Q = V'*( B1 B2 );*Q = ( x 0 ); ( */ +/* 0 B3 ); ( x x ); or if ( .NOT.UPPER ); then U'*A*Q = U'*( A1 */ +/* 0 );*Q = ( x x ); ( A2 A3 ); ( 0 x ); and V'*B*Q = V'*( B1 0 */ +/* );*Q = ( x x ); ( B2 B3 ); ( 0 x ); The rows of the */ +/* transformed A and B are parallel, where U = ( CSU SNU );, V = */ +/* ( CSV SNV );, Q = ( CSQ SNQ ); ( -SNU CSU ); ( -SNV CSV ); ( */ +/* -SNQ CSQ ); Z' denotes the transpose of Z */ +La_extern void +F77_NAME(dlags2)(const int* upper, + const double* a1, const double* a2, const double* a3, + const double* b1, const double* b2, const double* b3, + double* csu, double* snu, + double* csv, double* snv, double *csq, double *snq); +/* DLAGTF - factorize the matrix (T - lambda*I);, where T is an n */ +/* by n tridiagonal matrix and lambda is a scalar, as T - */ +/* lambda*I = PLU, */ +La_extern void +F77_NAME(dlagtf)(const int* n, double* a, const double* lambda, + double* b, double* c, const double *tol, + double* d, int* in, int* info); +/* DLAGTM - perform a matrix-vector product of the form B := */ +/* alpha * A * X + beta * B where A is a tridiagonal matrix of */ +/* order N, B and X are N by NRHS matrices, and alpha and beta are */ +/* real scalars, each of which may be 0., 1., or -1 */ +La_extern void +F77_NAME(dlagtm)(const char* trans, const int* n, const int* nrhs, + const double* alpha, const double* dl, + const double* d, const double* du, + const double* x, const int* ldx, const double* beta, + double* b, const int* ldb); +/* DLAGTS - may be used to solve one of the systems of equations */ +/* (T - lambda*I);*x = y or (T - lambda*I);'*x = y, */ +La_extern void +F77_NAME(dlagts)(const int* job, const int* n, + const double* a, const double* b, + const double* c, const double* d, + const int* in, double* y, double* tol, int* info); +/* DLAHQR - an auxiliary routine called by DHSEQR to update the */ +/* eigenvalues and Schur decomposition already computed by DHSEQR, */ +/* by dealing with the Hessenberg submatrix in rows and columns */ +/* ILO to IHI */ +La_extern void +F77_NAME(dlahqr)(const int* wantt, const int* wantz, const int* n, + const int* ilo, const int* ihi, + double* H, const int* ldh, double* wr, double* wi, + const int* iloz, const int* ihiz, + double* z, const int* ldz, int* info); +/* DLAHRD - reduce the first NB columns of a real general */ +/* n-by-(n-k+1); matrix A so that elements below the k-th */ +/* subdiagonal are zero */ +La_extern void +F77_NAME(dlahrd)(const int* n, const int* k, const int* nb, + double* a, const int* lda, + double* tau, double* t, const int* ldt, + double* y, const int* ldy); +/* DLAIC1 - apply one step of incremental condition estimation in */ +/* its simplest version */ +La_extern void +F77_NAME(dlaic1)(const int* job, const int* j, const double* x, + const double* sest, const double* w, + const double* gamma, double* sestpr, + double* s, double* c); +/* DLALN2 - solve a system of the form (ca A - w D ); X = s B or */ +/* (ca A' - w D); X = s B with possible scaling ("s"); and */ +/* perturbation of A */ +La_extern void +F77_NAME(dlaln2)(const int* ltrans, const int* na, const int* nw, + const double* smin, const double* ca, + const double* a, const int* lda, + const double* d1, const double* d2, + const double* b, const int* ldb, + const double* wr, const double* wi, + double* x, const int* ldx, double* scale, + double* xnorm, int* info); +/* DLAMCH - determine double precision machine parameters */ +La_extern double +F77_NAME(dlamch)(const char* cmach); +/* DLAMRG - will create a permutation list which will merge the */ +/* elements of A (which is composed of two independently sorted */ +/* sets); into a single set which is sorted in ascending order */ +La_extern void +F77_NAME(dlamrg)(const int* n1, const int* n2, const double* a, + const int* dtrd1, const int* dtrd2, int* index); +/* DLANGB - return the value of the one norm, or the Frobenius */ +/* norm, or the infinity norm, or the element of largest absolute */ +/* value of an n by n band matrix A, with kl sub-diagonals and ku */ +/* super-diagonals */ +La_extern double +F77_NAME(dlangb)(const char* norm, const int* n, + const int* kl, const int* ku, const double* ab, + const int* ldab, double* work); +/* DLANGE - return the value of the one norm, or the Frobenius */ +/* norm, or the infinity norm, or the element of largest absolute */ +/* value of a real matrix A */ +La_extern double +F77_NAME(dlange)(const char* norm, const int* m, const int* n, + const double* a, const int* lda, double* work); +/* DLANGT - return the value of the one norm, or the Frobenius */ +/* norm, or the infinity norm, or the element of largest absolute */ +/* value of a real tridiagonal matrix A */ +La_extern double +F77_NAME(dlangt)(const char* norm, const int* n, + const double* dl, const double* d, + const double* du); +/* DLANHS - return the value of the one norm, or the Frobenius */ +/* norm, or the infinity norm, or the element of largest absolute */ +/* value of a Hessenberg matrix A */ +La_extern double +F77_NAME(dlanhs)(const char* norm, const int* n, + const double* a, const int* lda, double* work); +/* DLANSB - return the value of the one norm, or the Frobenius */ +/* norm, or the infinity norm, or the element of largest absolute */ +/* value of an n by n symmetric band matrix A, with k */ +/* super-diagonals */ +La_extern double +F77_NAME(dlansb)(const char* norm, const char* uplo, + const int* n, const int* k, + const double* ab, const int* ldab, double* work); +/* DLANSP - return the value of the one norm, or the Frobenius */ +/* norm, or the infinity norm, or the element of largest absolute */ +/* value of a real symmetric matrix A, supplied in packed form */ +La_extern double +F77_NAME(dlansp)(const char* norm, const char* uplo, + const int* n, const double* ap, double* work); +/* DLANST - return the value of the one norm, or the Frobenius */ +/* norm, or the infinity norm, or the element of largest absolute */ +/* value of a real symmetric tridiagonal matrix A */ +La_extern double +F77_NAME(dlanst)(const char* norm, const int* n, + const double* d, const double* e); +/* DLANSY - return the value of the one norm, or the Frobenius */ +/* norm, or the infinity norm, or the element of largest absolute */ +/* value of a real symmetric matrix A */ +La_extern double +F77_NAME(dlansy)(const char* norm, const char* uplo, const int* n, + const double* a, const int* lda, double* work); +/* DLANTB - return the value of the one norm, or the Frobenius */ +/* norm, or the infinity norm, or the element of largest absolute */ +/* value of an n by n triangular band matrix A, with ( k + 1 ) diagonals */ +La_extern double +F77_NAME(dlantb)(const char* norm, const char* uplo, + const char* diag, const int* n, const int* k, + const double* ab, const int* ldab, double* work); +/* DLANTP - return the value of the one norm, or the Frobenius */ +/* norm, or the infinity norm, or the element of largest absolute */ +/* value of a triangular matrix A, supplied in packed form */ +La_extern double +F77_NAME(dlantp)(const char* norm, const char* uplo, const char* diag, + const int* n, const double* ap, double* work); +/* DLANTR - return the value of the one norm, or the Frobenius */ +/* norm, or the infinity norm, or the element of largest absolute */ +/* value of a trapezoidal or triangular matrix A */ +La_extern double +F77_NAME(dlantr)(const char* norm, const char* uplo, + const char* diag, const int* m, const int* n, + const double* a, const int* lda, double* work); +/* DLANV2 - compute the Schur factorization of a real 2-by-2 */ +/* nonsymmetric matrix in standard form */ +La_extern void +F77_NAME(dlanv2)(double* a, double* b, double* c, double* d, + double* rt1r, double* rt1i, double* rt2r, double* rt2i, + double* cs, double *sn); +/* DLAPLL - two column vectors X and Y, let A = ( X Y ); */ +La_extern void +F77_NAME(dlapll)(const int* n, double* x, const int* incx, + double* y, const int* incy, double* ssmin); +/* DLAPMT - rearrange the columns of the M by N matrix X as */ +/* specified by the permutation K(1);,K(2);,...,K(N); of the */ +/* integers 1,...,N */ +La_extern void +F77_NAME(dlapmt)(const int* forwrd, const int* m, const int* n, + double* x, const int* ldx, const int* k); +/* DLAPY2 - return sqrt(x**2+y**2);, taking care not to cause */ +/* unnecessary overflow */ +La_extern double +F77_NAME(dlapy2)(const double* x, const double* y); +/* DLAPY3 - return sqrt(x**2+y**2+z**2);, taking care not to */ +/* cause unnecessary overflow */ +La_extern double +F77_NAME(dlapy3)(const double* x, const double* y, const double* z); +/* DLAQGB - equilibrate a general M by N band matrix A with KL */ +/* subdiagonals and KU superdiagonals using the row and scaling */ +/* factors in the vectors R and C */ +La_extern void +F77_NAME(dlaqgb)(const int* m, const int* n, + const int* kl, const int* ku, + double* ab, const int* ldab, + double* r, double* c, + double* rowcnd, double* colcnd, + const double* amax, char* equed); +/* DLAQGE - equilibrate a general M by N matrix A using the row */ +/* and scaling factors in the vectors R and C */ +La_extern void +F77_NAME(dlaqge)(const int* m, const int* n, + double* a, const int* lda, + double* r, double* c, + double* rowcnd, double* colcnd, + const double* amax, char* equed); +/* DLAQSB - equilibrate a symmetric band matrix A using the */ +/* scaling factors in the vector S */ +La_extern void +F77_NAME(dlaqsb)(const char* uplo, const int* n, const int* kd, + double* ab, const int* ldab, const double* s, + const double* scond, const double* amax, char* equed); +/* DLAQSP - equilibrate a symmetric matrix A using the scaling */ +/* factors in the vector S */ +La_extern void +F77_NAME(dlaqsp)(const char* uplo, const int* n, + double* ap, const double* s, const double* scond, + const double* amax, int* equed); +/* DLAQSY - equilibrate a symmetric matrix A using the scaling */ +/* factors in the vector S */ +La_extern void +F77_NAME(dlaqsy)(const char* uplo, const int* n, + double* a, const int* lda, + const double* s, const double* scond, + const double* amax, int* equed); +/* DLAQTR - solve the real quasi-triangular system */ +/* op(T) * p = scale*c */ +La_extern void +F77_NAME(dlaqtr)(const int* ltran, const int* lreal, const int* n, + const double* t, const int* ldt, + const double* b, const double* w, + double* scale, double* x, double* work, int* info); +/* DLAR2V - apply a vector of real plane rotations from both */ +/* sides to a sequence of 2-by-2 real symmetric matrices, defined */ +/* by the elements of the vectors x, y and z */ +La_extern void +F77_NAME(dlar2v)(const int* n, double* x, double* y, + double* z, const int* incx, + const double* c, const double* s, + const int* incc); +/* DLARF - apply a real elementary reflector H to a real m by n */ +/* matrix C, from either the left or the right */ +La_extern void +F77_NAME(dlarf)(const char* side, const int* m, const int* n, + const double* v, const int* incv, const double* tau, + double* c, const int* ldc, double* work); +/* DLARFB - apply a real block reflector H or its transpose H' */ +/* to a real m by n matrix C, from either the left or the right */ +La_extern void +F77_NAME(dlarfb)(const char* side, const char* trans, + const char* direct, const char* storev, + const int* m, const int* n, const int* k, + const double* v, const int* ldv, + const double* t, const int* ldt, + double* c, const int* ldc, + double* work, const int* lwork); +/* DLARFG - generate a real elementary reflector H of order n, */ +/* such that H * ( alpha ) = ( beta ), H' * H = I */ +La_extern void +F77_NAME(dlarfg)(const int* n, const double* alpha, + double* x, const int* incx, double* tau); +/* DLARFT - form the triangular factor T of a real block */ +/* reflector H of order n, which is defined as a product of k */ +/* elementary reflectors */ +La_extern void +F77_NAME(dlarft)(const char* direct, const char* storev, + const int* n, const int* k, double* v, const int* ldv, + const double* tau, double* t, const int* ldt); +/* DLARFX - apply a real elementary reflector H to a real m by n */ +/* matrix C, from either the left or the right */ +La_extern void +F77_NAME(dlarfx)(const char* side, const int* m, const int* n, + const double* v, const double* tau, + double* c, const int* ldc, double* work); +/* DLARGV - generate a vector of real plane rotations, determined */ +/* by elements of the real vectors x and y */ +La_extern void +F77_NAME(dlargv)(const int* n, double* x, const int* incx, + double* y, const int* incy, double* c, const int* incc); +/* DLARNV - return a vector of n random real numbers from a */ +/* uniform or normal distribution */ +La_extern void +F77_NAME(dlarnv)(const int* idist, int* iseed, const int* n, double* x); +/* DLARTG - generate a plane rotation so that [ CS SN ] */ +La_extern void +F77_NAME(dlartg)(const double* f, const double* g, double* cs, + double* sn, double *r); +/* DLARTV - apply a vector of real plane rotations to elements of */ +/* the real vectors x and y */ +La_extern void +F77_NAME(dlartv)(const int* n, double* x, const int* incx, + double* y, const int* incy, + const double* c, const double* s, + const int* incc); +/* DLARUV - return a vector of n random real numbers from a */ +/* uniform (0,1); */ +La_extern void +F77_NAME(dlaruv)(int* iseed, const int* n, double* x); + +/* DLAS2 - compute the singular values of the 2-by-2 matrix */ +/* [ F G ] [ 0 H ] */ +La_extern void +F77_NAME(dlas2)(const double* f, const double* g, const double* h, + double* ssmin, double* ssmax); + +/* DLASCL - multiply the M by N real matrix A by the real scalar */ +/* CTO/CFROM */ +La_extern void +F77_NAME(dlascl)(const char* type, + const int* kl,const int* ku, + double* cfrom, double* cto, + const int* m, const int* n, + double* a, const int* lda, int* info); + +/* DLASET - initialize an m-by-n matrix A to BETA on the diagonal */ +/* and ALPHA on the offdiagonals */ +La_extern void +F77_NAME(dlaset)(const char* uplo, const int* m, const int* n, + const double* alpha, const double* beta, + double* a, const int* lda); +/* DLASQ1 - DLASQ1 computes the singular values of a real N-by-N */ +/* bidiagonal matrix with diagonal D and off-diagonal E */ +La_extern void +F77_NAME(dlasq1)(const int* n, double* d, double* e, + double* work, int* info); +/* DLASQ2 - DLASQ2 computes the singular values of a real N-by-N */ +/* unreduced bidiagonal matrix with squared diagonal elements in */ +/* Q and squared off-diagonal elements in E */ +La_extern void +F77_NAME(dlasq2)(const int* m, double* q, double* e, + double* qq, double* ee, const double* eps, + const double* tol2, const double* small2, + double* sup, int* kend, int* info); +/* DLASQ3 - DLASQ3 is the workhorse of the whole bidiagonal SVD */ +/* algorithm */ +La_extern void +F77_NAME(dlasq3)(int* n, double* q, double* e, double* qq, + double* ee, double* sup, double *sigma, + int* kend, int* off, int* iphase, + const int* iconv, const double* eps, + const double* tol2, const double* small2); +/* DLASQ4 - DLASQ4 estimates TAU, the smallest eigenvalue of a */ +/* matrix */ +La_extern void +F77_NAME(dlasq4)(const int* n, const double* q, const double* e, + double* tau, double* sup); +/* DLASR - perform the transformation A := P*A, when SIDE = 'L' */ +/* or 'l' ( Left-hand side ); A := A*P', when SIDE = 'R' or 'r' */ +/* ( Right-hand side ); where A is an m by n real matrix and P is */ +/* an orthogonal matrix, */ +La_extern void +F77_NAME(dlasr)(const char* side, const char* pivot, + const char* direct, const int* m, const int* n, + const double* c, const double* s, + double* a, const int* lda); +/* DLASRT - the numbers in D in increasing order (if ID = 'I'); */ +/* or in decreasing order (if ID = 'D' ); */ +La_extern void +F77_NAME(dlasrt)(const char* id, const int* n, double* d, int* info); +/* DLASSQ - return the values scl and smsq such that ( scl**2 */ +/* );*smsq = x( 1 );**2 +...+ x( n );**2 + ( scale**2 );*sumsq, */ +La_extern void +F77_NAME(dlassq)(const int* n, const double* x, const int* incx, + double* scale, double* sumsq); +/* DLASV2 - compute the singular value decomposition of a 2-by-2 */ +/* triangular matrix [ F G ] [ 0 H ] */ +La_extern void +F77_NAME(dlasv2)(const double* f, const double* g, const double* h, + double* ssmin, double* ssmax, double* snr, double* csr, + double* snl, double* csl); +/* DLASWP - perform a series of row interchanges on the matrix A */ +La_extern void +F77_NAME(dlaswp)(const int* n, double* a, const int* lda, + const int* k1, const int* k2, + const int* ipiv, const int* incx); +/* DLASY2 - solve for the N1 by N2 matrix double* x, 1 <= N1,N2 <= 2, in */ +/* op(TL);*X + ISGN*X*op(TR); = SCALE*B, */ +La_extern void +F77_NAME(dlasy2)(const int* ltranl, const int* ltranr, + const int* isgn, const int* n1, const int* n2, + const double* tl, const int* ldtl, + const double* tr, const int* ldtr, + const double* b, const int* ldb, + double* scale, double* x, const int* ldx, + double* xnorm, int* info); +/* DLASYF - compute a partial factorization of a real symmetric */ +/* matrix A using the Bunch-Kaufman diagonal pivoting method */ +La_extern void +F77_NAME(dlasyf)(const char* uplo, const int* n, + const int* nb, const int* kb, + double* a, const int* lda, int* ipiv, + double* w, const int* ldw, int* info); +/* DLATBS - solve one of the triangular systems A *x = s*b or */ +/* A'*x = s*b with scaling to prevent overflow, where A is an */ +/* upper or lower triangular band matrix */ +La_extern void +F77_NAME(dlatbs)(const char* uplo, const char* trans, + const char* diag, const char* normin, + const int* n, const int* kd, + const double* ab, const int* ldab, + double* x, double* scale, double* cnorm, int* info); +/* DLATPS - solve one of the triangular systems A *x = s*b or */ +/* A'*x = s*b with scaling to prevent overflow, where A is an */ +/* upper or lower triangular matrix stored in packed form */ +La_extern void +F77_NAME(dlatps)(const char* uplo, const char* trans, + const char* diag, const char* normin, + const int* n, const double* ap, + double* x, double* scale, double* cnorm, int* info); +/* DLATRD - reduce NB rows and columns of a real symmetric matrix */ +/* A to symmetric tridiagonal form by an orthogonal similarity */ +/* transformation Q' * A * Q, and returns the matrices V and W */ +/* which are needed to apply the transformation to the unreduced */ +/* part of A */ +La_extern void +F77_NAME(dlatrd)(const char* uplo, const int* n, const int* nb, + double* a, const int* lda, double* e, double* tau, + double* w, const int* ldw); +/* DLATRS - solve one of the triangular systems A *x = s*b or */ +/* A'*x = s*b with scaling to prevent overflow */ +La_extern void +F77_NAME(dlatrs)(const char* uplo, const char* trans, + const char* diag, const char* normin, + const int* n, const double* a, const int* lda, + double* x, double* scale, double* cnorm, int* info); +/* DLATZM - apply a Householder matrix generated by DTZRQF to a */ +/* matrix */ +La_extern void +F77_NAME(dlatzm)(const char* side, const int* m, const int* n, + const double* v, const int* incv, + const double* tau, double* c1, double* c2, + const int* ldc, double* work); +/* DLAUU2 - compute the product U * U' or L' * const int* l, where the */ +/* triangular factor U or L is stored in the upper or lower */ +/* triangular part of the array A */ +La_extern void +F77_NAME(dlauu2)(const char* uplo, const int* n, + double* a, const int* lda, int* info); +/* DLAUUM - compute the product U * U' or L' * L, where the */ +/* triangular factor U or L is stored in the upper or lower */ +/* triangular part of the array A */ +La_extern void +F77_NAME(dlauum)(const char* uplo, const int* n, + double* a, const int* lda, int* info); + + +/* ======================================================================== */ + +/* Selected Double Complex Lapack Routines + ======== + */ + +/* IZMAX1 finds the index of the element whose real part has maximum + * absolute value. */ +La_extern int +F77_NAME(izmax1)(const int *n, Rcomplex *cx, const int *incx); + + +/* ZGECON estimates the reciprocal of the condition number of a general + * complex matrix A, in either the 1-norm or the infinity-norm, using + * the LU factorization computed by ZGETRF. + */ +La_extern void +F77_NAME(zgecon)(const char *norm, const int *n, + const Rcomplex *a, const int *lda, + const double *anorm, double *rcond, + Rcomplex *work, double *rwork, int *info); + +/* ZGESV computes the solution to a complex system of linear equations */ +La_extern void +F77_NAME(zgesv)(const int *n, const int *nrhs, Rcomplex *a, + const int *lda, int *ipiv, Rcomplex *b, + const int *ldb, int *info); + +/* ZGEQP3 computes a QR factorization with column pivoting */ +La_extern void +F77_NAME(zgeqp3)(const int *m, const int *n, + Rcomplex *a, const int *lda, + int *jpvt, Rcomplex *tau, + Rcomplex *work, const int *lwork, + double *rwork, int *info); + +/* ZUNMQR applies Q or Q**H from the Left or Right */ +La_extern void +F77_NAME(zunmqr)(const char *side, const char *trans, + const int *m, const int *n, const int *k, + Rcomplex *a, const int *lda, + Rcomplex *tau, + Rcomplex *c, const int *ldc, + Rcomplex *work, const int *lwork, int *info); + +/* ZTRTRS solves triangular systems */ +La_extern void +F77_NAME(ztrtrs)(const char *uplo, const char *trans, const char *diag, + const int *n, const int *nrhs, + Rcomplex *a, const int *lda, + Rcomplex *b, const int *ldb, int *info); +/* ZGESVD - compute the singular value decomposition (SVD); of a */ +/* real M-by-N matrix A, optionally computing the left and/or */ +/* right singular vectors */ +La_extern void +F77_NAME(zgesvd)(const char *jobu, const char *jobvt, + const int *m, const int *n, + Rcomplex *a, const int *lda, double *s, + Rcomplex *u, const int *ldu, + Rcomplex *vt, const int *ldvt, + Rcomplex *work, const int *lwork, double *rwork, + int *info); + +/* ZGHEEV - compute all eigenvalues and, optionally, eigenvectors */ +/* of a Hermitian matrix A */ +La_extern void +F77_NAME(zheev)(const char *jobz, const char *uplo, + const int *n, Rcomplex *a, const int *lda, + double *w, Rcomplex *work, const int *lwork, + double *rwork, int *info); + +/* ZGGEEV - compute all eigenvalues and, optionally, eigenvectors */ +/* of a complex non-symmetric matrix A */ +La_extern void +F77_NAME(zgeev)(const char *jobvl, const char *jobvr, + const int *n, Rcomplex *a, const int *lda, + Rcomplex *wr, Rcomplex *vl, const int *ldvl, + Rcomplex *vr, const int *ldvr, + Rcomplex *work, const int *lwork, + double *rwork, int *info); + + +/* NOTE: The following entry points were traditionally in this file, + but are not provided by R's libRlapack */ + +/* DZSUM1 - take the sum of the absolute values of a complex */ +/* vector and returns a double precision result */ +La_extern double +F77_NAME(dzsum1)(const int *n, Rcomplex *CX, const int *incx); + +/* ZLACN2 estimates the 1-norm of a square, complex matrix A. + * Reverse communication is used for evaluating matrix-vector products. +*/ +La_extern void +F77_NAME(zlacn2)(const int *n, Rcomplex *v, Rcomplex *x, + double *est, int *kase, int *isave); + +/* ZLANTR - return the value of the one norm, or the Frobenius norm, */ +/* or the infinity norm, or the element of largest absolute value of */ +/* a trapezoidal or triangular matrix A */ +La_extern double +F77_NAME(zlantr)(const char *norm, const char *uplo, const char *diag, + const int *m, const int *n, Rcomplex *a, + const int *lda, double *work); + +/* ======================================================================== */ + +/* Other double precision and double complex Lapack routines + provided by libRlapack. + + These are extracted from the CLAPACK headers. +*/ + +La_extern void +F77_NAME(dbdsdc)(char *uplo, char *compq, int *n, double * + d, double *e, double *u, int *ldu, double *vt, + int *ldvt, double *q, int *iq, double *work, int * iwork, int *info); + +La_extern void +F77_NAME(dgegs)(char *jobvsl, char *jobvsr, int *n, + double *a, int *lda, double *b, int *ldb, double * + alphar, double *alphai, double *beta, double *vsl, + int *ldvsl, double *vsr, int *ldvsr, double *work, + int *lwork, int *info); + +La_extern void +F77_NAME(dgelsd)(int *m, int *n, int *nrhs, + double *a, int *lda, double *b, int *ldb, double * + s, double *rcond, int *rank, double *work, int *lwork, + int *iwork, int *info); + +La_extern void +F77_NAME(dgelsx)(int *m, int *n, int *nrhs, + double *a, int *lda, double *b, int *ldb, int * + jpvt, double *rcond, int *rank, double *work, int * + info); + +La_extern void +F77_NAME(dgesc2)(int *n, double *a, int *lda, + double *rhs, int *ipiv, int *jpiv, double *scale); + +/* DGESDD - compute the singular value decomposition (SVD); of a */ +/* real M-by-N matrix A, optionally computing the left and/or */ +/* right singular vectors. If singular vectors are desired, it uses a */ +/* divide-and-conquer algorithm. */ +La_extern void +F77_NAME(dgesdd)(const char *jobz, + const int *m, const int *n, + double *a, const int *lda, double *s, + double *u, const int *ldu, + double *vt, const int *ldvt, + double *work, const int *lwork, int *iwork, int *info); + +La_extern void +F77_NAME(dgetc2)(int *n, double *a, int *lda, int + *ipiv, int *jpiv, int *info); + +typedef int (*L_fp)(); +La_extern void +F77_NAME(dggesx)(char *jobvsl, char *jobvsr, char *sort, L_fp + delctg, char *sense, int *n, double *a, int *lda, + double *b, int *ldb, int *sdim, double *alphar, + double *alphai, double *beta, double *vsl, int *ldvsl, + double *vsr, int *ldvsr, double *rconde, double * + rcondv, double *work, int *lwork, int *iwork, int * + liwork, int *bwork, int *info); + +La_extern void +F77_NAME(dggev)(char *jobvl, char *jobvr, int *n, double * + a, int *lda, double *b, int *ldb, double *alphar, + double *alphai, double *beta, double *vl, int *ldvl, + double *vr, int *ldvr, double *work, int *lwork, + int *info); + +La_extern void +F77_NAME(dggevx)(char *balanc, char *jobvl, char *jobvr, char * + sense, int *n, double *a, int *lda, double *b, + int *ldb, double *alphar, double *alphai, double * + beta, double *vl, int *ldvl, double *vr, int *ldvr, + int *ilo, int *ihi, double *lscale, double *rscale, + double *abnrm, double *bbnrm, double *rconde, double * + rcondv, double *work, int *lwork, int *iwork, int * + bwork, int *info); + +La_extern void +F77_NAME(dggsvp)(char *jobu, char *jobv, char *jobq, int *m, + int *p, int *n, double *a, int *lda, double *b, + int *ldb, double *tola, double *tolb, int *k, int + *l, double *u, int *ldu, double *v, int *ldv, + double *q, int *ldq, int *iwork, double *tau, + double *work, int *info); + +La_extern void +F77_NAME(dgtts2)(int *itrans, int *n, int *nrhs, + double *dl, double *d, double *du, double *du2, + int *ipiv, double *b, int *ldb); +La_extern void +F77_NAME(dlagv2)(double *a, int *lda, double *b, int *ldb, double *alphar, + double *alphai, double * beta, double *csl, double *snl, + double *csr, double * snr); + +La_extern void +F77_NAME(dlals0)(int *icompq, int *nl, int *nr, + int *sqre, int *nrhs, double *b, int *ldb, double + *bx, int *ldbx, int *perm, int *givptr, int *givcol, + int *ldgcol, double *givnum, int *ldgnum, double * + poles, double *difl, double *difr, double *z, int * + k, double *c, double *s, double *work, int *info); + +La_extern void +F77_NAME(dlalsa)(int *icompq, int *smlsiz, int *n, + int *nrhs, double *b, int *ldb, double *bx, int * + ldbx, double *u, int *ldu, double *vt, int *k, + double *difl, double *difr, double *z, double * + poles, int *givptr, int *givcol, int *ldgcol, int * + perm, double *givnum, double *c, double *s, double * + work, int *iwork, int *info); + +La_extern void +F77_NAME(dlalsd)(char *uplo, int *smlsiz, int *n, int + *nrhs, double *d, double *e, double *b, int *ldb, + double *rcond, int *rank, double *work, int *iwork, + int *info); + +La_extern void +F77_NAME(dlamc1)(int *beta, int *t, int *rnd, int + *ieee1); + +La_extern void +F77_NAME(dlamc2)(int *beta, int *t, int *rnd, + double *eps, int *emin, double *rmin, int *emax, + double *rmax); + +La_extern double +F77_NAME(dlamc3)(double *a, double *b); + +La_extern void +F77_NAME(dlamc4)(int *emin, double *start, int *base); + +La_extern void +F77_NAME(dlamc5)(int *beta, int *p, int *emin, + int *ieee, int *emax, double *rmax); + +La_extern void +F77_NAME(dlaqp2)(int *m, int *n, int *offset, + double *a, int *lda, int *jpvt, double *tau, + double *vn1, double *vn2, double *work); + +La_extern void +F77_NAME(dlaqps)(int *m, int *n, int *offset, int + *nb, int *kb, double *a, int *lda, int *jpvt, + double *tau, double *vn1, double *vn2, double *auxv, + double *f, int *ldf); + +La_extern void +F77_NAME(dlar1v)(int *n, int *b1, int *bn, double + *sigma, double *d, double *l, double *ld, double * + lld, double *gersch, double *z, double *ztz, double + *mingma, int *r, int *isuppz, double *work); + +La_extern void +F77_NAME(dlarrb)(int *n, double *d, double *l, + double *ld, double *lld, int *ifirst, int *ilast, + double *sigma, double *reltol, double *w, double * + wgap, double *werr, double *work, int *iwork, int * + info); + +La_extern void +F77_NAME(dlarre)(int *n, double *d, double *e, + double *tol, int *nsplit, int *isplit, int *m, + double *w, double *woff, double *gersch, double *work, + int *info); + +La_extern void +F77_NAME(dlarrf)(int *n, double *d, double *l, + double *ld, double *lld, int *ifirst, int *ilast, + double *w, double *dplus, double *lplus, double *work, + int *iwork, int *info); + +La_extern void +F77_NAME(dlarrv)(int *n, double *d, double *l, + int *isplit, int *m, double *w, int *iblock, + double *gersch, double *tol, double *z, int *ldz, + int *isuppz, double *work, int *iwork, int *info); + +La_extern void +F77_NAME(dlarz)(char *side, int *m, int *n, int *l, + double *v, int *incv, double *tau, double *c, + int *ldc, double *work); + +La_extern void +F77_NAME(dlarzb)(char *side, char *trans, char *direct, char * + storev, int *m, int *n, int *k, int *l, double *v, + int *ldv, double *t, int *ldt, double *c, int * + ldc, double *work, int *ldwork); + +La_extern void +F77_NAME(dlarzt)(char *direct, char *storev, int *n, int * + k, double *v, int *ldv, double *tau, double *t, + int *ldt); + +La_extern void +F77_NAME(dlasd0)(int *n, int *sqre, double *d, + double *e, double *u, int *ldu, double *vt, int * + ldvt, int *smlsiz, int *iwork, double *work, int * + info); + +La_extern void +F77_NAME(dlasd1)(int *nl, int *nr, int *sqre, + double *d, double *alpha, double *beta, double *u, + int *ldu, double *vt, int *ldvt, int *idxq, int * + iwork, double *work, int *info); + +La_extern void +F77_NAME(dlasd2)(int *nl, int *nr, int *sqre, int + *k, double *d, double *z, double *alpha, double * + beta, double *u, int *ldu, double *vt, int *ldvt, + double *dsigma, double *u2, int *ldu2, double *vt2, + int *ldvt2, int *idxp, int *idx, int *idxc, int * + idxq, int *coltyp, int *info); + +La_extern void +F77_NAME(dlasd3)(int *nl, int *nr, int *sqre, int + *k, double *d, double *q, int *ldq, double *dsigma, + double *u, int *ldu, double *u2, int *ldu2, + double *vt, int *ldvt, double *vt2, int *ldvt2, + int *idxc, int *ctot, double *z, int *info); + +La_extern void +F77_NAME(dlasd4)(int *n, int *i, double *d, + double *z, double *delta, double *rho, double * + sigma, double *work, int *info); + +La_extern void +F77_NAME(dlasd5)(int *i, double *d, double *z, + double *delta, double *rho, double *dsigma, double * + work); + +La_extern void +F77_NAME(dlasd6)(int *icompq, int *nl, int *nr, + int *sqre, double *d, double *vf, double *vl, + double *alpha, double *beta, int *idxq, int *perm, + int *givptr, int *givcol, int *ldgcol, double *givnum, + int *ldgnum, double *poles, double *difl, double * + difr, double *z, int *k, double *c, double *s, + double *work, int *iwork, int *info); + +La_extern void +F77_NAME(dlasd7)(int *icompq, int *nl, int *nr, + int *sqre, int *k, double *d, double *z, + double *zw, double *vf, double *vfw, double *vl, + double *vlw, double *alpha, double *beta, double * + dsigma, int *idx, int *idxp, int *idxq, int *perm, + int *givptr, int *givcol, int *ldgcol, double *givnum, + int *ldgnum, double *c, double *s, int *info); + +La_extern void +F77_NAME(dlasd8)(int *icompq, int *k, double *d, + double *z, double *vf, double *vl, double *difl, + double *difr, int *lddifr, double *dsigma, double * + work, int *info); + +La_extern void +F77_NAME(dlasd9)(int *icompq, int *ldu, int *k, + double *d, double *z, double *vf, double *vl, + double *difl, double *difr, double *dsigma, double * + work, int *info); + +La_extern void +F77_NAME(dlasda)(int *icompq, int *smlsiz, int *n, + int *sqre, double *d, double *e, double *u, int + *ldu, double *vt, int *k, double *difl, double *difr, + double *z, double *poles, int *givptr, int *givcol, + int *ldgcol, int *perm, double *givnum, double *c, + double *s, double *work, int *iwork, int *info); + +La_extern void +F77_NAME(dlasdq)(char *uplo, int *sqre, int *n, int * + ncvt, int *nru, int *ncc, double *d, double *e, + double *vt, int *ldvt, double *u, int *ldu, + double *c, int *ldc, double *work, int *info); + +La_extern void +F77_NAME(dlasdt)(int *n, int *lvl, int *nd, int * + inode, int *ndiml, int *ndimr, int *msub); + +La_extern void +F77_NAME(dlasq5)(int *i0, int *n0, double *z, + int *pp, double *tau, double *dmin, double *dmin1, + double *dmin2, double *dn, double *dnm1, double *dnm2, + int *ieee); + +La_extern void +F77_NAME(dlasq6)(int *i0, int *n0, double *z, + int *pp, double *dmin, double *dmin1, double *dmin2, + double *dn, double *dnm1, double *dnm2); + +La_extern void +F77_NAME(dlatdf)(int *ijob, int *n, double *z, + int *ldz, double *rhs, double *rdsum, double *rdscal, + int *ipiv, int *jpiv); + +La_extern void +F77_NAME(dlatrz)(int *m, int *n, int *l, double * + a, int *lda, double *tau, double *work); + +La_extern void +F77_NAME(dormr3)(char *side, char *trans, int *m, int *n, + int *k, int *l, double *a, int *lda, double *tau, + double *c, int *ldc, double *work, int *info); + +La_extern void +F77_NAME(dormrz)(char *side, char *trans, int *m, int *n, + int *k, int *l, double *a, int *lda, double *tau, + double *c, int *ldc, double *work, int *lwork, + int *info); + +La_extern void +F77_NAME(dptts2)(int *n, int *nrhs, double *d, + double *e, double *b, int *ldb); + +La_extern void +F77_NAME(dsbgvd)(char *jobz, char *uplo, int *n, int *ka, + int *kb, double *ab, int *ldab, double *bb, int * + ldbb, double *w, double *z, int *ldz, double *work, + int *lwork, int *iwork, int *liwork, int *info); + +La_extern void +F77_NAME(dsbgvx)(char *jobz, char *range, char *uplo, int *n, + int *ka, int *kb, double *ab, int *ldab, double * + bb, int *ldbb, double *q, int *ldq, double *vl, + double *vu, int *il, int *iu, double *abstol, int + *m, double *w, double *z, int *ldz, double *work, + int *iwork, int *ifail, int *info); + +La_extern void +F77_NAME(dspgvd)(int *itype, char *jobz, char *uplo, int * + n, double *ap, double *bp, double *w, double *z, + int *ldz, double *work, int *lwork, int *iwork, + int *liwork, int *info); + +La_extern void +F77_NAME(dspgvx)(int *itype, char *jobz, char *range, char * + uplo, int *n, double *ap, double *bp, double *vl, + double *vu, int *il, int *iu, double *abstol, int + *m, double *w, double *z, int *ldz, double *work, + int *iwork, int *ifail, int *info); + +La_extern void +F77_NAME(dstegr)(char *jobz, char *range, int *n, double * + d, double *e, double *vl, double *vu, int *il, + int *iu, double *abstol, int *m, double *w, + double *z, int *ldz, int *isuppz, double *work, + int *lwork, int *iwork, int *liwork, int *info); + +La_extern void +F77_NAME(dstevr)(char *jobz, char *range, int *n, double * + d, double *e, double *vl, double *vu, int *il, + int *iu, double *abstol, int *m, double *w, + double *z, int *ldz, int *isuppz, double *work, + int *lwork, int *iwork, int *liwork, int *info); + +La_extern void +F77_NAME(dsygvd)(int *itype, char *jobz, char *uplo, int * + n, double *a, int *lda, double *b, int *ldb, + double *w, double *work, int *lwork, int *iwork, + int *liwork, int *info); + +La_extern void +F77_NAME(dsygvx)(int *itype, char *jobz, char *range, char * + uplo, int *n, double *a, int *lda, double *b, int + *ldb, double *vl, double *vu, int *il, int *iu, + double *abstol, int *m, double *w, double *z, + int *ldz, double *work, int *lwork, int *iwork, + int *ifail, int *info); + +La_extern void +F77_NAME(dtgex2)(int *wantq, int *wantz, int *n, + double *a, int *lda, double *b, int *ldb, double * + q, int *ldq, double *z, int *ldz, int *j1, int * + n1, int *n2, double *work, int *lwork, int *info); + +La_extern void +F77_NAME(dtgexc)(int *wantq, int *wantz, int *n, + double *a, int *lda, double *b, int *ldb, double * + q, int *ldq, double *z, int *ldz, int *ifst, + int *ilst, double *work, int *lwork, int *info); + +La_extern void +F77_NAME(dtgsen)(int *ijob, int *wantq, int *wantz, + int *select, int *n, double *a, int *lda, double * + b, int *ldb, double *alphar, double *alphai, double * + beta, double *q, int *ldq, double *z, int *ldz, + int *m, double *pl, double *pr, double *dif, + double *work, int *lwork, int *iwork, int *liwork, + int *info); + +La_extern void +F77_NAME(dtgsna)(char *job, char *howmny, int *select, + int *n, double *a, int *lda, double *b, int *ldb, + double *vl, int *ldvl, double *vr, int *ldvr, + double *s, double *dif, int *mm, int *m, double * + work, int *lwork, int *iwork, int *info); + +La_extern void +F77_NAME(dtgsy2)(char *trans, int *ijob, int *m, int * + n, double *a, int *lda, double *b, int *ldb, + double *c, int *ldc, double *d, int *ldd, + double *e, int *lde, double *f, int *ldf, double * + scale, double *rdsum, double *rdscal, int *iwork, int + *pq, int *info); + +La_extern void +F77_NAME(dtgsyl)(char *trans, int *ijob, int *m, int * + n, double *a, int *lda, double *b, int *ldb, + double *c, int *ldc, double *d, int *ldd, + double *e, int *lde, double *f, int *ldf, double * + scale, double *dif, double *work, int *lwork, int * + iwork, int *info); + +La_extern void +F77_NAME(dtzrzf)(int *m, int *n, double *a, int * + lda, double *tau, double *work, int *lwork, int *info); + +La_extern void +F77_NAME(dpstrf)(const char* uplo, const int* n, + double* a, const int* lda, int* piv, int* rank, + double* tol, double *work, int* info); + + +La_extern int +F77_NAME(lsame)(char *ca, char *cb); + +La_extern void +F77_NAME(zbdsqr)(char *uplo, int *n, int *ncvt, int * + nru, int *ncc, double *d, double *e, Rcomplex *vt, + int *ldvt, Rcomplex *u, int *ldu, Rcomplex *c, + int *ldc, double *rwork, int *info); + +La_extern void +F77_NAME(zdrot)(int *n, Rcomplex *cx, int *incx, + Rcomplex *cy, int *incy, double *c, double *s); + +La_extern void +F77_NAME(zgebak)(char *job, char *side, int *n, int *ilo, + int *ihi, double *scale, int *m, Rcomplex *v, + int *ldv, int *info); + +La_extern void +F77_NAME(zgebal)(char *job, int *n, Rcomplex *a, int + *lda, int *ilo, int *ihi, double *scale, int *info); + +La_extern void +F77_NAME(zgebd2)(int *m, int *n, Rcomplex *a, + int *lda, double *d, double *e, Rcomplex *tauq, + Rcomplex *taup, Rcomplex *work, int *info); + +La_extern void +F77_NAME(zgebrd)(int *m, int *n, Rcomplex *a, + int *lda, double *d, double *e, Rcomplex *tauq, + Rcomplex *taup, Rcomplex *work, int *lwork, int * + info); +La_extern void +F77_NAME(zgehd2)(int *n, int *ilo, int *ihi, + Rcomplex *a, int *lda, Rcomplex *tau, Rcomplex * + work, int *info); + +La_extern void +F77_NAME(zgehrd)(int *n, int *ilo, int *ihi, + Rcomplex *a, int *lda, Rcomplex *tau, Rcomplex * + work, int *lwork, int *info); + +La_extern void +F77_NAME(zgelq2)(int *m, int *n, Rcomplex *a, + int *lda, Rcomplex *tau, Rcomplex *work, int *info); + +La_extern void +F77_NAME(zgelqf)(int *m, int *n, Rcomplex *a, + int *lda, Rcomplex *tau, Rcomplex *work, int *lwork, + int *info); + +La_extern void +F77_NAME(zgeqr2)(int *m, int *n, Rcomplex *a, + int *lda, Rcomplex *tau, Rcomplex *work, int *info); + +La_extern void +F77_NAME(zgeqrf)(int *m, int *n, Rcomplex *a, + int *lda, Rcomplex *tau, Rcomplex *work, int *lwork, + int *info); + +La_extern void +F77_NAME(zgetf2)(int *m, int *n, Rcomplex *a, + int *lda, int *ipiv, int *info); + +La_extern void +F77_NAME(zgetrf)(int *m, int *n, Rcomplex *a, + int *lda, int *ipiv, int *info); + +La_extern void +F77_NAME(zgetrs)(char *trans, int *n, int *nrhs, + Rcomplex *a, int *lda, int *ipiv, Rcomplex *b, + int *ldb, int *info); + + +La_extern void +F77_NAME(zhetd2)(char *uplo, int *n, Rcomplex *a, int *lda, double *d, + double *e, Rcomplex *tau, int *info); + +La_extern void +F77_NAME(zhetrd)(char *uplo, int *n, Rcomplex *a, + int *lda, double *d, double *e, Rcomplex *tau, + Rcomplex *work, int *lwork, int *info); + +La_extern void +F77_NAME(zhseqr)(char *job, char *compz, int *n, int *ilo, + int *ihi, Rcomplex *h, int *ldh, Rcomplex *w, + Rcomplex *z, int *ldz, Rcomplex *work, int *lwork, + int *info); + +La_extern void +F77_NAME(zlabrd)(int *m, int *n, int *nb, + Rcomplex *a, int *lda, double *d, double *e, + Rcomplex *tauq, Rcomplex *taup, Rcomplex *x, int * + ldx, Rcomplex *y, int *ldy); + +La_extern void +F77_NAME(zlacgv)(int *n, Rcomplex *x, int *incx); + +La_extern void +F77_NAME(zlacpy)(char *uplo, int *m, int *n, + Rcomplex *a, int *lda, Rcomplex *b, int *ldb); + +La_extern void +F77_NAME(zlahqr)(int *wantt, int *wantz, int *n, + int *ilo, int *ihi, Rcomplex *h, int *ldh, + Rcomplex *w, int *iloz, int *ihiz, Rcomplex *z, + int *ldz, int *info); + +La_extern void +F77_NAME(zlahrd)(int *n, int *k, int *nb, + Rcomplex *a, int *lda, Rcomplex *tau, Rcomplex *t, + int *ldt, Rcomplex *y, int *ldy); + +La_extern double +F77_NAME(zlange)(char *norm, int *m, int *n, Rcomplex *a, int *lda, + double *work); + +La_extern double +F77_NAME(zlanhe)(char *norm, char *uplo, int *n, Rcomplex *a, + int *lda, double *work); + +La_extern double +F77_NAME(zlanhs)(char *norm, int *n, Rcomplex *a, int *lda, double *work); + + +La_extern void +F77_NAME(zlaqp2)(int *m, int *n, int *offset, + Rcomplex *a, int *lda, int *jpvt, Rcomplex *tau, + double *vn1, double *vn2, Rcomplex *work); + +La_extern void +F77_NAME(zlaqps)(int *m, int *n, int *offset, int + *nb, int *kb, Rcomplex *a, int *lda, int *jpvt, + Rcomplex *tau, double *vn1, double *vn2, Rcomplex * + auxv, Rcomplex *f, int *ldf); + +La_extern void +F77_NAME(zlarf)(char *side, int *m, int *n, Rcomplex + *v, int *incv, Rcomplex *tau, Rcomplex *c, int * + ldc, Rcomplex *work); + +La_extern void +F77_NAME(zlarfb)(char *side, char *trans, char *direct, char * + storev, int *m, int *n, int *k, Rcomplex *v, int + *ldv, Rcomplex *t, int *ldt, Rcomplex *c, int * + ldc, Rcomplex *work, int *ldwork); + +La_extern void +F77_NAME(zlarfg)(int *n, Rcomplex *alpha, Rcomplex * + x, int *incx, Rcomplex *tau); + +La_extern void +F77_NAME(zlarft)(char *direct, char *storev, int *n, int * + k, Rcomplex *v, int *ldv, Rcomplex *tau, Rcomplex * + t, int *ldt); + +La_extern void +F77_NAME(zlarfx)(char *side, int *m, int *n, + Rcomplex *v, Rcomplex *tau, Rcomplex *c, int * + ldc, Rcomplex *work); + +La_extern void +F77_NAME(zlascl)(char *type, int *kl, int *ku, + double *cfrom, double *cto, int *m, int *n, + Rcomplex *a, int *lda, int *info); + +La_extern void +F77_NAME(zlaset)(char *uplo, int *m, int *n, + Rcomplex *alpha, Rcomplex *beta, Rcomplex *a, int * + lda); + +La_extern void +F77_NAME(zlasr)(char *side, char *pivot, char *direct, int *m, + int *n, double *c, double *s, Rcomplex *a, + int *lda); + +La_extern void +F77_NAME(zlassq)(int *n, Rcomplex *x, int *incx, + double *scale, double *sumsq); + +La_extern void +F77_NAME(zlaswp)(int *n, Rcomplex *a, int *lda, + int *k1, int *k2, int *ipiv, int *incx); + +La_extern void +F77_NAME(zlatrd)(char *uplo, int *n, int *nb, + Rcomplex *a, int *lda, double *e, Rcomplex *tau, + Rcomplex *w, int *ldw); + +La_extern void +F77_NAME(zlatrs)(char *uplo, char *trans, char *diag, char * + normin, int *n, Rcomplex *a, int *lda, Rcomplex *x, + double *scale, double *cnorm, int *info); + +La_extern void +F77_NAME(zsteqr)(char *compz, int *n, double *d, + double *e, Rcomplex *z, int *ldz, double *work, + int *info); + +/* ZTRCON estimates the reciprocal of the condition number of a + * triangular matrix A, in either the 1-norm or the infinity-norm. + */ +La_extern void +F77_NAME(ztrcon)(const char *norm, const char *uplo, const char *diag, + const int *n, const Rcomplex *a, const int *lda, + double *rcond, Rcomplex *work, double *rwork, int *info); + +La_extern void +F77_NAME(ztrevc)(char *side, char *howmny, int *select, + int *n, Rcomplex *t, int *ldt, Rcomplex *vl, + int *ldvl, Rcomplex *vr, int *ldvr, int *mm, int + *m, Rcomplex *work, double *rwork, int *info); + +La_extern void +F77_NAME(zung2l)(int *m, int *n, int *k, + Rcomplex *a, int *lda, Rcomplex *tau, Rcomplex * + work, int *info); + +La_extern void +F77_NAME(zung2r)(int *m, int *n, int *k, + Rcomplex *a, int *lda, Rcomplex *tau, Rcomplex * + work, int *info); + +La_extern void +F77_NAME(zungbr)(char *vect, int *m, int *n, int *k, + Rcomplex *a, int *lda, Rcomplex *tau, Rcomplex * + work, int *lwork, int *info); + +La_extern void +F77_NAME(zunghr)(int *n, int *ilo, int *ihi, + Rcomplex *a, int *lda, Rcomplex *tau, Rcomplex * + work, int *lwork, int *info); + +La_extern void +F77_NAME(zungl2)(int *m, int *n, int *k, + Rcomplex *a, int *lda, Rcomplex *tau, Rcomplex * + work, int *info); + +La_extern void +F77_NAME(zunglq)(int *m, int *n, int *k, + Rcomplex *a, int *lda, Rcomplex *tau, Rcomplex * + work, int *lwork, int *info); + +La_extern void +F77_NAME(zungql)(int *m, int *n, int *k, + Rcomplex *a, int *lda, Rcomplex *tau, Rcomplex * + work, int *lwork, int *info); + +La_extern void +F77_NAME(zungqr)(int *m, int *n, int *k, + Rcomplex *a, int *lda, Rcomplex *tau, Rcomplex * + work, int *lwork, int *info); + +La_extern void +F77_NAME(zungr2)(int *m, int *n, int *k, + Rcomplex *a, int *lda, Rcomplex *tau, Rcomplex * + work, int *info); + +La_extern void +F77_NAME(zungrq)(int *m, int *n, int *k, + Rcomplex *a, int *lda, Rcomplex *tau, Rcomplex * + work, int *lwork, int *info); + +La_extern void +F77_NAME(zungtr)(char *uplo, int *n, Rcomplex *a, + int *lda, Rcomplex *tau, Rcomplex *work, int *lwork, + int *info); + +La_extern void +F77_NAME(zunm2r)(char *side, char *trans, int *m, int *n, + int *k, Rcomplex *a, int *lda, Rcomplex *tau, + Rcomplex *c, int *ldc, Rcomplex *work, int *info); + +La_extern void +F77_NAME(zunmbr)(char *vect, char *side, char *trans, int *m, + int *n, int *k, Rcomplex *a, int *lda, Rcomplex + *tau, Rcomplex *c, int *ldc, Rcomplex *work, int * + lwork, int *info); + +La_extern void +F77_NAME(zunml2)(char *side, char *trans, int *m, int *n, + int *k, Rcomplex *a, int *lda, Rcomplex *tau, + Rcomplex *c, int *ldc, Rcomplex *work, int *info); + +La_extern void +F77_NAME(zunmlq)(char *side, char *trans, int *m, int *n, + int *k, Rcomplex *a, int *lda, Rcomplex *tau, + Rcomplex *c, int *ldc, Rcomplex *work, int *lwork, + int *info); + +#ifdef __cplusplus +} +#endif + +#endif /* R_LAPACK_H */ diff --git a/var_lib_genenet_bnw/localscore/Linpack.h b/var_lib_genenet_bnw/localscore/Linpack.h new file mode 100644 index 00000000..95cb753e --- /dev/null +++ b/var_lib_genenet_bnw/localscore/Linpack.h @@ -0,0 +1,89 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 1997 Robert Gentleman and Ross Ihaka + * Copyright (C) 1999-2002 The R Core Team. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +/* + C declarations of double-precision LINPACK Fortran subroutines + included in R, and some others. + + Those which are listed as part of R are in the API + */ + +#ifndef R_LINPACK_H_ +#define R_LINPACK_H_ + +#include <R_ext/RS.h> /* for F77_... */ +#include <R_ext/BLAS.h> + +#ifdef __cplusplus +extern "C" { +#endif + + /* Double Precision Linpack */ + +extern void F77_NAME(dchdc)(double*, int*, int*, double*, int*, int*, int*); +extern void F77_NAME(dpbfa)(double*, int*, int*, int*, int*); +extern void F77_NAME(dpbsl)(double*, int*, int*, int*, double*); +extern void F77_NAME(dpoco)(double*, int*, int*, double*, double*, int*); +extern void F77_NAME(dpodi)(double*, int*, int*, double*, int*); +extern void F77_NAME(dpofa)(double*, int*, int*, int*); +extern void F77_NAME(dposl)(double*, int*, int*, double*); +extern void F77_NAME(dqrdc)(double*, int*, int*, int*, double*, int*, double*, int*); +extern void F77_NAME(dqrsl)(double*, int*, int*, int*, double*, double*, double*, double*, double*, double*, double*, int*, int*); +extern void F77_NAME(dsvdc)(double*, int*, int*, int*, double*, double*, double*, int*, double*, int*, double*, int*, int*); +extern void F77_NAME(dtrco)(double*, int*, int*, double*, double*, int*); +extern void F77_NAME(dtrsl)(double*, int*, int*, double*, int*, int*); + + +/* The following routines are listed as they have always been declared + here, but they are not currently included in R */ +extern void F77_NAME(dchdc)(double*, int*, int*, double*, int*, int*, int*); +extern void F77_NAME(dchdd)(double*, int*, int*, double*, double*, int*, int*, double*, double*, double*, double*, int*); +extern void F77_NAME(dchex)(double*, int*, int*, int*, int*, double*, int*, int*, double*, double*, int*); +extern void F77_NAME(dchud)(double*, int*, int*, double*, double*, int*, int*, double*, double*, double*, double*); +extern void F77_NAME(dgbco)(double*, int*, int*, int*, int*, int*, double*, double*); +extern void F77_NAME(dgbdi)(double*, int*, int*, int*, int*, int*, double*); +extern void F77_NAME(dgbfa)(double*, int*, int*, int*, int*, int*, int*); +extern void F77_NAME(dgbsl)(double*, int*, int*, int*, int*, int*, double*, int*); +extern void F77_NAME(dgeco)(double*, int*, int*, int*, double*, double*); +extern void F77_NAME(dgedi)(double*, int*, int*, int*, double*, double*, int*); +extern void F77_NAME(dgefa)(double*, int*, int*, int*, int*); +extern void F77_NAME(dgesl)(double*, int*, int*, int*, double*, int*); +extern void F77_NAME(dgtsl)(int*, double*, double*, double*, double*, int*); +extern void F77_NAME(dpbco)(double*, int*, int*, int*, double*, double*, int*); +extern void F77_NAME(dpbdi)(double*, int*, int*, int*, double*); +extern void F77_NAME(dppco)(double*, int*, double*, double*, int*); +extern void F77_NAME(dppdi)(double*, int*, double*, int*); +extern void F77_NAME(dppfa)(double*, int*, int*); +extern void F77_NAME(dppsl)(double*, int*, double*); +extern void F77_NAME(dptsl)(int*, double*, double*, double*); +extern void F77_NAME(dsico)(double*, int*, int*, int*, double*, double*); +extern void F77_NAME(dsidi)(double*, int*, int*, int*, double*, int*, double*, int*); +extern void F77_NAME(dsifa)(double*, int*, int*, int*, int*); +extern void F77_NAME(dsisl)(double*, int*, int*, int*, double*); +extern void F77_NAME(dspco)(double*, int*, int*, double*, double*); +extern void F77_NAME(dspdi)(double*, int*, int*, double*, int*, double*, int*); +extern void F77_NAME(dspfa)(double*, int*, int*, int*); +extern void F77_NAME(dspsl)(double*, int*, int*, double*); + +#ifdef __cplusplus +} +#endif + +#endif /* R_LINPACK_H_ */ diff --git a/var_lib_genenet_bnw/localscore/MathThreads.h b/var_lib_genenet_bnw/localscore/MathThreads.h new file mode 100644 index 00000000..41234442 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/MathThreads.h @@ -0,0 +1,39 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 2000, 2001 The R Core Team. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +/* + Experimental: included by src/library/stats/src/distance.c +*/ + +#ifndef R_EXT_MATHTHREADS_H_ +#define R_EXT_MATHTHREADS_H_ + +#ifdef __cplusplus +extern "C" { +#endif + +#include <R_ext/libextern.h> +LibExtern int R_num_math_threads; +LibExtern int R_max_num_math_threads; + +#ifdef __cplusplus +} +#endif + +#endif /* R_EXT_MATHTHREADS_H_ */ diff --git a/var_lib_genenet_bnw/localscore/Memory.h b/var_lib_genenet_bnw/localscore/Memory.h new file mode 100644 index 00000000..306c9835 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/Memory.h @@ -0,0 +1,49 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 1998-2007 The R Core Team + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + * + * + * Memory Allocation (garbage collected) --- INCLUDING S compatibility --- + */ + +/* Included by R.h: API */ + +#ifndef R_EXT_MEMORY_H_ +#define R_EXT_MEMORY_H_ + +#ifndef NO_C_HEADERS +# include <stddef.h> /* for size_t */ +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +void* vmaxget(void); +void vmaxset(const void *); + +void R_gc(void); + +char* R_alloc(size_t, int); +char* S_alloc(long, int); +char* S_realloc(char *, long, long, int); + +#ifdef __cplusplus +} +#endif + +#endif /* R_EXT_MEMORY_H_ */ diff --git a/var_lib_genenet_bnw/localscore/Parse.h b/var_lib_genenet_bnw/localscore/Parse.h new file mode 100644 index 00000000..a1d8cc87 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/Parse.h @@ -0,0 +1,47 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 1998-2006 R Core Team + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +/* NOTE: + This file exports a part of the current internal parse interface. + It is subject to change at any minor (x.y.0) version of R. + */ + +#ifndef R_EXT_PARSE_H_ +#define R_EXT_PARSE_H_ + +#ifdef __cplusplus +extern "C" { +#endif + +/* PARSE_NULL will not be returned by R_ParseVector */ +typedef enum { + PARSE_NULL, + PARSE_OK, + PARSE_INCOMPLETE, + PARSE_ERROR, + PARSE_EOF +} ParseStatus; + +SEXP R_ParseVector(SEXP, int, ParseStatus *, SEXP); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/var_lib_genenet_bnw/localscore/Print.h b/var_lib_genenet_bnw/localscore/Print.h new file mode 100644 index 00000000..7beeaf17 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/Print.h @@ -0,0 +1,50 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 1998-2010 The R Core Team + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +/* Included by R.h: API */ + +#ifndef R_EXT_PRINT_H_ +#define R_EXT_PRINT_H_ + +#ifdef __cplusplus +/* If the vprintf interface is defined at all in C++ it may only be + defined in namespace std. */ +# ifdef R_USE_C99_IN_CXX +# include <cstdarg> +# ifdef __SUNPRO_CC +using _STLP_VENDOR_CSTD::va_list; +# endif +# endif +extern "C" { +#else +# include <stdarg.h> +#endif + +void Rprintf(const char *, ...); +void REprintf(const char *, ...); +#if !defined(__cplusplus) || defined R_USE_C99_IN_CXX +void Rvprintf(const char *, va_list); +void REvprintf(const char *, va_list); +#endif + +#ifdef __cplusplus +} +#endif + +#endif /* R_EXT_PRINT_H_ */ diff --git a/var_lib_genenet_bnw/localscore/PrtUtil.h b/var_lib_genenet_bnw/localscore/PrtUtil.h new file mode 100644 index 00000000..1ef06d9a --- /dev/null +++ b/var_lib_genenet_bnw/localscore/PrtUtil.h @@ -0,0 +1,71 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 1998-2012 The R Core Team + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +/* + * These functions are not part of the API. + */ +#ifndef PRTUTIL_H_ +#define PRTUTIL_H_ + +#include <R_ext/Complex.h> +#include <R_ext/Print.h> + +#define formatLogical Rf_formatLogical +#define formatInteger Rf_formatInteger +#define formatReal Rf_formatReal +#define formatComplex Rf_formatComplex +#define EncodeLogical Rf_EncodeLogical +#define EncodeInteger Rf_EncodeInteger +#define EncodeReal Rf_EncodeReal +#define EncodeComplex Rf_EncodeComplex +#define VectorIndex Rf_VectorIndex +#define printIntegerVector Rf_printIntegerVector +#define printRealVector Rf_printRealVector +#define printComplexVector Rf_printComplexVector + +#ifdef __cplusplus +extern "C" { +#endif + +/* Computation of printing formats */ +void formatLogical(int *, int, int *); +void formatInteger(int *, int, int *); +void formatReal(double *, int, int *, int *, int *, int); +void formatComplex(Rcomplex *, int, int *, int *, int *, int *, int *, int *, int); + +/* Formating of values */ +const char *EncodeLogical(int, int); +const char *EncodeInteger(int, int); +const char *EncodeReal(double, int, int, int, char); +const char *EncodeComplex(Rcomplex, int, int, int, int, int, int, char); + +/* Printing */ +void VectorIndex(int, int); + +void printLogicalVector(int *, int, int); +void printIntegerVector(int *, int, int); +void printRealVector (double *, int, int); +void printComplexVector(Rcomplex *,int, int); + +/* char *Rsprintf(char*, ...); */ +#ifdef __cplusplus +} +#endif + +#endif /* PRTUTIL_H_ */ diff --git a/var_lib_genenet_bnw/localscore/QuartzDevice.h b/var_lib_genenet_bnw/localscore/QuartzDevice.h new file mode 100644 index 00000000..ceb513e2 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/QuartzDevice.h @@ -0,0 +1,235 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 2007 The R Core Team + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + * + *--------------------------------------------------------------------- + * This header file constitutes the (unofficial) API to the Quartz + * device. Being unofficial, the API may change at any point without + * warning. + * + * Quartz is a general device-independent way of drawing in Mac OS X, + * therefore the Quartz device modularizes the actual drawing target + * implementation into separate modules (e.g. Carbon and Cocoa for + * on-screen display and PDF, Bitmap for off-screen drawing). The API + * below is used by the modules to talk to the Quartz device without + * having to know anything about R graphics device API. + * + * Key functions are listed here: + * QuartzDevice_Create - creates a Quartz device + * QuartzDevice_ResetContext - should be called after the target + * context has been created to initialize it. + * QuartzDevice_Kill - closes the Quartz device (e.g. on window close) + * QuartzDevice_SetScaledSize - resize device (does not include + * re-painting, it should be followed by a call to + * QuartzDevice_ReplayDisplayList) + * QuartzDevice_ReplayDisplayList - replays all plot commands + * + * Key concepts + * - all Quartz modules are expected to provide a device context + * (CGContextRef) for drawing. A device can temporarily return NULL + * (e.g. if the context is not available immediately) and replay + * the display list later to catch up. + * + * - interactive devices can use QuartzDevice_SetScaledSize to resize + * the device (no context is necessary), then prepare the context + * (call QuartzDevice_ResetContext if a new context was created) + * and finally re-draw using QuartzDevice_ReplayDisplayList. + * + * - snapshots can be created either off the current display list + * (last=0) or off the last known one (last=1). NewPage callback + * can only use last=1 as there is no display list during that + * call. Restored snapshots become the current display list and + * thus can be extended by further painting (yet the original saved + * copy is not influenced). Also note that all snapshots are SEXPs + * (the declaration doesn't use SEXP as to not depend on + * Rinternals.h) therefore must be protected or preserved immediately + * (i.e. the Quartz device does NOT protect them - except in the + * call to RestoreSnapshot). + * + * - dirty flag: the dirty flag is not used internally by the Quartz + * device, but can be useful for the modules to determine whether + * the current graphics is a restored copy or in-progress + * drawing. The Quartz device manages the flag as follows: a) + * display list replay does NOT change the flag, b) snapshot + * restoration resets the flag, c) all other paint operations + * (i.e. outside of restore/replay) set the flag. Most common use + * is to determine whether restored snapshots have been + * subsequently modified. + * + * - history: currently the history management is not used by any + * modules and as such is untested and strictly experimental. It + * may be removed in the future as it is not clear whether it makes + * sense to be part of the device. See Cocoa module for a + * module-internal implementation of the display history. + * + * Quartz device creation path: + * quartz() function -> SEXP Quartz(args) -> + * setup QuartzParameters_t, call backend constructor + * [e.g. QuartzCocoa_DeviceCreate(dd, fn, QuartzParameters_t *pars)] -> + * create backend definition (QuartzBackend_t backend) -> + * fn->Create(dd, &backend), return the result + */ + +#ifndef R_EXT_QUARTZDEVICE_H_ +#define R_EXT_QUARTZDEVICE_H_ + +/* FIXME: this is installed, but can it really work without config.h */ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +#if HAVE_AQUA +#include <ApplicationServices/ApplicationServices.h> +#else + typedef void* CGContextRef; +#endif + +/* flags passed to the newPage callback */ +#define QNPF_REDRAW 0x0001 /* is set when NewPage really means re-draw of an existing page */ + +/* flags passed to QuartzDevice_Create (as fs parameter) */ +#define QDFLAG_DISPLAY_LIST 0x0001 +#define QDFLAG_INTERACTIVE 0x0002 +#define QDFLAG_RASTERIZED 0x0004 /* rasterized media - may imply disabling AA paritally for rects etc. */ + +/* parameter flags (they should not conflict with QDFLAGS to allow chaining) */ +#define QPFLAG_ANTIALIAS 0x0100 + +typedef void* QuartzDesc_t; + +typedef struct QuartzBackend_s { + int size; /* structure size */ + double width, height; + double scalex, scaley, pointsize; + int bg, canvas; + int flags; + void* userInfo; + CGContextRef (*getCGContext)(QuartzDesc_t dev, void*userInfo); /* Get the context for this device */ + int (*locatePoint)(QuartzDesc_t dev, void*userInfo, double*x, double*y); + void (*close)(QuartzDesc_t dev, void*userInfo); + void (*newPage)(QuartzDesc_t dev, void*userInfo, int flags); + void (*state)(QuartzDesc_t dev, void*userInfo, int state); + void* (*par)(QuartzDesc_t dev, void*userInfo, int set, const char *key, void *value); + void (*sync)(QuartzDesc_t dev, void*userInfo); + void* (*cap)(QuartzDesc_t dev, void*userInfo); +} QuartzBackend_t; + +/* parameters that are passed to functions that create backends */ +typedef struct QuartzParameters_s { + int size; /* structure size */ + const char *type, *file, *title; + double x, y, width, height, pointsize; + const char *family; + int flags; + int connection; + int bg, canvas; + double *dpi; + /* the following parameters can be used to pass custom parameters when desired */ + double pard1, pard2; + int pari1, pari2; + const char *pars1, *pars2; + void *parv; +} QuartzParameters_t; + +/* all device implementations have to call this general Quartz device constructor at some point */ +QuartzDesc_t QuartzDevice_Create(void *dd, QuartzBackend_t* def); + +typedef struct QuartzFunctons_s { + void* (*Create)(void *, QuartzBackend_t *); /* create a new device */ + int (*DevNumber)(QuartzDesc_t desc); /* returns device number */ + void (*Kill)(QuartzDesc_t desc); /* call to close the device */ + void (*ResetContext)(QuartzDesc_t desc); /* notifies Q back-end that the implementation has created a new context */ + double (*GetWidth)(QuartzDesc_t desc); /* get device width (in inches) */ + double (*GetHeight)(QuartzDesc_t desc); /* get device height (in inches) */ + void (*SetSize)(QuartzDesc_t desc, double width, double height); /* set device size (in inches) */ + + double (*GetScaledWidth)(QuartzDesc_t desc); /* get device width (in pixels) */ + double (*GetScaledHeight)(QuartzDesc_t desc); /* get device height (in pixels) */ + void (*SetScaledSize)(QuartzDesc_t desc, double width, double height); /* set device size (in pixels) */ + + double (*GetXScale)(QuartzDesc_t desc); /* get x scale factor (px/pt ratio) */ + double (*GetYScale)(QuartzDesc_t desc); /* get y scale factor (px/pt ratio) */ + void (*SetScale)(QuartzDesc_t desc,double scalex, double scaley); /* sets both scale factors (px/pt ratio) */ + + void (*SetTextScale)(QuartzDesc_t desc,double scale); /* sets text scale factor */ + double (*GetTextScale)(QuartzDesc_t desc); /* sets text scale factor */ + + void (*SetPointSize)(QuartzDesc_t desc,double ps); /* sets point size */ + double (*GetPointSize)(QuartzDesc_t desc); /* gets point size */ + + int (*GetDirty)(QuartzDesc_t desc); /* sets dirty flag */ + void (*SetDirty)(QuartzDesc_t desc,int dirty); /* gets dirty flag */ + + void (*ReplayDisplayList)(QuartzDesc_t desc); /* replay display list + Note: it inhibits sync calls during repaint, + the caller is responsible for calling sync if needed. + Dirty flag is kept unmodified */ + void* (*GetSnapshot)(QuartzDesc_t desc, int last); + /* create a (replayable) snapshot of the device contents. + when 'last' is set then the last stored display list is used, + otherwise a new snapshot is created */ + void (*RestoreSnapshot)(QuartzDesc_t desc,void* snapshot); + /* restore a snapshot. also clears the dirty flag */ + + int (*GetAntialias)(QuartzDesc_t desc); /* get anti-alias flag */ + void (*SetAntialias)(QuartzDesc_t desc, int aa); /* set anti-alias flag */ + + int (*GetBackground)(QuartzDesc_t desc); /* get background color */ + void (*Activate)(QuartzDesc_t desc); /* activate/select the device */ + /* get/set Quartz-specific parameters. desc can be NULL for global parameters */ + void* (*SetParameter)(QuartzDesc_t desc, const char *key, void *value); + void* (*GetParameter)(QuartzDesc_t desc, const char *key); +} QuartzFunctions_t; + +#define QuartzParam_EmbeddingFlags "embeddeding flags" /* value: int[1] */ +#define QP_Flags_CFLoop 0x0001 /* drives application event loop */ +#define QP_Flags_Cocoa 0x0002 /* Cocoa is fully initialized */ +#define QP_Flags_Front 0x0004 /* is front application */ + +/* from unix/aqua.c - loads grDevices if necessary and returns NULL on failure */ +QuartzFunctions_t *getQuartzFunctions(); + +/* type of a Quartz contructor */ +typedef QuartzDesc_t (*quartz_create_fn_t)(void *dd, QuartzFunctions_t *fn, QuartzParameters_t *par); + +/* grDevices currently supply following constructors: + QuartzCocoa_DeviceCreate, QuartzCarbon_DeviceCreate, + QuartzBitmap_DeviceCreate, QuartzPDF_DeviceCreate */ + +/* embedded Quartz support hook (defined in unix/aqua.c): + dd = should be passed-through to QuartzDevice_Create + fn = Quartz API functions + par = parameters (see above) */ +#ifndef IN_AQUA_C + extern +#endif + QuartzDesc_t (*ptr_QuartzBackend)(void *dd, QuartzFunctions_t *fn, QuartzParameters_t *par); + +/* C version of the Quartz call (experimental) + returns 0 on success, error code on failure */ +QuartzDesc_t Quartz_C(QuartzParameters_t *par, quartz_create_fn_t q_create, int *errorCode); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/var_lib_genenet_bnw/localscore/R-ftp-http.h b/var_lib_genenet_bnw/localscore/R-ftp-http.h new file mode 100644 index 00000000..665bfb87 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/R-ftp-http.h @@ -0,0 +1,65 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 2001-6 The R Core Team. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +/* Advertized entry points, for that part of libxml included in + * the internet module. + */ + +#ifndef R_FTP_HTTP_H_ +#define R_FTP_HTTP_H_ + +#ifdef __cplusplus +extern "C" { +#endif + +void *R_HTTPOpen(const char *url); +int R_HTTPRead(void *ctx, char *dest, int len); +void R_HTTPClose(void *ctx); + +void *R_FTPOpen(const char *url); +int R_FTPRead(void *ctx, char *dest, int len); +void R_FTPClose(void *ctx); + +void * RxmlNanoHTTPOpen(const char *URL, char **contentType, const char *headers, int cacheOK); +int RxmlNanoHTTPRead(void *ctx, void *dest, int len); +void RxmlNanoHTTPClose(void *ctx); +int RxmlNanoHTTPReturnCode(void *ctx); +char * RxmlNanoHTTPStatusMsg(void *ctx); +int RxmlNanoHTTPContentLength(void *ctx); +char * RxmlNanoHTTPContentType(void *ctx); +void RxmlNanoHTTPTimeout(int delay); + +void * RxmlNanoFTPOpen(const char *URL); +int RxmlNanoFTPRead(void *ctx, void *dest, int len); +int RxmlNanoFTPClose(void *ctx); +void RxmlNanoFTPTimeout(int delay); +int RxmlNanoFTPContentLength(void *ctx); + +void RxmlMessage(int level, const char *format, ...); + +/* not currently used */ + +void RxmlNanoFTPCleanup(void); +void RxmlNanoHTTPCleanup(void); + +#ifdef __cplusplus +} +#endif + +#endif /* R_FTP_HTTP_H_ */ diff --git a/var_lib_genenet_bnw/localscore/R.h b/var_lib_genenet_bnw/localscore/R.h new file mode 100644 index 00000000..5c5696b3 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/R.h @@ -0,0 +1,65 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 2000-2010 The R Core Team. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +#ifndef R_R_H +#define R_R_H + +#ifndef USING_R +# define USING_R +#endif + +#ifndef NO_C_HEADERS +#include <stdlib.h> +#include <stdio.h> /* Used by several packages, remove in due course */ +#include <limits.h> /* for INT_MAX */ +#include <math.h> +#endif + +#include "Rconfig.h" +#include "Arith.h" /* R_FINITE, ISNAN, ... */ +#include "Boolean.h" /* Rboolean type */ +#include "Complex.h" /* Rcomplex type */ +#include "Constants.h" /* PI, DOUBLE_EPS, etc */ +#include "Error.h" /* error and warning */ +#include "Memory.h" /* R_alloc and S_alloc */ +#include "Print.h" /* Rprintf etc */ +#include "Random.h" /* RNG interface */ +#include "Utils.h" /* sort routines et al */ +#include "RS.h" +/* for PROBLEM ... Calloc, Realloc, Free, Memcpy, F77_xxxx */ + + +typedef double Sfloat; +typedef int Sint; +#define SINT_MAX INT_MAX +#define SINT_MIN INT_MIN + +#ifdef __cplusplus +extern "C" { +#endif + +void R_FlushConsole(void); +/* always declared, but only usable under Win32 and Aqua */ +void R_ProcessEvents(void); + +#ifdef __cplusplus +} +#endif + +#endif /* !R_R_H */ diff --git a/var_lib_genenet_bnw/localscore/RConverters.h b/var_lib_genenet_bnw/localscore/RConverters.h new file mode 100644 index 00000000..9ac0da33 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/RConverters.h @@ -0,0 +1,131 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 1998-2006 The R Core Team + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + * + * + */ + +/* + Not part of the API, concerns .C() converters which are deprecated. + */ + +#ifndef R_CCONVERTERS_H +#define R_CCONVERTERS_H + +#include <Rinternals.h> + +#ifdef __cplusplus +extern "C" { +#endif + +#define freeCConverter RC_freeCConverter +#define R_addToCConverter RC_addToCConverter +#define R_converterMatchClass RC_converterMatchClass +#define R_converterMatchClass RC_converterMatchClass +#define R_getToCConverterByDescription RC_getToCConverterByDescription +#define R_getToCConverterByIndex RC_getToCConverterByIndex +#define R_getToCConverterByIndex RC_getToCConverterByIndex +#define R_removeToCConverter RC_removeToCConverter + + /* Context information controlling how the conversion is performed, passed + to RObjToCPtr in dotcode.c and the different user level converters. */ + typedef struct { + int naok; + int narg; + int dup; + int Fort; + + char const * name ; + + SEXP classes; + } R_CConvertInfo; + + + /* Typedefs for structs defined below with future/cross-referencing. */ + typedef struct RtoCConverter R_toCConverter; + typedef struct RFromCConvertInfo R_FromCConvertInfo; + + + /* The matching routine which determines whether the converter can process the given SEXP. */ + typedef Rboolean (*R_ToCPredicate)(SEXP obj, R_CConvertInfo *info, R_toCConverter *el); + + /* The converter routine that returns the value to be passed to the C routine. + (We may have to make the return type a union to handle the different types.) */ + typedef void* (*R_ToCConverter)(SEXP obj, R_CConvertInfo *info, R_toCConverter *el); + + /* The reverse converter from the C argument to the R object that is returned via the .C() call. */ + typedef SEXP (*R_FromCConverter)(void *value, SEXP arg, R_FromCConvertInfo *info, + R_toCConverter *el); + + + /* The definition of the converter element which are stored as a linked list. */ + struct RtoCConverter { + R_ToCPredicate matcher; /* check if converter applies to R object */ + R_ToCConverter converter; /* convert the R object to C value */ + R_FromCConverter reverse; /* convert the C value back to an R object. */ + char *description; /* user-readable string describing the converter. */ + void *userData; /* additional information used in (any of) the matcher, + converter, and reverse routines to parameterize them. */ + Rboolean active; /* allows the converter to be in the list but ignored temporarily. */ + + R_toCConverter *next; /* next element in the linked list. */ + }; + + + /* Information used to convert C values to R objects at the end of do_dotCode() */ + struct RFromCConvertInfo { + const char *functionName; /* the name of the routine being called (S's name for it). */ + + int argIndex; /* the pariticular argument being processed. */ + + /* We provide all of the arguments and the corresponding C values. + This gives the full context of the call to the reverse converter */ + SEXP allArgs; + void **cargs; + int nargs; + }; + + + + /* Internal mechanism for employing the converter mechanism, used in do_dotCode() in dotcode.c */ + void *Rf_convertToC(SEXP s, R_CConvertInfo *info, int *success, R_toCConverter **converter); + + /* Converter management facilities. */ + R_toCConverter *R_addToCConverter(R_ToCPredicate match, R_ToCConverter converter, + R_FromCConverter reverse, + void *userData, char *desc); + R_toCConverter *R_getToCConverterByIndex(int which); + R_toCConverter *R_getToCConverterByDescription(const char *desc); + void R_removeToCConverter(R_toCConverter *el); + + Rboolean R_converterMatchClass(SEXP obj, R_CConvertInfo *inf, R_toCConverter *el); + void freeCConverter(R_toCConverter *el); + + /* The routines corresponding to the .Internal() providing access to the + management facilities of the converter list. + */ + SEXP do_getNumRtoCConverters(SEXP call, SEXP op, SEXP args, SEXP env); + SEXP do_getRtoCConverterDescriptions(SEXP call, SEXP op, SEXP args, SEXP env); + SEXP do_getRtoCConverterStatus(SEXP call, SEXP op, SEXP args, SEXP env); + SEXP do_setToCConverterActiveStatus(SEXP call, SEXP op, SEXP args, SEXP env); + + +#ifdef __cplusplus +} +#endif + +#endif /* R_CCONVERTERS_H */ diff --git a/var_lib_genenet_bnw/localscore/RS.h b/var_lib_genenet_bnw/localscore/RS.h new file mode 100644 index 00000000..e8ce2ef2 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/RS.h @@ -0,0 +1,96 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 1999-2007 The R Core Team. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +/* Included by R.h: API */ + +#ifndef R_RS_H +#define R_RS_H + +#ifndef NO_C_HEADERS +# include <string.h> /* for memcpy */ +#endif + +#include "Rconfig.h" /* for F77_APPEND_UNDERSCORE */ + +#ifdef __cplusplus +extern "C" { +#endif + +/* S Like Error Handling */ + +#include "Error.h" /* for error and warning */ + +#ifndef STRICT_R_HEADERS + +#define R_PROBLEM_BUFSIZE 4096 +/* Parentheses added for FC4 with gcc4 and -D_FORTIFY_SOURCE=2 */ +#define PROBLEM {char R_problem_buf[R_PROBLEM_BUFSIZE];(sprintf)(R_problem_buf, +#define MESSAGE {char R_problem_buf[R_PROBLEM_BUFSIZE];(sprintf)(R_problem_buf, +#define ERROR ),error(R_problem_buf);} +#define RECOVER(x) ),error(R_problem_buf);} +#define WARNING(x) ),warning(R_problem_buf);} +#define LOCAL_EVALUATOR /**/ +#define NULL_ENTRY /**/ +#define WARN WARNING(NULL) + +#endif + +/* S Like Memory Management */ + +extern void *R_chk_calloc(size_t, size_t); +extern void *R_chk_realloc(void *, size_t); +extern void R_chk_free(void *); + +#ifndef STRICT_R_HEADERS +/* S-PLUS 3.x but not 5.x NULLs the pointer in the following */ +#define Calloc(n, t) (t *) R_chk_calloc( (size_t) (n), sizeof(t) ) +#define Realloc(p,n,t) (t *) R_chk_realloc( (void *)(p), (size_t)((n) * sizeof(t)) ) +#define Free(p) (R_chk_free( (void *)(p) ), (p) = NULL) +#endif +#define R_Calloc(n, t) (t *) R_chk_calloc( (size_t) (n), sizeof(t) ) +#define R_Realloc(p,n,t) (t *) R_chk_realloc( (void *)(p), (size_t)((n) * sizeof(t)) ) +#define R_Free(p) (R_chk_free( (void *)(p) ), (p) = NULL) + +#define Memcpy(p,q,n) memcpy( p, q, (size_t)( (n) * sizeof(*p) ) ) + +#define CallocCharBuf(n) (char *) R_chk_calloc((size_t) ((n)+1), sizeof(char)) + +/* S Like Fortran Interface */ +/* These may not be adequate everywhere. Convex had _ prepending common + blocks, and some compilers may need to specify Fortran linkage */ + +#ifdef HAVE_F77_UNDERSCORE +# define F77_CALL(x) x ## _ +#else +# define F77_CALL(x) x +#endif +#define F77_NAME(x) F77_CALL(x) +#define F77_SUB(x) F77_CALL(x) +#define F77_COM(x) F77_CALL(x) +#define F77_COMDECL(x) F77_CALL(x) + +#ifndef NO_CALL_R +void call_R(char*, long, void**, char**, long*, char**, long, char**); +#endif + +#ifdef __cplusplus +} +#endif + +#endif /* R_RS_H */ diff --git a/var_lib_genenet_bnw/localscore/RStartup.h b/var_lib_genenet_bnw/localscore/RStartup.h new file mode 100644 index 00000000..5b89e7fe --- /dev/null +++ b/var_lib_genenet_bnw/localscore/RStartup.h @@ -0,0 +1,107 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 1999-2010 The R Core Team + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +/* + C functions to be called from alternative front-ends. + + Part of the API for such front-ends but not for packages. +*/ + +#ifndef R_EXT_RSTARTUP_H_ +#define R_EXT_RSTARTUP_H_ + +#include <R_ext/Boolean.h> /* TRUE/FALSE */ + +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef Win32 +typedef int (*blah1) (const char *, char *, int, int); +typedef void (*blah2) (const char *, int); +typedef void (*blah3) (void); +typedef void (*blah4) (const char *); +/* Return value here is expected to be 1 for Yes, -1 for No and 0 for Cancel: + symbolic constants in graphapp.h */ +typedef int (*blah5) (const char *); +typedef void (*blah6) (int); +typedef void (*blah7) (const char *, int, int); +typedef enum {RGui, RTerm, LinkDLL} UImode; +#endif + +/* Startup Actions */ +typedef enum { + SA_NORESTORE,/* = 0 */ + SA_RESTORE, + SA_DEFAULT,/* was === SA_RESTORE */ + SA_NOSAVE, + SA_SAVE, + SA_SAVEASK, + SA_SUICIDE +} SA_TYPE; + +typedef struct +{ + Rboolean R_Quiet; + Rboolean R_Slave; + Rboolean R_Interactive; + Rboolean R_Verbose; + Rboolean LoadSiteFile; + Rboolean LoadInitFile; + Rboolean DebugInitFile; + SA_TYPE RestoreAction; + SA_TYPE SaveAction; + size_t vsize; + size_t nsize; + size_t max_vsize; + size_t max_nsize; + size_t ppsize; + int NoRenviron; + +#ifdef Win32 + char *rhome; /* R_HOME */ + char *home; /* HOME */ + blah1 ReadConsole; + blah2 WriteConsole; + blah3 CallBack; + blah4 ShowMessage; + blah5 YesNoCancel; + blah6 Busy; + UImode CharacterMode; + blah7 WriteConsoleEx; /* used only if WriteConsole is NULL */ +#endif +} structRstart; + +typedef structRstart *Rstart; + +void R_DefParams(Rstart); +void R_SetParams(Rstart); +void R_SetWin32(Rstart); +void R_SizeFromEnv(Rstart); +void R_common_command_line(int *, char **, Rstart); + +void R_set_command_line_arguments(int argc, char **argv); + +void setup_Rmainloop(void); // also in Rembedded.h + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/var_lib_genenet_bnw/localscore/Random.h b/var_lib_genenet_bnw/localscore/Random.h new file mode 100644 index 00000000..1615778d --- /dev/null +++ b/var_lib_genenet_bnw/localscore/Random.h @@ -0,0 +1,75 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 1998-2011 The R Core Team + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +/* Included by R.h: API */ + +#ifndef R_RANDOM_H +#define R_RANDOM_H + +#ifdef __cplusplus +extern "C" { +#endif + +#include "Boolean.h" + +typedef enum { + WICHMANN_HILL, + MARSAGLIA_MULTICARRY, + SUPER_DUPER, + MERSENNE_TWISTER, + KNUTH_TAOCP, + USER_UNIF, + KNUTH_TAOCP2, + LECUYER_CMRG +} RNGtype; + +/* Different kinds of "N(0,1)" generators :*/ +typedef enum { + BUGGY_KINDERMAN_RAMAGE, + AHRENS_DIETER, + BOX_MULLER, + USER_NORM, + INVERSION, + KINDERMAN_RAMAGE +} N01type; + + +void GetRNGstate(void); +void PutRNGstate(void); + +double unif_rand(void); +/* These are also defined in Rmath.h */ +double norm_rand(void); +double exp_rand(void); + +typedef unsigned int Int32; +double * user_unif_rand(void); +void user_unif_init(Int32); +int * user_unif_nseed(void); +int * user_unif_seedloc(void); + +double * user_norm_rand(void); + +void FixupProb(double *, int, int, Rboolean); + +#ifdef __cplusplus +} +#endif + +#endif /* R_RANDOM_H */ diff --git a/var_lib_genenet_bnw/localscore/Rconfig.h b/var_lib_genenet_bnw/localscore/Rconfig.h new file mode 100644 index 00000000..2541c8a9 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/Rconfig.h @@ -0,0 +1,20 @@ +/* Rconfig.h. Generated automatically */ +#ifndef R_RCONFIG_H +#define R_RCONFIG_H + +#ifndef R_CONFIG_H + +#define HAVE_F77_UNDERSCORE 1 +#define IEEE_754 1 +/* #undef WORDS_BIGENDIAN */ +#define R_INLINE inline +#define HAVE_VISIBILITY_ATTRIBUTE 1 +#define SUPPORT_UTF8 1 +#define SUPPORT_MBCS 1 +#define ENABLE_NLS 1 +/* #undef HAVE_AQUA */ +#define SUPPORT_OPENMP 1 + +#endif /* not R_CONFIG_H */ + +#endif /* not R_RCONFIG_H */ diff --git a/var_lib_genenet_bnw/localscore/Rdynload.h b/var_lib_genenet_bnw/localscore/Rdynload.h new file mode 100644 index 00000000..982b571a --- /dev/null +++ b/var_lib_genenet_bnw/localscore/Rdynload.h @@ -0,0 +1,129 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 2001-12 The R Core Team. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +/* + C functions used to register compiled code in packages. + + Those needed for that purpose are part of the API. + */ + +#ifndef R_EXT_DYNLOAD_H_ +#define R_EXT_DYNLOAD_H_ + +#include <R_ext/Boolean.h> + +/* called with a variable argument set */ +typedef void * (*DL_FUNC)(); + +typedef unsigned int R_NativePrimitiveArgType; + +#define SINGLESXP 302 /* Don't have a single type for this. */ + +/* In the future, we will want to allow people register their own types + and then refer to these in other contexts. Something like the Gtk type + system may be appropriate. +*/ +typedef unsigned int R_NativeObjectArgType; + + +/* In the near future, we may support registering + information about the arguments of native routines + and whether they are used to return information. + The hope is that we can minimize copying objects even + further. Not currently in use. +*/ +typedef enum {R_ARG_IN, R_ARG_OUT, R_ARG_IN_OUT, R_IRRELEVANT} R_NativeArgStyle; + + + +/* + These are very similar to those in unix/dynload.c + but we maintain them separately to give us more freedom to do + some computations on the internal versions that are derived from + these definitions. +*/ +typedef struct { + const char *name; + DL_FUNC fun; + int numArgs; + + R_NativePrimitiveArgType *types; + R_NativeArgStyle *styles; + +} R_CMethodDef; + +typedef R_CMethodDef R_FortranMethodDef; + + + +typedef struct { + const char *name; + DL_FUNC fun; + int numArgs; +/* In the future, we will put types in here for the different arguments. + We need a richer type system to do this effectively so that one + can specify types for new classes. +*/ +} R_CallMethodDef; +typedef R_CallMethodDef R_ExternalMethodDef; + + +typedef struct _DllInfo DllInfo; + +/* + Currently ignore the graphics routines, accessible via .External.graphics() + and .Call.graphics(). + */ +#ifdef __cplusplus +extern "C" { +#endif +int R_registerRoutines(DllInfo *info, const R_CMethodDef * const croutines, + const R_CallMethodDef * const callRoutines, + const R_FortranMethodDef * const fortranRoutines, + const R_ExternalMethodDef * const externalRoutines); + +Rboolean R_useDynamicSymbols(DllInfo *info, Rboolean value); + +DllInfo *R_getDllInfo(const char *name); + +/* to be used by applications embedding R to register their symbols + that are not related to any dynamic module */ +DllInfo *R_getEmbeddingDllInfo(void); + +typedef struct Rf_RegisteredNativeSymbol R_RegisteredNativeSymbol; +typedef enum {R_ANY_SYM=0, R_C_SYM, R_CALL_SYM, R_FORTRAN_SYM, R_EXTERNAL_SYM} NativeSymbolType; + + +DL_FUNC R_FindSymbol(char const *, char const *, + R_RegisteredNativeSymbol *symbol); + + +/* Experimental interface for exporting and importing functions from + one package for use from C code in a package. The registration + part probably ought to be integrated with the other registrations. + The naming of these routines may be less than ideal. */ + +void R_RegisterCCallable(const char *package, const char *name, DL_FUNC fptr); +DL_FUNC R_GetCCallable(const char *package, const char *name); + +#ifdef __cplusplus +} +#endif + +#endif /* R_EXT_DYNLOAD_H_ */ diff --git a/var_lib_genenet_bnw/localscore/Riconv.h b/var_lib_genenet_bnw/localscore/Riconv.h new file mode 100644 index 00000000..13864ee6 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/Riconv.h @@ -0,0 +1,46 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 2005 the R Core Team + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +/* + Interface to R's platform-independent implementation of iconv. + + Part of the API. +*/ + +#ifndef R_ICONV_H +#define R_ICONV_H + +#ifdef __cplusplus +extern "C" { +#endif + +/* from sysutils.c */ +#undef Riconv_open +#undef Riconv +#undef Riconv_close +void * Riconv_open (const char* tocode, const char* fromcode); +size_t Riconv (void * cd, const char **inbuf, size_t *inbytesleft, + char **outbuf, size_t *outbytesleft); +int Riconv_close (void * cd); + +#ifdef __cplusplus +} +#endif + +#endif /* R_ICONV_H */ diff --git a/var_lib_genenet_bnw/localscore/Rmath.h b/var_lib_genenet_bnw/localscore/Rmath.h new file mode 100644 index 00000000..1acd1dbb --- /dev/null +++ b/var_lib_genenet_bnw/localscore/Rmath.h @@ -0,0 +1,657 @@ +/* -*- C -*- + * Mathlib : A C Library of Special Functions + * Copyright (C) 1998-2011 The R Core Team + * Copyright (C) 2004 The R Foundation + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + * + + * Rmath.h should contain ALL headers from R's C code in `src/nmath' + ------- such that ``the Math library'' can be used by simply + + ``#include <Rmath.h> '' + + and nothing else. + + It is part of the API and supports 'standalone Rmath'. + +*/ +#ifndef RMATH_H +#define RMATH_H + +/* Note that on some systems we need to include math.h before the + defines below, to avoid redefining ftrunc */ +#ifndef NO_C_HEADERS +# include <math.h> +#endif + +/*-- Mathlib as part of R -- define this for standalone : */ +/* #undef MATHLIB_STANDALONE */ + +#define R_VERSION_STRING "2.15.2" + +#ifndef HAVE_EXPM1 +# define HAVE_EXPM1 1 +#endif + +#ifndef HAVE_HYPOT +# define HAVE_HYPOT 1 +#endif + +#ifndef HAVE_LOG1P +# define HAVE_LOG1P 1 +#endif + +#ifndef HAVE_WORKING_LOG1P +# define HAVE_WORKING_LOG1P 1 +#endif + +#if defined(HAVE_LOG1P) && !defined(HAVE_WORKING_LOG1P) +/* remap to avoid problems with getting the right entry point */ +double Rlog1p(double); +#define log1p Rlog1p +#endif + + + /* Undo SGI Madness */ + +#ifdef ftrunc +# undef ftrunc +#endif +#ifdef qexp +# undef qexp +#endif +#ifdef qgamma +# undef qgamma +#endif + + +/* ----- The following constants and entry points are part of the R API ---- */ + +/* 30 Decimal-place constants */ +/* Computed with bc -l (scale=32; proper round) */ + +/* SVID & X/Open Constants */ +/* Names from Solaris math.h */ + +#ifndef M_E +#define M_E 2.718281828459045235360287471353 /* e */ +#endif + +#ifndef M_LOG2E +#define M_LOG2E 1.442695040888963407359924681002 /* log2(e) */ +#endif + +#ifndef M_LOG10E +#define M_LOG10E 0.434294481903251827651128918917 /* log10(e) */ +#endif + +#ifndef M_LN2 +#define M_LN2 0.693147180559945309417232121458 /* ln(2) */ +#endif + +#ifndef M_LN10 +#define M_LN10 2.302585092994045684017991454684 /* ln(10) */ +#endif + +#ifndef M_PI +#define M_PI 3.141592653589793238462643383280 /* pi */ +#endif + +#ifndef M_2PI +#define M_2PI 6.283185307179586476925286766559 /* 2*pi */ +#endif + +#ifndef M_PI_2 +#define M_PI_2 1.570796326794896619231321691640 /* pi/2 */ +#endif + +#ifndef M_PI_4 +#define M_PI_4 0.785398163397448309615660845820 /* pi/4 */ +#endif + +#ifndef M_1_PI +#define M_1_PI 0.318309886183790671537767526745 /* 1/pi */ +#endif + +#ifndef M_2_PI +#define M_2_PI 0.636619772367581343075535053490 /* 2/pi */ +#endif + +#ifndef M_2_SQRTPI +#define M_2_SQRTPI 1.128379167095512573896158903122 /* 2/sqrt(pi) */ +#endif + +#ifndef M_SQRT2 +#define M_SQRT2 1.414213562373095048801688724210 /* sqrt(2) */ +#endif + +#ifndef M_SQRT1_2 +#define M_SQRT1_2 0.707106781186547524400844362105 /* 1/sqrt(2) */ +#endif + +/* R-Specific Constants */ + +#ifndef M_SQRT_3 +#define M_SQRT_3 1.732050807568877293527446341506 /* sqrt(3) */ +#endif + +#ifndef M_SQRT_32 +#define M_SQRT_32 5.656854249492380195206754896838 /* sqrt(32) */ +#endif + +#ifndef M_LOG10_2 +#define M_LOG10_2 0.301029995663981195213738894724 /* log10(2) */ +#endif + +#ifndef M_SQRT_PI +#define M_SQRT_PI 1.772453850905516027298167483341 /* sqrt(pi) */ +#endif + +#ifndef M_1_SQRT_2PI +#define M_1_SQRT_2PI 0.398942280401432677939946059934 /* 1/sqrt(2pi) */ +#endif + +#ifndef M_SQRT_2dPI +#define M_SQRT_2dPI 0.797884560802865355879892119869 /* sqrt(2/pi) */ +#endif + + +#ifndef M_LN_SQRT_PI +#define M_LN_SQRT_PI 0.572364942924700087071713675677 /* log(sqrt(pi)) + == log(pi)/2 */ +#endif + +#ifndef M_LN_SQRT_2PI +#define M_LN_SQRT_2PI 0.918938533204672741780329736406 /* log(sqrt(2*pi)) + == log(2*pi)/2 */ +#endif + +#ifndef M_LN_SQRT_PId2 +#define M_LN_SQRT_PId2 0.225791352644727432363097614947 /* log(sqrt(pi/2)) */ +#endif + + +#ifdef MATHLIB_STANDALONE +# ifndef R_EXT_BOOLEAN_H_ +/* "copy-paste" R_ext/Boolean.h if not already included: */ + #define R_EXT_BOOLEAN_H_ + #undef FALSE + #undef TRUE + typedef enum { FALSE = 0, TRUE } Rboolean; +# endif +#else +# include "Boolean.h" +#endif + + +#ifndef MATHLIB_STANDALONE +#define bessel_i Rf_bessel_i +#define bessel_j Rf_bessel_j +#define bessel_k Rf_bessel_k +#define bessel_y Rf_bessel_y +#define bessel_i_ex Rf_bessel_i_ex +#define bessel_j_ex Rf_bessel_j_ex +#define bessel_k_ex Rf_bessel_k_ex +#define bessel_y_ex Rf_bessel_y_ex +#define beta Rf_beta +#define choose Rf_choose +#define dbeta Rf_dbeta +#define dbinom Rf_dbinom +#define dcauchy Rf_dcauchy +#define dchisq Rf_dchisq +#define dexp Rf_dexp +#define df Rf_df +#define dgamma Rf_dgamma +#define dgeom Rf_dgeom +#define dhyper Rf_dhyper +#define digamma Rf_digamma +#define dlnorm Rf_dlnorm +#define dlogis Rf_dlogis +#define dnbeta Rf_dnbeta +#define dnbinom Rf_dnbinom +#define dnchisq Rf_dnchisq +#define dnf Rf_dnf +#define dnorm4 Rf_dnorm4 +#define dnt Rf_dnt +#define dpois Rf_dpois +#define dpsifn Rf_dpsifn +#define dsignrank Rf_dsignrank +#define dt Rf_dt +#define dtukey Rf_dtukey +#define dunif Rf_dunif +#define dweibull Rf_dweibull +#define dwilcox Rf_dwilcox +#define fmax2 Rf_fmax2 +#define fmin2 Rf_fmin2 +#define fprec Rf_fprec +#define fround Rf_fround +#define ftrunc Rf_ftrunc +#define fsign Rf_fsign +#define gammafn Rf_gammafn +#define imax2 Rf_imax2 +#define imin2 Rf_imin2 +#define lbeta Rf_lbeta +#define lchoose Rf_lchoose +#define lgammafn Rf_lgammafn +#define lgammafn_sign Rf_lgammafn_sign +#define lgamma1p Rf_lgamma1p +#define log1pmx Rf_log1pmx +#define logspace_add Rf_logspace_add +#define logspace_sub Rf_logspace_sub +#define pbeta Rf_pbeta +#define pbeta_raw Rf_pbeta_raw +#define pbinom Rf_pbinom +#define pcauchy Rf_pcauchy +#define pchisq Rf_pchisq +#define pentagamma Rf_pentagamma +#define pexp Rf_pexp +#define pf Rf_pf +#define pgamma Rf_pgamma +#define pgeom Rf_pgeom +#define phyper Rf_phyper +#define plnorm Rf_plnorm +#define plogis Rf_plogis +#define pnbeta Rf_pnbeta +#define pnbinom Rf_pnbinom +#define pnchisq Rf_pnchisq +#define pnf Rf_pnf +#define pnorm5 Rf_pnorm5 +#define pnorm_both Rf_pnorm_both +#define pnt Rf_pnt +#define ppois Rf_ppois +#define psignrank Rf_psignrank +#define psigamma Rf_psigamma +#define pt Rf_pt +#define ptukey Rf_ptukey +#define punif Rf_punif +#define pythag Rf_pythag +#define pweibull Rf_pweibull +#define pwilcox Rf_pwilcox +#define qbeta Rf_qbeta +#define qbinom Rf_qbinom +#define qcauchy Rf_qcauchy +#define qchisq Rf_qchisq +#define qchisq_appr Rf_qchisq_appr +#define qexp Rf_qexp +#define qf Rf_qf +#define qgamma Rf_qgamma +#define qgeom Rf_qgeom +#define qhyper Rf_qhyper +#define qlnorm Rf_qlnorm +#define qlogis Rf_qlogis +#define qnbeta Rf_qnbeta +#define qnbinom Rf_qnbinom +#define qnchisq Rf_qnchisq +#define qnf Rf_qnf +#define qnorm5 Rf_qnorm5 +#define qnt Rf_qnt +#define qpois Rf_qpois +#define qsignrank Rf_qsignrank +#define qt Rf_qt +#define qtukey Rf_qtukey +#define qunif Rf_qunif +#define qweibull Rf_qweibull +#define qwilcox Rf_qwilcox +#define rbeta Rf_rbeta +#define rbinom Rf_rbinom +#define rcauchy Rf_rcauchy +#define rchisq Rf_rchisq +#define rexp Rf_rexp +#define rf Rf_rf +#define rgamma Rf_rgamma +#define rgeom Rf_rgeom +#define rhyper Rf_rhyper +#define rlnorm Rf_rlnorm +#define rlogis Rf_rlogis +#define rnbeta Rf_rnbeta +#define rnbinom Rf_rnbinom +#define rnchisq Rf_rnchisq +#define rnf Rf_rnf +#define rnorm Rf_rnorm +#define rnt Rf_rnt +#define rpois Rf_rpois +#define rsignrank Rf_rsignrank +#define rt Rf_rt +#define rtukey Rf_rtukey +#define runif Rf_runif +#define rweibull Rf_rweibull +#define rwilcox Rf_rwilcox +#define sign Rf_sign +#define tetragamma Rf_tetragamma +#define trigamma Rf_trigamma +#endif + +#define rround fround +#define prec fprec +#undef trunc +#define trunc ftrunc + +#ifdef __cplusplus +extern "C" { +#endif + /* R's versions with !R_FINITE checks */ + +double R_pow(double x, double y); +double R_pow_di(double, int); + + /* Random Number Generators */ + +double norm_rand(void); +double unif_rand(void); +double exp_rand(void); +#ifdef MATHLIB_STANDALONE +void set_seed(unsigned int, unsigned int); +void get_seed(unsigned int *, unsigned int *); +#endif + + /* Normal Distribution */ + +#define pnorm pnorm5 +#define qnorm qnorm5 +#define dnorm dnorm4 + +double dnorm(double, double, double, int); +double pnorm(double, double, double, int, int); +double qnorm(double, double, double, int, int); +double rnorm(double, double); +void pnorm_both(double, double *, double *, int, int);/* both tails */ + + /* Uniform Distribution */ + +double dunif(double, double, double, int); +double punif(double, double, double, int, int); +double qunif(double, double, double, int, int); +double runif(double, double); + + /* Gamma Distribution */ + +double dgamma(double, double, double, int); +double pgamma(double, double, double, int, int); +double qgamma(double, double, double, int, int); +double rgamma(double, double); + +double log1pmx(double); +double log1pexp(double); // <-- ../nmath/plogis.c +double lgamma1p(double); +double logspace_add(double, double); +double logspace_sub(double, double); + + /* Beta Distribution */ + +double dbeta(double, double, double, int); +double pbeta(double, double, double, int, int); +double qbeta(double, double, double, int, int); +double rbeta(double, double); + + /* Lognormal Distribution */ + +double dlnorm(double, double, double, int); +double plnorm(double, double, double, int, int); +double qlnorm(double, double, double, int, int); +double rlnorm(double, double); + + /* Chi-squared Distribution */ + +double dchisq(double, double, int); +double pchisq(double, double, int, int); +double qchisq(double, double, int, int); +double rchisq(double); + + /* Non-central Chi-squared Distribution */ + +double dnchisq(double, double, double, int); +double pnchisq(double, double, double, int, int); +double qnchisq(double, double, double, int, int); +double rnchisq(double, double); + + /* F Distibution */ + +double df(double, double, double, int); +double pf(double, double, double, int, int); +double qf(double, double, double, int, int); +double rf(double, double); + + /* Student t Distibution */ + +double dt(double, double, int); +double pt(double, double, int, int); +double qt(double, double, int, int); +double rt(double); + + /* Binomial Distribution */ + +double dbinom(double, double, double, int); +double pbinom(double, double, double, int, int); +double qbinom(double, double, double, int, int); +double rbinom(double, double); + + /* Multnomial Distribution */ + +void rmultinom(int, double*, int, int*); + + /* Cauchy Distribution */ + +double dcauchy(double, double, double, int); +double pcauchy(double, double, double, int, int); +double qcauchy(double, double, double, int, int); +double rcauchy(double, double); + + /* Exponential Distribution */ + +double dexp(double, double, int); +double pexp(double, double, int, int); +double qexp(double, double, int, int); +double rexp(double); + + /* Geometric Distribution */ + +double dgeom(double, double, int); +double pgeom(double, double, int, int); +double qgeom(double, double, int, int); +double rgeom(double); + + /* Hypergeometric Distibution */ + +double dhyper(double, double, double, double, int); +double phyper(double, double, double, double, int, int); +double qhyper(double, double, double, double, int, int); +double rhyper(double, double, double); + + /* Negative Binomial Distribution */ + +double dnbinom(double, double, double, int); +double pnbinom(double, double, double, int, int); +double qnbinom(double, double, double, int, int); +double rnbinom(double, double); + +double dnbinom_mu(double, double, double, int); +double pnbinom_mu(double, double, double, int, int); +double qnbinom_mu(double, double, double, int, int); +double rnbinom_mu(double, double); + + /* Poisson Distribution */ + +double dpois(double, double, int); +double ppois(double, double, int, int); +double qpois(double, double, int, int); +double rpois(double); + + /* Weibull Distribution */ + +double dweibull(double, double, double, int); +double pweibull(double, double, double, int, int); +double qweibull(double, double, double, int, int); +double rweibull(double, double); + + /* Logistic Distribution */ + +double dlogis(double, double, double, int); +double plogis(double, double, double, int, int); +double qlogis(double, double, double, int, int); +double rlogis(double, double); + + /* Non-central Beta Distribution */ + +double dnbeta(double, double, double, double, int); +double pnbeta(double, double, double, double, int, int); +double qnbeta(double, double, double, double, int, int); +double rnbeta(double, double, double); + + /* Non-central F Distribution */ + +double dnf(double, double, double, double, int); +double pnf(double, double, double, double, int, int); +double qnf(double, double, double, double, int, int); + + /* Non-central Student t Distribution */ + +double dnt(double, double, double, int); +double pnt(double, double, double, int, int); +double qnt(double, double, double, int, int); + + /* Studentized Range Distribution */ + +double ptukey(double, double, double, double, int, int); +double qtukey(double, double, double, double, int, int); + + /* Wilcoxon Rank Sum Distribution */ + +double dwilcox(double, double, double, int); +double pwilcox(double, double, double, int, int); +double qwilcox(double, double, double, int, int); +double rwilcox(double, double); + + /* Wilcoxon Signed Rank Distribution */ + +double dsignrank(double, double, int); +double psignrank(double, double, int, int); +double qsignrank(double, double, int, int); +double rsignrank(double); + + /* Gamma and Related Functions */ +double gammafn(double); +double lgammafn(double); +double lgammafn_sign(double, int*); +void dpsifn(double, int, int, int, double*, int*, int*); +double psigamma(double, double); +double digamma(double); +double trigamma(double); +double tetragamma(double); +double pentagamma(double); + +double beta(double, double); +double lbeta(double, double); + +double choose(double, double); +double lchoose(double, double); + + /* Bessel Functions */ + +double bessel_i(double, double, double); +double bessel_j(double, double); +double bessel_k(double, double, double); +double bessel_y(double, double); +double bessel_i_ex(double, double, double, double *); +double bessel_j_ex(double, double, double *); +double bessel_k_ex(double, double, double, double *); +double bessel_y_ex(double, double, double *); + + + /* General Support Functions */ + +#ifndef HAVE_HYPOT +double hypot(double, double); +#endif +double pythag(double, double); +#ifndef HAVE_EXPM1 +double expm1(double); /* = exp(x)-1 {care for small x} */ +#endif +#ifndef HAVE_LOG1P +double log1p(double); /* = log(1+x) {care for small x} */ +#endif +int imax2(int, int); +int imin2(int, int); +double fmax2(double, double); +double fmin2(double, double); +double sign(double); +double fprec(double, double); +double fround(double, double); +double fsign(double, double); +double ftrunc(double); + +double log1pmx(double); /* Accurate log(1+x) - x, {care for small x} */ +double lgamma1p(double);/* accurate log(gamma(x+1)), small x (0 < x < 0.5) */ + +/* Compute the log of a sum or difference from logs of terms, i.e., + * + * log (exp (logx) + exp (logy)) + * or log (exp (logx) - exp (logy)) + * + * without causing overflows or throwing away too much accuracy: + */ +double logspace_add(double logx, double logy); +double logspace_sub(double logx, double logy); + + + + +/* ----------------- Private part of the header file ------------------- */ + + /* old-R Compatibility */ + +#ifdef OLD_RMATH_COMPAT +# define snorm norm_rand +# define sunif unif_rand +# define sexp exp_rand +#endif + +#if defined(MATHLIB_STANDALONE) && !defined(MATHLIB_PRIVATE_H) +/* second is defined by nmath.h */ + +/* If isnan is a macro, as C99 specifies, the C++ + math header will undefine it. This happens on OS X */ +# ifdef __cplusplus + int R_isnancpp(double); /* in mlutils.c */ +# define ISNAN(x) R_isnancpp(x) +# else +# define ISNAN(x) (isnan(x)!=0) +# endif + +# define R_FINITE(x) R_finite(x) +int R_finite(double); + +# ifdef WIN32 /* not Win32 as no config information */ +# ifdef RMATH_DLL +# define R_EXTERN extern __declspec(dllimport) +# else +# define R_EXTERN extern +# endif +R_EXTERN double NA_REAL; +R_EXTERN double R_PosInf; +R_EXTERN double R_NegInf; +R_EXTERN int N01_kind; +# undef R_EXTERN +#else +extern int N01_kind; +# endif + +#endif /* MATHLIB_STANDALONE */ + +#ifdef __cplusplus +} +#endif + +#endif /* RMATH_H */ diff --git a/var_lib_genenet_bnw/localscore/Utils.h b/var_lib_genenet_bnw/localscore/Utils.h new file mode 100644 index 00000000..61efaaaa --- /dev/null +++ b/var_lib_genenet_bnw/localscore/Utils.h @@ -0,0 +1,115 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 1998-2005 The R Core Team + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + * + * + * Generally useful UTILITIES *NOT* relying on R internals (from Defn.h) + */ + +/* Included by R.h: API */ + +#ifndef R_EXT_UTILS_H_ +#define R_EXT_UTILS_H_ + +#include "Boolean.h" +#include "Complex.h" + +#define revsort Rf_revsort +#define iPsort Rf_iPsort +#define rPsort Rf_rPsort +#define cPsort Rf_cPsort +#define IndexWidth Rf_IndexWidth +#define setIVector Rf_setIVector +#define setRVector Rf_setRVector +#define StringFalse Rf_StringFalse +#define StringTrue Rf_StringTrue +#define isBlankString Rf_isBlankString +#define hsv2rgb Rf_hsv2rgb +#define rgb2hsv Rf_rgb2hsv + +#ifdef __cplusplus +extern "C" { +#endif + +/* ../../main/sort.c : */ +void R_isort(int*, int); +void R_rsort(double*, int); +void R_csort(Rcomplex*, int); +void rsort_with_index(double *, int *, int); +void revsort(double*, int*, int);/* reverse; sort i[] alongside */ +void iPsort(int*, int, int); +void rPsort(double*, int, int); +void cPsort(Rcomplex*, int, int); + +/* ../../main/qsort.c : */ +void R_qsort (double *v, int i, int j); +void R_qsort_I (double *v, int *I, int i, int j); +void R_qsort_int (int *iv, int i, int j); +void R_qsort_int_I(int *iv, int *I, int i, int j); +#ifdef R_RS_H +void F77_NAME(qsort4)(double *v, int *indx, int *ii, int *jj); +void F77_NAME(qsort3)(double *v, int *ii, int *jj); +#endif + +/* ../../main/printutils.c : */ +int IndexWidth(int); +/* ../../main/util.c and others : */ +const char *R_ExpandFileName(const char *); +void setIVector(int*, int, int); +void setRVector(double*, int, double); +Rboolean StringFalse(const char *); +Rboolean StringTrue(const char *); +Rboolean isBlankString(const char *); + +/* These two are guaranteed to use '.' as the decimal point, + and to accept "NA". + */ +double R_atof(const char *str); +double R_strtod(const char *c, char **end); + +char *R_tmpnam(const char *prefix, const char *tempdir); +char *R_tmpnam2(const char *prefix, const char *tempdir, const char *fileext); + +void hsv2rgb(double h, double s, double v, + double *r, double *g, double *b); +void rgb2hsv(double r, double g, double b, + double *h, double *s, double *v); + +void R_CheckUserInterrupt(void); +void R_CheckStack(void); + + +/* ../../appl/interv.c: also in Applic.h */ +int findInterval(double *xt, int n, double x, + Rboolean rightmost_closed, Rboolean all_inside, int ilo, + int *mflag); +#ifdef R_RS_H +int F77_SUB(interv)(double *xt, int *n, double *x, + Rboolean *rightmost_closed, Rboolean *all_inside, + int *ilo, int *mflag); +#endif +void find_interv_vec(double *xt, int *n, double *x, int *nx, + int *rightmost_closed, int *all_inside, int *indx); + +/* ../../appl/maxcol.c: also in Applic.h */ +void R_max_col(double *matrix, int *nr, int *nc, int *maxes, int *ties_meth); + +#ifdef __cplusplus +} +#endif + +#endif /* R_EXT_UTILS_H_ */ diff --git a/var_lib_genenet_bnw/localscore/Visibility.h b/var_lib_genenet_bnw/localscore/Visibility.h new file mode 100644 index 00000000..aa35e342 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/Visibility.h @@ -0,0 +1,39 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 2008 the R Core Team + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +/* + Definitions controlling visibility on some platforms. + + Part of the API. +*/ + +#ifndef R_EXT_VISIBILITY_H_ +#define R_EXT_VISIBILITY_H_ + +#include <Rconfig.h> + +#ifdef HAVE_VISIBILITY_ATTRIBUTE +# define attribute_visible __attribute__ ((visibility ("default"))) +# define attribute_hidden __attribute__ ((visibility ("hidden"))) +#else +# define attribute_visible +# define attribute_hidden +#endif + +#endif /* R_EXT_VISIBILITY_H_ */ diff --git a/var_lib_genenet_bnw/localscore/eventloop.h b/var_lib_genenet_bnw/localscore/eventloop.h new file mode 100644 index 00000000..842cf9bb --- /dev/null +++ b/var_lib_genenet_bnw/localscore/eventloop.h @@ -0,0 +1,97 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 2000-2007 The R Core Team. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +/* + For use by alternative front-ends and packages which need to share + the R event loop (on all platforms). + + Not part of the API and subject to change without notice. + */ + +#ifndef R_EXT_EVENTLOOP_H +#define R_EXT_EVENTLOOP_H + +#ifndef NO_C_HEADERS +#ifdef HAVE_SYS_SELECT_H +# include <sys/select.h> /* for fd_set according to recent POSIX */ +#endif +/* NOTE: Needed at least on FreeBSD so that fd_set is defined. */ +# include <sys/types.h> +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +#define XActivity 1 +#define StdinActivity 2 + +typedef void (*InputHandlerProc)(void *userData); + +typedef struct _InputHandler { + + int activity; + int fileDescriptor; + InputHandlerProc handler; + + struct _InputHandler *next; + + /* Whether we should be listening to this file descriptor or not. */ + int active; + + /* Data that can be passed to the routine as its only argument. + This might be a user-level function or closure when we implement + a callback to R mechanism. + */ + void *userData; + +} InputHandler; + + +extern InputHandler *initStdinHandler(void); +extern void consoleInputHandler(unsigned char *buf, int len); + +extern InputHandler *addInputHandler(InputHandler *handlers, int fd, InputHandlerProc handler, int activity); +extern InputHandler *getInputHandler(InputHandler *handlers, int fd); +extern int removeInputHandler(InputHandler **handlers, InputHandler *it); +extern InputHandler *getSelectedHandler(InputHandler *handlers, fd_set *mask); +extern fd_set *R_checkActivity(int usec, int ignore_stdin); +extern fd_set *R_checkActivityEx(int usec, int ignore_stdin, void (*intr)(void)); +extern void R_runHandlers(InputHandler *handlers, fd_set *mask); + +extern int R_SelectEx(int n, fd_set *readfds, fd_set *writefds, + fd_set *exceptfds, struct timeval *timeout, + void (*intr)(void)); + +#ifdef __SYSTEM__ +#ifndef __cplusplus /* Would get duplicate conflicting symbols*/ +InputHandler *R_InputHandlers; +#endif +#else +extern InputHandler *R_InputHandlers; +#endif + +extern void (* R_PolledEvents)(void); +extern int R_wait_usec; + +#ifdef __cplusplus +} +#endif + +#endif /* R_EXT_EVENTLOOP_H */ diff --git a/var_lib_genenet_bnw/localscore/libRmath.so b/var_lib_genenet_bnw/localscore/libRmath.so new file mode 100644 index 00000000..8c56eb4f --- /dev/null +++ b/var_lib_genenet_bnw/localscore/libRmath.so Binary files differdiff --git a/var_lib_genenet_bnw/localscore/libextern.h b/var_lib_genenet_bnw/localscore/libextern.h new file mode 100644 index 00000000..3f61fb1e --- /dev/null +++ b/var_lib_genenet_bnw/localscore/libextern.h @@ -0,0 +1,48 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 2001, 2004 The R Core Team. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +/* Included by R.h: API on Windows */ + +/* don't disallow including this one more than once */ + +/* This is intended to be called from other header files, so not callable + from C++ */ + +#undef LibExtern +#undef LibImport +#undef LibExport + +/* Don't try to include CYGWIN here: decorating some symbols breaks + the auto-export that it relies on, even if R_DLL_BUILD were set. */ +#ifdef WIN32 /* WIN32 as does not depend on config.h */ +#define LibImport __declspec(dllimport) +#define LibExport __declspec(dllexport) +#else +#define LibImport +#define LibExport +#endif + +#ifdef __MAIN__ +#define LibExtern LibExport +#define extern +#elif defined(R_DLL_BUILD) +#define LibExtern extern +#else +#define LibExtern extern LibImport +#endif diff --git a/var_lib_genenet_bnw/localscore/matrix.h b/var_lib_genenet_bnw/localscore/matrix.h new file mode 100644 index 00000000..b37772b4 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/matrix.h @@ -0,0 +1,42 @@ +/* -*- Mode: C -*- + * matrix.h --- + * Author : Claus Dethlefsen + * Created On : Thu Mar 14 06:47:52 2002 + * Last Modified By: Claus Dethlefsen + * Last Modified On: Tue May 07 09:39:46 2002 + * Update Count : 22 + * Status : Unknown, Use with caution! + */ + +/* + ## +## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen +## +## This program is free software; you can redistribute it and/or modify +## it under the terms of the GNU General Public License as published by +## the Free Software Foundation; either version 2 of the License, or +## (at your option) any later version. +## +## This program is distributed in the hope that it will be useful, +## but WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +## GNU General Public License for more details. +## +## You should have received a copy of the GNU General Public License +## along with this program; if not, write to the Free Software +## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +###################################################################### +*/ + +extern double ** dmatrix( int, int, int, int ); +extern int * ivector( int, int ); +extern void free_ivector( int *, int, int ); + +extern int invers(double **a, int n, double **b, int m); +extern void printmat( double **, int, int); +extern void asmatrix( double *, double **, int, int); +extern double** matcopy(double **, int, int); +extern double** matmult(double **,double **, int, int, int); +extern double** matsum(double **a, double **b, int nr, int nc); +extern double** matminus(double **a, double **b, int nr, int nc); +extern double** transp (double **a, int n, int m); diff --git a/var_lib_genenet_bnw/localscore/modified_matrix.c b/var_lib_genenet_bnw/localscore/modified_matrix.c new file mode 100644 index 00000000..8737b51b --- /dev/null +++ b/var_lib_genenet_bnw/localscore/modified_matrix.c @@ -0,0 +1,252 @@ +/* -*- Mode: C -*- + * matrix.c --- Simple matrix functions for use with postc.c + * Author : Claus Dethlefsen + * Created On : Thu Mar 14 06:48:02 2002 + * Last Modified By: Claus Dethlefsen + * Last Modified On: Wed Jun 04 11:56:23 2003 + * Update Count : 36 + * Status : Ready + */ + +/* + ## +## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen +## +## This program is free software; you can redistribute it and/or modify +## it under the terms of the GNU General Public License as published by +## the Free Software Foundation; either version 2 of the License, or +## (at your option) any later version. +## +## This program is distributed in the hope that it will be useful, +## but WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +## GNU General Public License for more details. +## +## You should have received a copy of the GNU General Public License +## along with this program; if not, write to the Free Software +## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +###################################################################### +*/ + + +#include "matrix.h" +#include "R.h" +#include "Rmath.h" + + +int *ivector(int nl, int nh) +{ + int *v; + + v=(int *) calloc((unsigned) (nh-nl+1)*sizeof(int),sizeof(int)); + if ( v == NULL ){ + //error("memory allocation failure in ivector()"); return(NULL); + } + return v-nl; +} + +void free_ivector(int *v, int nl, int nh) { free((char*) (v+nl)); } + +double **dmatrix(int nrl, int nrh, int ncl, int nch) +{ + int i; + double **m; + + m=(double **) calloc((unsigned) (nrh-nrl+1)*sizeof(double*),sizeof(double*)); + + m -= nrl; + + for(i=nrl;i<=nrh;i++) { + m[i]=(double *) calloc((unsigned) (nch-ncl+1)*sizeof(double),sizeof(double)); + + m[i] -= ncl; + } + return m; +} + +void free_dmatrix(double **m, int nrl, int nrh, int ncl, int nch) +{ + int i; + + for(i=nrh;i>=nrl;i--) free((char*) (m[i]+ncl)); + free((char*) (m+nrl)); +} + +void printmat(double **mat, int nr, int nc) { + int i,j; + +} + +void asmatrix(double *vek, double **mat, int nr, int nc) { + int i,j; + for (i=1; i<=nr; i++) { + for (j=1; j<=nc; j++) { + mat[i][j] = vek[j-1+(i-1)*nc]; + } + } + +} + +double** matcopy(double **mat, int nr, int nc) { + /* copy mat[i][j] into nat[i][j] */ + int i,j; + double **nat; + nat = dmatrix(1,nr,1,nc); +/* Rprintf("(nr=%d,nc=%d)\n",nr,nc); + Rprintf("(mat=%d)\n",mat); + Rprintf("(mat[1][1]=%f)\n",mat[1][1]); +*/ + + for (i=1; i<=nr; i++) { + for (j=1; j<=nc; j++) { + nat[i][j] = mat[i][j]; + } + } + return(nat); +} + +double** matmult(double **a, double **b, int nra, int nca, int ncb) { + double **c; + int i,j,k; + c = dmatrix(1,nra,1,ncb); + for (i=1; i<=nra; i++) + for (j=1; j<=ncb; j++) + c[i][j] = 0.0; + + for (i=1; i<=nra; i++) + for (k=1; k<=ncb; k++) + for (j=1; j<=nca; j++) + c[i][k] += a[i][j]*b[j][k]; + return(c); +} + + +double** modified_matmult(double **a, double **b, int nra, int nca, int ncb) { + double **c; + int i,j,k; + c = dmatrix(1,nra,1,ncb); + for (i=1; i<=nra; i++) + for (j=1; j<=ncb; j++) + c[i][j] = 0.0; + + for (i=1; i<=nra; i++) + for (k=1; k<=ncb; k++) + for (j=1; j<=nca; j++) + c[i][k] += a[i][j]*b[j][k]; + + for (i=1; i<=nra; i++) + { + for (j=1; j<=ncb; j++) + printf("%lf\t",c[i][j]); + printf("\n"); + } + + + return(c); +} + + +double** matsum(double **a, double **b, int nr, int nc) { + double **c; + int i,j; + c = dmatrix(1,nr,1,nc); + + for (i=1; i<=nr; i++) + for (j=1; j<=nc; j++) + c[i][j] = a[i][j] + b[i][j]; + return(c); +} + +double** matminus(double **a, double **b, int nr, int nc) { + double **c; + int i,j; + c = dmatrix(1,nr,1,nc); + + for (i=1; i<=nr; i++) + for (j=1; j<=nc; j++) + c[i][j] = a[i][j] - b[i][j]; + return(c); +} + +double** transp (double **a, int n, int m) { + double **b; + int i,j; + b = dmatrix(1,m,1,n); + for (i=1; i<=n; i++) + for (j=1; j<=m; j++) + b[j][i] = a[i][j]; + return(b); +} + +int invers(double **a, int n, double **b, int m) +{ + int *indxc,*indxr,*ipiv; + int i,icol=1,irow=1,j,k,l,ll; + double big,dum,pivinv; + +// if( (indxc = ivector(1,n)) == NULL){ return(-1); } + // if( (indxr = ivector(1,n)) == NULL){ return(-1); } + // if( (ipiv = ivector(1,n)) == NULL){ return(-1); } + if( (indxc=(int *)calloc((unsigned)(n+1)*sizeof(int),sizeof(int))) == NULL){ return(-1); } + if( (indxr=(int *)calloc((unsigned)(n+1)*sizeof(int),sizeof(int))) == NULL){ return(-1); } + if( (ipiv=(int *)calloc((unsigned)(n+1)*sizeof(int),sizeof(int))) == NULL){ return(-1); } + + + for (j=1;j<=n;j++) ipiv[j]=0; + for (i=1;i<=n;i++) { + big=0.0; + for (j=1;j<=n;j++) + if (ipiv[j] != 1) + for (k=1;k<=n;k++) { + if (ipiv[k] == 0) { + if (fabs(a[j][k]) >= big) { + big=fabs(a[j][k]); + irow=j; + icol=k; + } + } else if (ipiv[k] > 1){ + + return(-1); + } + } + ++(ipiv[icol]); + if (irow != icol) { + for (l=1;l<=n;l++){ + double temp=a[irow][l]; a[irow][l]=a[icol][l]; a[icol][l]=temp; + } + for (l=1;l<=m;l++){ + double temp=b[irow][l]; b[irow][l]=b[icol][l]; b[icol][l]=temp; + } + } + indxr[i]=irow; + indxc[i]=icol; + if (a[icol][icol] == 0.0){ + //error("Invers: Singular Matrix-2"); + return(-1); + } + pivinv=1.0/a[icol][icol]; + a[icol][icol]=1.0; + for (l=1;l<=n;l++) a[icol][l] *= pivinv; + for (l=1;l<=m;l++) b[icol][l] *= pivinv; + for (ll=1;ll<=n;ll++) + if (ll != icol) { + dum=a[ll][icol]; + a[ll][icol]=0.0; + for (l=1;l<=n;l++) a[ll][l] -= a[icol][l]*dum; + for (l=1;l<=m;l++) b[ll][l] -= b[icol][l]*dum; + } + } + for (l=n;l>=1;l--) { + if (indxr[l] != indxc[l]){ + for (k=1;k<=n;k++){ + double temp = a[k][indxr[l]]; + a[k][indxr[l]] = a[k][indxc[l]]; + a[k][indxc[l]] = temp; + } + } + } + free(indxc); free(indxr); free(ipiv); + return(0); +} + + diff --git a/var_lib_genenet_bnw/localscore/modified_postc.c b/var_lib_genenet_bnw/localscore/modified_postc.c new file mode 100644 index 00000000..f223fdb8 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/modified_postc.c @@ -0,0 +1,171 @@ +/* -*- Mode: C -*- + * postc.c --- Posterior for continuous node with continuous parents + * Author : Claus Dethlefsen + * Created On : Tue Mar 12 06:44:35 2002 + * Last Modified By: Claus Dethlefsen + * Last Modified On: Wed Jun 04 11:56:51 2003 + * Update Count : 227 + * Status : Unknown, Use with caution! + */ + +/* + ## +## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen +## +## This program is free software; you can redistribute it and/or modify +## it under the terms of the GNU General Public License as published by +## the Free Software Foundation; either version 2 of the License, or +## (at your option) any later version. +## +## This program is distributed in the hope that it will be useful, +## but WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +## GNU General Public License for more details. +## +## You should have received a copy of the GNU General Public License +## along with this program; if not, write to the Free Software +## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +###################################################################### +*/ + +#include "R.h" +#include "Rmath.h" +#include "matrix.h" +#include "modified_matrix.c" + +void postc(double *mu, double *tau, double *rho, double *phi, double + *loglik, double *y, double *z, int *n, int *d) +{ + int i,j,ii,jj; + double logscale,logk,mscore; + double **mtau, **mmu, **tauinv=0; + double **zero, **zi, **ziy; + double **oldtau, **oldmu; + //temp pointers + double **tm1,**tm2,**tm3,**tm4,**mm1,**sm1,**sm2,**tt1,**tt2; + + /* allocate space for matrices */ + mtau = dmatrix(1,*d,1,*d); + oldtau = dmatrix(1,*d,1,*d); + + zi = dmatrix(1,*d,1,1); + ziy = dmatrix(1,*d,1,1); + mmu = dmatrix(1,*d,1,1); + oldmu = dmatrix(1,*d,1,1); + zero = dmatrix(1,*d,1,1); + tauinv = dmatrix(1,*d,1,*d); + + + + /* copy arguments into the matrices */ + asmatrix(mu,mmu,*d,1); + asmatrix(tau,mtau,*d,*d); + + /* show input */ + + for(i = 1; i <= *n; i++) { + for (ii=1; ii<=*d; ii++) { + for (jj=1; jj<=*d; jj++) { + tauinv[ii][jj] = mtau[ii][jj]; + } + } + + invers(tauinv, *d, zero, 1); + + for (j=1; j<=*d; j++) { + zi[j][1] = z[j-1+(i-1)*(*d)]; + } + //define once + tt1=transp(zi,*d,1); + + tm1=matmult(tauinv,zi,*d,*d,1); + tm2=matmult(tt1,tm1,1,*d,1); + + logscale = log(*phi) + log1p(tm2[1][1]); + + free_dmatrix(tm1,1,*d,1,*d); + free_dmatrix(tm2,1,1,1,*d); + + + logk = lgammafn( 0.5*(1.0+*rho) ) - lgammafn(*rho*0.5); + logk -= 0.5*(logscale + log(M_PI)); + + tm1=matmult(tt1,mmu,1,*d,1); + + + mscore = logk - 0.5*(*rho+1)*log1p((y[i-1] - tm1[1][1])*(y[i-1] - tm1[1][1])/exp(logscale)); + *loglik += mscore; + + free_dmatrix(tm1,1,1,1,1); + + for (ii=1; ii<=*d; ii++) { + for (jj=1; jj<=*d; jj++) { + oldtau[ii][jj] = mtau[ii][jj]; + } + } + + + for (jj=1; jj<=*d; jj++) { + oldmu[jj][1] = mmu[jj][1]; + } + + tm1=matmult(zi,tt1,*d,1,*d); + sm1=matsum(mtau,tm1,*d,*d); + free_dmatrix(mtau,1,*d,1,*d); + mtau = sm1; + free_dmatrix(tm1,1,*d,1,*d); + + for (ii=1; ii<=*d; ii++) { + for (jj=1; jj<=*d; jj++) { + tauinv[ii][jj] = mtau[ii][jj]; + } + } + + + invers(tauinv, *d, zero, 1); + + for (j=1;j<=*d;j++) + ziy[j][1] = zi[j][1]*y[i-1]; + + + tm1=matmult(oldtau,mmu,*d,*d,1); + sm2=matsum(tm1,ziy,*d,1); + free_dmatrix(mmu,1,*d,1,1); + mmu=matmult(tauinv,sm2,*d,*d,1); + free_dmatrix(tm1,1,*d,1,*d); + free_dmatrix(sm2,1,*d,1,1); + + + (*rho)++; + + tm1=matmult(tt1,mmu,1,*d,1); + mm1=matminus(oldmu,mmu,*d,1); + tt2=transp(mm1,*d,1); + tm3=matmult(oldtau,oldmu,*d,*d,1); + tm4=matmult(tt2,tm3,1,*d,1); + + (*phi) += (y[i-1]-tm1[1][1])*y[i-1] + tm4[1][1]; + + + free_dmatrix(tm1,1,1,1,*d); + free_dmatrix(mm1,1,*d,1,1); + free_dmatrix(tt2,1,1,1,*d); + free_dmatrix(tm3,1,*d,1,*d); + free_dmatrix(tm4,1,1,1,*d); + + free_dmatrix(tt1,1,1,1,*d); + + + } + + free_dmatrix(mtau,1,*d,1,*d); + free_dmatrix(zi,1,*d,1,1); + free_dmatrix(ziy,1,*d,1,1); + free_dmatrix(mmu,1,*d,1,1); + free_dmatrix(zero,1,*d,1,1); + free_dmatrix(tauinv,1,*d,1,*d); + free_dmatrix(oldtau,1,*d,1,*d); + free_dmatrix(oldmu,1,*d,1,1); + +} + diff --git a/var_lib_genenet_bnw/localscore/network_score.c b/var_lib_genenet_bnw/localscore/network_score.c new file mode 100644 index 00000000..69e84aab --- /dev/null +++ b/var_lib_genenet_bnw/localscore/network_score.c @@ -0,0 +1,1434 @@ +#include<stdio.h> +#include <stdlib.h> +#include<string.h> +#define MATHLIB_STANDALONE 1 +#include "matrix.h" +#include "postc0.c" +#include "modified_postc.c" // only line that has been changed in this code +//#define OUT_DIR "./Result/" //WHERE BENE READ DATA FOR STRUCTURE LEARNING //change it to #define OUT_DIR "/var/www/html/compbio/BNW/bene-0.9-4/example/resdir/" for server. Also change from sprintf(line+9,"%d",i); to sprintf(line+52,"%d",i); + +struct white{ +int n; +int *list; +}; + +struct ban{ +int n; +int *list; +}; + +struct ndata{ +int idx,type,score_i; +char **ddata; +char **label; //for descrete node +int lindex; +double *prob,*cdata,*post_alpha; +double score_zeroparent; +double *score; +struct white wlist; +struct ban blist; +}; + + +struct nd{ +int num,nd,*discrete,nc,*continuous,row; +double score; +struct ndata *node; +}; + +void get_next_seq(int *,int *,int); +void learn_node(struct nd *); +double learn_parent(struct nd *,int,int); + +double run_strtof (const char * input) //Convert string to double +{ + double output; + char * end; + output = strtod (input, & end); + if (end == input) { + return 0.0; + } + else { + return output; + } +} + + +char* itoa(int val, int base){ //convert number to string + + static char buf[32] = {0}; + + int i = 30; + + for(; val && i ; --i, val /= base) + + buf[i] = "0123456789abcdef"[val % base]; + + return &buf[i+1]; + +} + +double standarizedata(double val,double mean,double std) +{ + return (val-mean)/std; + +} + +double mean(double *a,int l) +{ +int i; +double m; +m=0; +for(i=0;i<l;i++) +{ + m+=a[i]; +} +m=m/l; +return m; +} + + +double stdev(double *a,int l,double m) +{ +int i; +double sqsum=0.0; + +for(i=0;i<l;i++) +{ + sqsum+=(a[i]-m)*(a[i]-m); + +} + +return sqrt(sqsum/(l-1)); +} + + +main(int argc, char *argv[]) +{ + FILE * pFile,*banf,*whitef; + int i,s_i,j,k,l,m,id,ic,c,row,imatch,flag,bit,bit_count,ccount,maxccount; + int n = 0,ban_flag,white_flag,white_flag_all; + char line[2500],nf[250],nt[250],*file_name; + char **name; //name of variables + double tc,tcm,score_val; + struct nd network; + int MAX_PARENT; + FILE **inputFiles; + + + double min_score; + + + if(argc<=5) + { + printf("Use 5 arguments: 1. input data file name. 2. ban list file name. 3. white list file name. 4. integer value of the maximum number of parents are allowed and 5. output file directory\n"); + return; + } + + + + pFile=fopen (argv[1],"r"); + + + if (pFile==NULL) perror ("Error opening file"); + else + {//reading data from input file + + + row=0; + do{ row++; + } while (fgets (line,2500,pFile)!=NULL); + + row-=3; + network.row=row; + fclose(pFile); + pFile=fopen (argv[1],"r"); + ccount=0; + maxccount=0; + do { + c = fgetc (pFile); + if (c == '\t') + { + n++; + if(maxccount<ccount) + maxccount=ccount; + ccount=0; + } + else + ccount++; + + + } while (c != '\n'); + + + network.num=n+1; + network.discrete=(int *)malloc(sizeof(int)*network.num); + network.continuous=(int *)malloc(sizeof(int)*network.num); + network.node=(struct ndata *)malloc(sizeof(struct ndata)*network.num); + + MAX_PARENT=atoi(argv[4]); //maximum number of parents for each node + if(MAX_PARENT==0) //no restriction on parents + MAX_PARENT=network.num+1; + + name=(char **)malloc(sizeof(char *)*network.num); + + for(i=0;i<network.num;i++) + name[i]=(char *)malloc(sizeof(char)*(maxccount+1)); + + + + id=0; + ic=0; + for(i=0;i<=n;i++) + { + fscanf(pFile,"%d",&c); + network.node[i].idx=i; + network.node[i].type=c; + if(c==1) + { + network.continuous[ic]=i; + ic++; + network.node[i].prob=(double *)malloc(sizeof(double)*2); //probability array of size 2 for continuous node + network.node[i].prob[0]=0.0; //initialization + network.node[i].prob[1]=0.0; + network.node[i].cdata=(double *)malloc(sizeof(double)*row); //data matrix for continuous node + } + else + { + network.discrete[id]=i; + network.node[i].post_alpha=(double *)calloc(network.node[i].type,sizeof(double)); //prepare total count of each discrete data lebel initialize with zero by calloc which is used in learnnode + id++; + network.node[i].prob=(double *)malloc(sizeof(double)*c); //probability array of size equals to number of levels for discrete node + network.node[i].ddata=(char **)malloc(sizeof(char *)*row); //data matrix for continuous node + network.node[i].label=(char **)malloc(sizeof(char *)*c); //label array + for(j=0;j<c;j++) + network.node[i].prob[j]=1.0/c; + } + } + network.nd=id; network.nc=ic; + j=0; + + do{ //calculate average and prob for each node + for(i=0;i<=n;i++) //n is nimber of column in the data matrix + { + if(network.node[i].type==1) //if continuous + { + fscanf(pFile,"%s",line); + tc=run_strtof(line); + //network.node[i].prob[1]+=tc; //summation for average + network.node[i].cdata[j]=tc; // data values in data column vector + } + else //discrete + { + fscanf(pFile,"%s",line); + network.node[i].ddata[j]=(char *)malloc(sizeof(char)*strlen(line)); + if(j==0) //first iteration of do while + { + network.node[i].lindex=0; + network.node[i].label[0]=(char *)malloc(sizeof(char)*strlen(line)); + strcpy(network.node[i].label[0],line); //new label assigned to label list + network.node[i].post_alpha[0]=1; + + } + else //store different label for discrete node also count number of ocarance of each label for calculation of post alpha score + { + imatch=0; + for(k=0;k<=network.node[i].lindex;k++) + { + if(strcmp(network.node[i].label[k],line)==0) + { + imatch=1; + network.node[i].post_alpha[k]+=1; + break; + } + } + if(imatch==0) + { + network.node[i].lindex++; + k=network.node[i].lindex; + network.node[i].label[k]=(char *)malloc(sizeof(char)*strlen(line)); + strcpy(network.node[i].label[k],line); //new label assigned to label list + network.node[i].post_alpha[k]+=1; + } + } + strcpy(network.node[i].ddata[j],line); + } + + } + j++; + } while (fgets (line,250,pFile)!=NULL); //end of do while to read the input file + + //////////////normalize continuous data///////////// + for(i=0;i<=n;i++) + { + if(network.node[i].type==1) + { + + tcm=mean(network.node[i].cdata,row); + tc=stdev(network.node[i].cdata,row,tcm); + for(j=0;j<row;j++) + { + network.node[i].cdata[j]=standarizedata(network.node[i].cdata[j],tcm,tc); //dataval.data mean, standard deviation + } + } + } + + //////////////////adjust average and prob for normalized data + for(i=0;i<=n;i++) + { + if(network.node[i].type==1) //claculate average and prob for continuous nodes + { + network.node[i].prob[1]=mean(network.node[i].cdata,row); + + for(j=0;j<row;j++) + { + network.node[i].prob[0]+=(network.node[i].cdata[j]-network.node[i].prob[1])*(network.node[i].cdata[j]-network.node[i].prob[1]); + } + network.node[i].prob[0]*=1.0/(double)(row-1); + network.node[i].prob[0]*=(double)(row-1.0)/(double)row; + + } + } + + fclose (pFile); + }//end of else part for open input file + + pFile=fopen (argv[1],"r"); + + for(i=0;i<network.num;i++) + fscanf(pFile,"%s",name[i]); + + fclose(pFile); + + learn_node(&network); //call function to learn network and get local score whell 0 parent for all nodes + + + + //printf("%.2lf\n",learn_parent(&network,6,176)); + // printf("%.2lf\n",learn_parent(&network,6,47)); + // printf("%.2lf\n",learn_parent(&network,6,18)); + //printf("%.2lf\n",learn_parent(&network,7,80)); + ////////printing trylist to a file//////////////////////////////// + + //fprintf(outfile,"Number of nodes\n%d\n",network.num); + //fprintf(outfile,"Possible sets of parents per node\n"); + j=(int)pow(2.0,network.nd-1); //possible number of parents for discrete node + k=(int)pow(2.0,network.num-1); //possible number of parents for continuous nodes + + + for(i=0;i<network.num;i++) + { + network.node[i].score=(double *)malloc(sizeof(double)*(k+1)); + network.node[i].score_i=0; + + + network.node[i].wlist.n=0; + network.node[i].blist.n=0; + network.node[i].blist.list=(int *)malloc(sizeof(int)*network.num); + network.node[i].wlist.list=(int *)malloc(sizeof(int)*network.num); + // if(network.node[i].type>1) //discrete + // fprintf(outfile,"%d\t",j); + //else //continuous + // fprintf(outfile,"%d\t",k); + } + + banf=fopen (argv[2],"r"); //ban list file name + whitef=fopen (argv[3],"r"); //white list file name + + //read banlist +strcpy(nf,""); +strcpy(nt,""); + +while (fgets (line,2500,banf)!=NULL){ + + fscanf(banf,"%s",nf); //node from + fscanf(banf,"%s",nt); //node to + + for(i=0;i<network.num;i++) + { + if(strcmp(name[i],nt)==0) + { + j=network.node[i].blist.n; + for(l=0;l<network.num;l++) + { + if(strcmp(name[l],nf)==0) + { + ban_flag=0; + for(k=0;k<network.node[i].blist.n;k++) + { + if(network.node[i].blist.list[k]==l) + { + ban_flag=1; + break; + } + } + if(ban_flag==0) + { + network.node[i].blist.list[j]=l; + j++; + network.node[i].blist.n=j; + } + + + } + } + } + } + +} + + + +//read whitelist +strcpy(nf,""); +strcpy(nt,""); + +while (fgets (line,2500,whitef)!=NULL){ + +fscanf(whitef,"%s",nf); //node from +fscanf(whitef,"%s",nt); //node to + +for(i=0;i<network.num;i++) + { + if(strcmp(name[i],nt)==0) + { + j=network.node[i].wlist.n; + for(l=0;l<network.num;l++) + { + if(strcmp(name[l],nf)==0) + { + white_flag=0; + for(k=0;k<network.node[i].wlist.n;k++) + { + if(network.node[i].wlist.list[k]==l) + { + white_flag=1; + break; + } + } + if(white_flag==0) + { + + network.node[i].wlist.list[j]=l; + j++; + network.node[i].wlist.n=j; + } + + + } + } + } + } + +} + + //fprintf(outfile,"\nChild Parents Score\n"); + + m=(int)pow(2.0,network.num)-1; //number of combinations of parents + min_score=1.0; + for(i=0;i<network.num;i++) + { + + if(network.node[i].wlist.n==0) + { + network.node[i].score[0]=network.node[i].score_zeroparent; + if(min_score>network.node[i].score_zeroparent) + min_score=network.node[i].score_zeroparent; + + //fprintf(outfile,"%d\t0\t%lf\n",i+1,network.node[i].score_zeroparent); //printing score for zero parent + } + else + { + network.node[i].score[0]=1.0; + //fprintf(outfile,"%d\t0\t0.0\n",i+1); + + } + network.node[i].score_i=1; + + + for(j=0;j<m;j++) + { + + + + bit= (j+1 >> i) & 1; + + if(bit!=1) //check if the child itself is present in parent list + { + + bit_count=0; + //fprintf(outfile,"%d\t",i+1); + for(l=0;l<network.num;l++) + { + bit= (j+1 >> l) & 1; + if(bit==1) + { + //fprintf(outfile,"%d",l+1); + bit_count++; + + } + + } + + + if(network.node[i].type>1) //if discrete node checck if any continuous node is included in the parent list + { + flag=0; + ban_flag=0; + + for(l=0;l<network.num;l++) + { + bit= (j+1 >> l) & 1; + + if(bit==1 && network.node[l].type==1) //check if continuous is parent of discrete + { + flag=1; + break; + } + if(bit==1) + { + for(k=0;k<network.node[i].blist.n;k++) + { + if(network.node[i].blist.list[k]==l) + { + ban_flag=1; + break; + } + } + + + if(ban_flag==1) + break; + } + + + + } + if(flag==0) //if no continuous parent for discrete node then learn the network with the list of parents + { + + if(bit_count>MAX_PARENT) + { + //fprintf(outfile,"\t0.0\n"); + + s_i=network.node[i].score_i; + network.node[i].score[s_i]=1.0; + network.node[i].score_i=s_i+1; + + + + } + else if(ban_flag==1) + { + //fprintf(outfile,"\t0.0\n"); + s_i=network.node[i].score_i; + network.node[i].score[s_i]=1.0; + network.node[i].score_i=s_i+1; + } + else // calculate score if white list check get satisfied + { + if(network.node[i].wlist.n==0) + { + score_val=learn_parent(&network,i,j); + + if(min_score>score_val) + min_score=score_val; + + + + //fprintf(outfile,"\t%lf\n",score_val); + s_i=network.node[i].score_i; + network.node[i].score[s_i]=score_val; + network.node[i].score_i=s_i+1; + } + else if(bit_count<network.node[i].wlist.n) //white list is greater than list of parents + { + //fprintf(outfile,"\tfor white\t0.0\n"); + s_i=network.node[i].score_i; + network.node[i].score[s_i]=1.0; + network.node[i].score_i=s_i+1; + } + else + { + white_flag=0; + white_flag_all=0; + + for(l=0;l<network.num;l++) + { + bit= (j+1 >> l) & 1; + + if(bit==1) + { + for(k=0;k<network.node[i].wlist.n;k++) + { + if(network.node[i].wlist.list[k]==l) + { + white_flag=1; + break; + } + } + if(white_flag!=1) + { + white_flag_all=1; + break; + + } + + } + } + if(white_flag_all==0) + { + score_val=learn_parent(&network,i,j); + if(min_score>score_val) + min_score=score_val; + + //fprintf(outfile,"\t%lf\n",score_val); + s_i=network.node[i].score_i; + network.node[i].score[s_i]=score_val; + network.node[i].score_i=s_i+1; + } + else + { + //fprintf(outfile,"\t0.0\n"); + s_i=network.node[i].score_i; + network.node[i].score[s_i]=1.0; + network.node[i].score_i=s_i+1; + } + + } + } + + } + else //fill up data when continuous is parent of discrete + { + //fprintf(outfile,"\t0.0\n"); + s_i=network.node[i].score_i; + network.node[i].score[s_i]=1.0; + network.node[i].score_i=s_i+1; + + } + } + else //if continuous node then learn the network with the parent set + { + + ban_flag=0; + + + for(l=0;l<network.num;l++) + { + bit= (j+1 >> l) & 1; + if(bit==1) + { + + for(k=0;k<network.node[i].blist.n;k++) + { + if(network.node[i].blist.list[k]==l) + { + ban_flag=1; + break; + } + } + if(ban_flag==1) + break; + } + + + } + if(bit_count>MAX_PARENT) + { + //fprintf(outfile,"\t0.0\n"); + s_i=network.node[i].score_i; + network.node[i].score[s_i]=1.0; + network.node[i].score_i=s_i+1; + } + else if(ban_flag==1) + { + //fprintf(outfile,"\t0.0\n"); + s_i=network.node[i].score_i; + network.node[i].score[s_i]=1.0; + network.node[i].score_i=s_i+1; + } + else + { + if(network.node[i].wlist.n==0) + { + score_val=learn_parent(&network,i,j); + if(min_score>score_val) + min_score=score_val; + + //fprintf(outfile,"\t%lf\n",score_val); + s_i=network.node[i].score_i; + network.node[i].score[s_i]=score_val; + network.node[i].score_i=s_i+1; + } + else if(bit_count<network.node[i].wlist.n) //white list is greater than list of parents + { + //fprintf(outfile,"\t0.0\n"); + s_i=network.node[i].score_i; + network.node[i].score[s_i]=1.0; + network.node[i].score_i=s_i+1; + } + else + { + white_flag=0; + white_flag_all=0; + + for(l=0;l<network.num;l++) + { + bit= (j+1 >> l) & 1; + + if(bit==1) + { + for(k=0;k<network.node[i].wlist.n;k++) + { + if(network.node[i].wlist.list[k]==l) + { + white_flag=1; + break; + } + } + if(white_flag!=1) + { + white_flag_all=1; + break; + + } + + } + } + if(white_flag_all==0) + { + score_val=learn_parent(&network,i,j); + if(min_score>score_val) + min_score=score_val; + + //fprintf(outfile,"\t%lf\n",score_val); + s_i=network.node[i].score_i; + network.node[i].score[s_i]=score_val; + network.node[i].score_i=s_i+1; + } + else + { + // fprintf(outfile,"\t0.0\n"); + s_i=network.node[i].score_i; + network.node[i].score[s_i]=1.0; + network.node[i].score_i=s_i+1; + } + + } + } + + + } + + + } + } + } + + +//print scores to separate files + +min_score*=10; +inputFiles= (FILE **) malloc(network.num * sizeof(FILE*)); + + +for(i=0;i<network.num;i++) +{ + strcpy(line,argv[5]); + k=strlen(line); + sprintf(line+k,"/%d",i); + + inputFiles[i] = fopen(line, "wb"); + + //print content + for(j=0;j<network.node[i].score_i;j++) + { + if(network.node[i].score[j]<1.0) + fwrite(&network.node[i].score[j],sizeof(double),1,inputFiles[i]); // fprintf(inputFiles[i],"%lf\n",network.node[i].score[j]); + else + fwrite(&min_score,sizeof(double),1,inputFiles[i]); //fprintf(inputFiles[i],"%lf\n",min_score); + } + + fclose(inputFiles[i]); +} + + + + + + +fclose(banf); +fclose(whitef); + + +// printf("Time elapsed: %f\n", ((double)clock() - start) / CLOCKS_PER_SEC); + +} + + +/* learn the network for zero parent */ + +void learn_node(struct nd *net) +{ + int i,j,k,nk,l,m,i1,j1; + long num,temp; + double n,N,s2; + struct nd network=*net; //create a local copy + double *alpha,nu,rho,mu,phi,tau; + double post_nu,post_rho,post_mu,post_phi,post_tau; + double loglik,post_loglik; + + num=network.num; + + nk=1; + + for(i=0;i<num;i++) + { + if(network.node[i].type>1) + nk*=network.node[i].type; + } + + + + + for(i=0;i<num;i++) + { + if(network.node[i].type>1) + { + + alpha=(double *)malloc(sizeof(double)*network.node[i].type); + k=1; + + for(j=0;j<num;j++) + { + if(i!=j && network.node[j].type>1) + k*=network.node[j].type; + + } + N=0.0; n=0.0; + for(j=0;j<network.node[i].type;j++) + { + alpha[j]=2.0*k; + network.node[i].post_alpha[j]+=alpha[j]; + ////////update loglik from udisclik + n+=alpha[j]; + N+=network.node[i].post_alpha[j]; + } + + + loglik=0.0; + post_loglik=0.0; + + for(j=0;j<network.node[i].type;j++) + post_loglik+=lgammafn(network.node[i].post_alpha[j])-lgammafn(alpha[j]); + + post_loglik+=lgammafn(n); + post_loglik-=lgammafn(N); + + + } + else + { + nu=nk*2.0; + tau=nu; + rho=nk*2.0; + mu=network.node[i].prob[1]; + phi=network.node[i].prob[0]*nk; + loglik=0.0; + post_mu=mu; + post_tau=tau; + post_rho=rho; + post_phi=phi; + post_loglik=loglik; + + postc0(&post_mu,&post_tau,&post_rho,&post_phi,&post_loglik,network.node[i].cdata,&network.row); + + + } + network.node[i].score_zeroparent=post_loglik; // store the zero parent score + + } + + if(nk!=1) + free(alpha); + + *net=network; //coppied back to original +} + + +/* +learn node for a list of parents +*/ + +double learn_parent(struct nd *net,int child,int p) +{ + int i,j,jj,k,nk,l,m,i1,j1,k1,k2,cn_send; + long num,temp; + double n,N,s2; + struct nd network=*net; //create a local copy + int cn,ds,bit,*discrete,*continuous; + double alpha,*postalpha,alpha_parent,*postalpha_parent,nu,rho,mu,phi,tau; + double post_nu,post_rho,*post_mu,post_phi,post_tau; + double loglik,post_loglik=0,post_loglik_parent=0; + double *mu_mat,**tau_mat,tau11,tau12,tau22,div,phiinv; + char **label; + int *a,*l_list,flag,y_count,z_count; + double *y,mu_p,phi_p,*tau_send,*z_send,loglik_sum; + + + + num=network.num; + + continuous=(int *)malloc(sizeof(int)*network.nc); + discrete=(int *)malloc(sizeof(int)*network.nd); + + nk=1; + for(i=0;i<num;i++) + { + if(network.node[i].type>1) + nk*=network.node[i].type; + } + +//list of discrete snd continuous parents + cn=0; + ds=0; + alpha_parent=0; + alpha=2; + + k1=network.node[child].type; + k2=1; + + //printf("%d\n",child); + for(j=0;j<network.num;j++) //list the continuous parents and discrete parents + { + bit= (p+1 >> j) & 1; + + + if(bit==1 && j!=child) + { + + if(network.node[j].type>1) + { + discrete[ds]=j; + //printf("discrete parent=%d\n",j); + k1*=network.node[j].type; + k2*=network.node[j].type; + ds++; + } + else + { + continuous[cn]=j; + //printf("continuous parent=%d\n",j); + cn++; + } + } + else if(j!=child) + { + alpha*=network.node[j].type; + } + } + + if(network.nd<=2) + alpha=2; + + i=child; //i is the node with changes in its parrent nodes + + if(network.node[i].type>1 && cn==0) // no continuous node //prepare alpha and post alpha and then calculate local score + { + + k=k1; + postalpha=(double *)calloc(network.node[i].type,sizeof(double)); + + label=(char **)malloc(sizeof(char *)*(ds+1)); //label array + a=(int *)calloc((ds+1),sizeof(int)); + l_list=(int *)malloc(sizeof(int)*(ds+1)); + + for(j=0;j<=ds;j++) + label[j]=(char *)malloc(sizeof(char)*100); + + for(j=0;j<ds;j++) + { + l=discrete[j]; + l_list[j]=network.node[l].type; + + } + l_list[ds]=network.node[i].type; + + for(j=0;j<k;j++) + { + + get_next_seq(a,l_list,ds+1); // prepare a new combination of labels for parent + for(i1=0;i1<ds;i1++) + { + j1=a[i1]; + l=discrete[i1]; + strcpy(label[i1],network.node[l].label[j1]); + } + + j1=a[i1]; + strcpy(label[i1],network.node[child].label[j1]); + for(i1=0;i1<network.node[i].type;i1++) + postalpha[i1]=0; + for(i1=0;i1<network.row;i1++) // search through parents data and count how many number of matches for current label list. prepare post alpha from count+alpha + { + flag=0; + for(m=0;m<ds;m++) + { + j1=a[m]; + l=discrete[m]; + if(strcmp(label[m],network.node[l].ddata[i1])!=0) + { + flag=1; + } + } + j1=a[m]; + if(strcmp(label[m],network.node[child].ddata[i1])!=0) + { + flag=1; + } + if(flag==0) + { + j1=a[ds]; + postalpha[j1]+=1; + + } + } + for(m=0;m<network.node[i].type;m++) + { + if(postalpha[m]!=0) + { + postalpha[m]+=alpha; + post_loglik+=lgammafn(postalpha[m])-lgammafn(alpha); + } + } + } + + + k=k2; // repeat the last step of preparing alpha and post alpha for only parent set. this time exclude the child node label from computation. prepare alpha_parent and post_alphaparent + l=discrete[ds-1]; + postalpha_parent=(double *)calloc(network.node[l].type,sizeof(double)); + + for(j=0;j<ds;j++) + { + l=discrete[j]; + l_list[j]=network.node[l].type; + a[j]=0; + + } + for(j=0;j<k1/k2;j++) + alpha_parent+=alpha; + for(j=0;j<k;j++) + { + get_next_seq(a,l_list,ds); + + for(i1=0;i1<ds;i1++) + { + j1=a[i1]; + l=discrete[i1]; + strcpy(label[i1],network.node[l].label[j1]); + + } + + l=discrete[ds-1]; + for(i1=0;i1<network.node[l].type;i1++) + postalpha_parent[i1]=0; + + for(i1=0;i1<network.row;i1++) + { + flag=0; + for(m=0;m<ds;m++) + { + j1=a[m]; + l=discrete[m]; + if(strcmp(label[m],network.node[l].ddata[i1])!=0) + { + flag=1; + } + } + + if(flag==0) + { + j1=a[ds-1]; + postalpha_parent[j1]+=1; + + } + } + l=discrete[ds-1]; + for(m=0;m<network.node[l].type;m++) + { + if(postalpha_parent[m]!=0) + { + postalpha_parent[m]+=alpha_parent; + post_loglik_parent+=lgammafn(postalpha_parent[m])-lgammafn(alpha_parent); + } + } + } + + + loglik=post_loglik-post_loglik_parent; + free(postalpha); + free(postalpha_parent); + for(j=0;j<=ds;j++) + free(label[j]); + free(label); + free(a); + free(l_list); + + } + else if(network.node[i].type==1 && ds==0) // no discrete node //prepare continuous parameter set + { + z_count=0; + tau_mat=(double **)malloc(sizeof(double *)*(cn+1)); + + z_send=(double *)malloc(sizeof(double)*(cn+1)*network.row); + tau_send=(double *)malloc(sizeof(double)*(cn+1)*(cn+1)); + + mu_mat=(double *)malloc(sizeof(double)*(cn+1)); + nu=nk*2.0; rho=nk*2.0+cn; + mu_mat[0]=network.node[i].prob[1]; + for(j=0;j<cn;j++) + { + mu_mat[j+1]=0; + tau_mat[j]=(double *)malloc(sizeof(double)*(cn+1)); + + } + + tau_mat[j]=(double *)malloc(sizeof(double)*(cn+1)); + + for(j=0;j<network.row;j++) + { + z_send[z_count]=1; + z_count++; + for(j1=0;j1<cn;j1++) + { + l=continuous[j1]; + z_send[z_count]=network.node[l].cdata[j]; + z_count++; + } + + } + + phi=network.node[i].prob[0]*nk; + + //preparing tau + + //**tau_mat + for(j=0;j<=cn;j++) + for(m=0;m<=cn;m++) + { + tau_mat[j][m]=1.0; + } + + for(j=0;j<cn;j++) + { + l=continuous[j]; + mu_p=network.node[l].prob[1]; + phi_p=network.node[l].prob[0]*nk; + phiinv=1/phi_p; + tau11 = 1/nu + mu_p*phiinv*mu_p; + tau22 = phiinv; + tau12 = -mu_p*phiinv; + div=tau11*tau22-tau12*tau12; + if(j==0) + tau_mat[0][0]=tau22/div; + tau_mat[0][j+1]=-tau12/div; + tau_mat[j+1][0]=tau_mat[0][j+1]; + tau_mat[j+1][j+1]=tau11/div; + } + + for(j=0;j<=cn;j++) + for(m=0;m<=cn;m++) + { + if(tau_mat[j][m]==1.0) + { + tau_mat[j][m]=tau_mat[0][j]*(tau_mat[0][m]/tau_mat[0][0]); + + } + j1=j*(cn+1)+m; + tau_send[j1]=tau_mat[j][m]; + + } + + loglik=0.0; + + cn_send=cn+1; + + postc(mu_mat,tau_send,&rho,&phi,&loglik,network.node[i].cdata,z_send,&network.row,&cn_send); + + + free(z_send); + free(tau_send); + for(j=0;j<=cn;j++) + free(tau_mat[j]); + free(tau_mat); + free(mu_mat); + + } + else //hybrid cases + { + if(cn==0) //if parents are all discrete and child is continuous + { + + ///////////////////prepare y array and run c code//////////////////////////////// + loglik_sum=0; + k=k2; + y=(double *)calloc(network.row,sizeof(double)); + label=(char **)malloc(sizeof(char *)*(ds)); //label array + a=(int *)calloc((ds+1),sizeof(int)); + l_list=(int *)malloc(sizeof(int)*(ds)); + + for(j=0;j<ds;j++) + label[j]=(char *)malloc(sizeof(char)*100); + + for(j=0;j<ds;j++) + { + l=discrete[j]; + l_list[j]=network.node[l].type; + + } + + + for(j=0;j<k;j++) + { + + nu=(nk*2.0)/k2; + tau=nu; + rho=nu; + mu=network.node[i].prob[1]; + phi=network.node[i].prob[0]*nu/2; + loglik=0.0; + + get_next_seq(a,l_list,ds); // prepare a new combination of labels for parent + for(i1=0;i1<ds;i1++) + { + j1=a[i1]; + l=discrete[i1]; + strcpy(label[i1],network.node[l].label[j1]); + } + y_count=0; + for(i1=0;i1<network.row;i1++) // search through parents data and count how many number of matches for current label list. prepare post alpha from count+alpha + { + flag=0; + for(m=0;m<ds;m++) + { + + l=discrete[m]; + if(strcmp(label[m],network.node[l].ddata[i1])!=0) + { + flag=1; + } + } + + if(flag==0) + { + y[y_count]=network.node[i].cdata[i1]; + y_count++; + + } + } + + postc0(&mu,&tau,&rho,&phi,&loglik,y,&y_count); + loglik_sum+=loglik; + + + } + + loglik=loglik_sum; + + free(y); + for(j=0;j<ds;j++) + free(label[j]); + free(label); + free(a); + free(l_list); + + + }//end of continuous node discrete parent check + else //all the other hybrid cases when parents are both continuous and discrete + { + + + tau_mat=(double **)malloc(sizeof(double *)*(cn+1)); + z_send=(double *)malloc(sizeof(double)*(cn+1)*network.row); + tau_send=(double *)malloc(sizeof(double)*(cn+1)*(cn+1)); + mu_mat=(double *)malloc(sizeof(double)*(cn+1)); + + for(j=0;j<cn;j++) + { + tau_mat[j]=(double *)malloc(sizeof(double)*(cn+1)); + } + + + tau_mat[j]=(double *)malloc(sizeof(double)*(cn+1)); + + ///////////////////prepare parameters and run c code//////////////////////////////// + loglik_sum=0.0; + k=k2; + y=(double *)calloc(network.row,sizeof(double)); + label=(char **)malloc(sizeof(char *)*(ds)); //label array + a=(int *)calloc((ds+1),sizeof(int)); + l_list=(int *)malloc(sizeof(int)*(ds)); + + for(j=0;j<ds;j++) + label[j]=(char *)malloc(sizeof(char)*100); + + for(j=0;j<ds;j++) + { + l=discrete[j]; + l_list[j]=network.node[l].type; + + } + + + for(jj=0;jj<k;jj++) + { + + nu=(nk*2.0)/k2; + rho=nu+cn; + mu_mat[0]=network.node[i].prob[1]; + + for(j1=0;j1<cn;j1++) + mu_mat[j1+1]=0; + + phi=network.node[i].prob[0]*nu/2; + //preparing tau + //**tau_mat + for(j=0;j<=cn;j++) + for(m=0;m<=cn;m++) + { + tau_mat[j][m]=1.0; + } + + for(j=0;j<cn;j++) + { + l=continuous[j]; + mu_p=network.node[l].prob[1]; + phi_p=network.node[l].prob[0]*(nk/k2); + + phiinv=1/phi_p; + tau11 = 1/nu + mu_p*phiinv*mu_p; + tau22 = phiinv; + tau12 = -mu_p*phiinv; + div=tau11*tau22-tau12*tau12; + if(j==0) + tau_mat[0][0]=tau22/div; + + tau_mat[0][j+1]=-tau12/div; + tau_mat[j+1][0]=tau_mat[0][j+1]; + tau_mat[j+1][j+1]=tau11/div; + + + } + for(j=0;j<=cn;j++) + for(m=0;m<=cn;m++) + { + if(tau_mat[j][m]==1.0) + { + tau_mat[j][m]=tau_mat[0][j]*(tau_mat[0][m]/tau_mat[0][0]); + } + + j1=j*(cn+1)+m; + tau_send[j1]=tau_mat[j][m]; + + //printf("%.2lf\t",tau_mat[j][m]); + } + //printf("\n"); + loglik=0.0; + + + cn_send=cn+1; + + + get_next_seq(a,l_list,ds); // prepare a new combination of labels for parent + for(i1=0;i1<ds;i1++) + { + j1=a[i1]; + l=discrete[i1]; + strcpy(label[i1],network.node[l].label[j1]); + } + y_count=0; + z_count=0; + for(i1=0;i1<network.row;i1++) // search through parents data and count how many number of matches for current label list. prepare post alpha from count+alpha + { + flag=0; + for(m=0;m<ds;m++) + { + + l=discrete[m]; + if(strcmp(label[m],network.node[l].ddata[i1])!=0) + { + flag=1; + } + } + + if(flag==0) + { + y[y_count]=network.node[i].cdata[i1]; + + //prepare z send matrix + z_send[z_count]=1; + z_count++; + for(j1=0;j1<cn;j1++) + { + l=continuous[j1]; + z_send[z_count]=network.node[l].cdata[i1]; + z_count++; + } + y_count++; + } + } + + postc(mu_mat,tau_send,&rho,&phi,&loglik,y,z_send,&y_count,&cn_send); + + loglik_sum+=loglik; + + + } + + loglik=loglik_sum; + + free(y); + //free(z); + free(z_send); + free(tau_send); + for(j=0;j<=cn;j++) + free(tau_mat[j]); + free(tau_mat); + free(mu_mat); + for(j=0;j<ds;j++) + free(label[j]); + free(label); + free(a); + free(l_list); + + }//end of else part for hybrid when parents are mixed + + }//end of else part for hybrid + + free(continuous); + free(discrete); + return loglik; + + +} + +void get_next_seq(int *a,int *l,int size) +{ + int j,idx; + idx=size-1; + a[idx]+=1; + if(a[idx]==l[idx]) + { + a[idx]=0; + for(j=idx-1;j>=0;j--){ + a[j]+=1; + if(a[j]==l[j]) + a[j]=0; + else + break; + } + } +} + + diff --git a/var_lib_genenet_bnw/localscore/postc0.c b/var_lib_genenet_bnw/localscore/postc0.c new file mode 100644 index 00000000..16e9ccec --- /dev/null +++ b/var_lib_genenet_bnw/localscore/postc0.c @@ -0,0 +1,81 @@ +/* -*- Mode: C -*- + * postc0.c --- Posterior for continuous node with 0 parents + * Author : Claus Dethlefsen + * Created On : Tue Mar 12 06:44:35 2002 + * Last Modified By: Claus Dethlefsen + * Last Modified On: Wed Jun 04 11:57:10 2003 + * Update Count : 55 + * Status : Unknown, Use with caution! + */ + +/* + ## +## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen +## +## This program is free software; you can redistribute it and/or modify +## it under the terms of the GNU General Public License as published by +## the Free Software Foundation; either version 2 of the License, or +## (at your option) any later version. +## +## This program is distributed in the hope that it will be useful, +## but WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +## GNU General Public License for more details. +## +## You should have received a copy of the GNU General Public License +## along with this program; if not, write to the Free Software +## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +###################################################################### +*/ + +#include "R.h" +#include "Rmath.h" + + +void postc0(double *mu, double *tau, double *rho, double *phi, double + *loglik, double *y, int *n) +{ + int i; + double logscale,logk,mscore; + double oldtau,oldmu; + +/* Rprintf("her er mu=%f\n",*mu); + Rprintf("her er tau=%f\n",*tau); + Rprintf("her er rho=%f\n",*rho); + Rprintf("her er phi=%f\n",*phi); + Rprintf("her er loglik=%f\n",*loglik); +*/ + + for(i = 0; i < *n; i++) { + + logscale = log(*phi)+log1p(1.0/(*tau)); + logk = lgammafn( 0.5*(1.0+*rho) ) - lgammafn(*rho*0.5); + logk -= 0.5*(logscale + log(M_PI)); + mscore = logk - 0.5*(*rho+1.0)*log1p( (y[i]-*mu)*(y[i]-*mu)/exp(logscale)); + *loglik += mscore; + + oldtau = *tau; + oldmu = *mu; + + (*tau)++; + (*rho)++; +/* Rprintf("her er oldmu=%f\n",oldmu); + Rprintf("her er oldtau=%f\n",oldtau); + Rprintf("her er mu=%f\n",*mu); + Rprintf("her er tau=%f\n",*tau); +*/ + *mu = (oldtau*(*mu)+y[i])/(*tau); + *phi+= (y[i]-(*mu))*y[i] + (oldmu-(*mu))*oldtau*oldmu; +/* Rprintf("logscale=%f\n",logscale); + Rprintf("logk=%f\n",logk); + Rprintf("mscore=%f\n",mscore); + Rprintf("loglik=%f\n",*loglik); + + Rprintf("her er mu=%f\n",*mu); + Rprintf("her er tau=%f\n",*tau); + Rprintf("her er rho=%f\n",*rho); + Rprintf("her er phi=%f\n",*phi); + Rprintf("her er loglik=%f\n",*loglik); +*/ + } +} diff --git a/var_lib_genenet_bnw/localscore/rlocale.h b/var_lib_genenet_bnw/localscore/rlocale.h new file mode 100644 index 00000000..ac08f341 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/rlocale.h @@ -0,0 +1,118 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 2005-12 The R Core Team + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + + +/* This file was contributed by Ei-ji Nakama. + * See also the comments in src/main/rlocale.c. + + * For use in R only. + */ + +#ifndef R_LOCALE_H +#define R_LOCALE_H + +#ifndef NO_C_HEADERS +#include <wchar.h> +#include <ctype.h> +#include <wctype.h> +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +extern const char *locale2charset(const char *); + +/* + * Windows CJK + * In Unicode, there is not a rule about character width. + * A letter of breadth is used in a CJK (China, Japan, Korea, + * Taiwan, Hong Kong, and Singapore) area, and there are a + * letter and a standard (character width is not still prescribed) + * of a cord in a country. + * Letter width is a problem of a font, but it is a rule route + * besides a alphanumeric character that use a breadth letter. + * It is generally defined as a breadth letter for a font such + * as Japanese. + * - Win32 + + * Attempted explanation by BDR + * The display widths of characters are not prescribed in Unicode. + * Double-width characters are used in the CJK area: their width can + * be font-specific, with different fonts in use in different parts + * of the CJK area. The tables supplied in many OSes and by Marcus + * Kuhn are not do not take the exact locale into account. The + * tables supplied in rlocale_data.h allow different widths for + * different parts of the CJK area, and also where needed different + * widths on Windows. (The Windows differences are in zh_CN, and + * apply to European characters.) + * + */ +extern int Ri18n_wcwidth(wchar_t); +extern int Ri18n_wcswidth (const wchar_t *, size_t); + +/* Mac OSX CJK and WindowXP(Japanese) + * iswctypes of MacOSX calls isctypes. no i18n. + * For example, iswprint of Windows does not accept a macron of + * Japanese "a-ru" of R as a letter. + * Therefore Japanese "Buraian.Ripuri-" of "Brian Ripley" is + * shown of hex-string.:-) + * We define alternatives to be used if + * defined(Win32) || defined(__APPLE_CC__) || defined(_AIX) + */ +extern wctype_t Ri18n_wctype(const char *); +extern int Ri18n_iswctype(wint_t, wctype_t); + +#ifndef IN_RLOCALE_C +/* We want to avoid these redefinitions in rlocale.c itself */ +#undef iswupper +#undef iswlower +#undef iswalpha +#undef iswdigit +#undef iswxdigit +#undef iswspace +#undef iswprint +#undef iswgraph +#undef iswblank +#undef iswcntrl +#undef iswpunct +#undef iswalnum +#undef wctype +#undef iswctype + +#define iswupper(__x) Ri18n_iswctype(__x, Ri18n_wctype("upper")) +#define iswlower(__x) Ri18n_iswctype(__x, Ri18n_wctype("lower")) +#define iswalpha(__x) Ri18n_iswctype(__x, Ri18n_wctype("alpha")) +#define iswdigit(__x) Ri18n_iswctype(__x, Ri18n_wctype("digit")) +#define iswxdigit(__x) Ri18n_iswctype(__x, Ri18n_wctype("xdigit")) +#define iswspace(__x) Ri18n_iswctype(__x, Ri18n_wctype("space")) +#define iswprint(__x) Ri18n_iswctype(__x, Ri18n_wctype("print")) +#define iswgraph(__x) Ri18n_iswctype(__x, Ri18n_wctype("graph")) +#define iswblank(__x) Ri18n_iswctype(__x, Ri18n_wctype("blank")) +#define iswcntrl(__x) Ri18n_iswctype(__x, Ri18n_wctype("cntrl")) +#define iswpunct(__x) Ri18n_iswctype(__x, Ri18n_wctype("punct")) +#define iswalnum(__x) Ri18n_iswctype(__x, Ri18n_wctype("alnum")) +#define wctype(__x) Ri18n_wctype(__x) +#define iswctype(__x,__y) Ri18n_iswctype(__x,__y) +#endif + +#ifdef __cplusplus +} +#endif +#endif /* R_LOCALE_H */ diff --git a/var_lib_genenet_bnw/localscore/stats_package.h b/var_lib_genenet_bnw/localscore/stats_package.h new file mode 100644 index 00000000..3717c482 --- /dev/null +++ b/var_lib_genenet_bnw/localscore/stats_package.h @@ -0,0 +1,71 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 2007 The R Core Team. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +#ifndef R_STATS_PACKAGE_H +#define R_STATS_PACKAGE_H +#include <Rconfig.h> + +#ifdef HAVE_VISIBILITY_ATTRIBUTE +# define attribute_hidden __attribute__ ((visibility ("hidden"))) +#else +# define attribute_hidden +#endif + +enum AlgType {NREG = 1, OPT = 2}; + /* 0-based indices into v */ +enum VPos {F = 9, F0 = 12, FDIF = 10, G = 27, HC = 70}; + /* 0-based indices into iv */ +enum IVPos {AI = 90, AM = 94, ALGSAV = 50, COVMAT = 25, + COVPRT = 13, COVREQ = 14, DRADPR = 100, + DTYPE = 15, IERR = 74, INITH = 24, INITS = 24, + IPIVOT = 75, IVNEED = 2, LASTIV = 42, LASTV = 44, + LMAT = 41, MXFCAL = 16, MXITER = 17, NEXTV = 46, + NFCALL = 5, NFCOV = 51, NFGCAL = 6, NGCOV = 52, + NITER = 30, NVDFLT = 49, NVSAVE = 8, OUTLEV = 18, + PARPRT = 19, PARSAV = 48, PERM = 57, PRUNIT = 20, + QRTYP = 79, RDREQ = 56, RMAT = 77, SOLPRT = 21, + STATPR = 22, TOOBIG = 1, VNEED = 3, VSAVE = 59, + X0PRT = 23}; + +void attribute_hidden +S_Rf_divset(int alg, int iv[], int liv, int lv, double v[]); + +void attribute_hidden +S_nlsb_iterate(double b[], double d[], double dr[], int iv[], + int liv, int lv, int n, int nd, int p, + double r[], double rd[], double v[], double x[]); + +void attribute_hidden +S_nlminb_iterate(double b[], double d[], double fx, double g[], + double h[], int iv[], int liv, int lv, int n, + double v[], double x[]); + +static R_INLINE int S_v_length(int alg, int n) +{ + return (alg - 1) ? (105 + (n * (2 * n + 20))) : + (130 + (n * (n + 27))/2); +} + +static R_INLINE int S_iv_length(int alg, int n) +{ + return (alg - 1) ? (82 + 4 * n) : (78 + 3 * n); +} + +#endif /* R_STATS_PACKAGE_H */ + diff --git a/var_lib_genenet_bnw/localscore/stats_stubs.h b/var_lib_genenet_bnw/localscore/stats_stubs.h new file mode 100644 index 00000000..bc46821e --- /dev/null +++ b/var_lib_genenet_bnw/localscore/stats_stubs.h @@ -0,0 +1,68 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 2007 The R Core Team. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + */ + +#include <Rconfig.h> +#include <Rinternals.h> +#include <R_ext/Rdynload.h> + +#ifdef HAVE_VISIBILITY_ATTRIBUTE +# define attribute_hidden __attribute__ ((visibility ("hidden"))) +#else +# define attribute_hidden +#endif + +void attribute_hidden +S_Rf_divset(int alg, int iv[], int liv, int lv, double v[]) +{ + static void(*fun)(int,int[],int,int,double[]) = NULL; + if (fun == NULL) + fun = (void(*)(int,int[],int,int,double[])) + R_GetCCallable("stats", "Rf_divset"); + fun(alg, iv, liv, lv, v); +} + +void attribute_hidden +S_nlminb_iterate(double b[], double d[], double fx, double g[], double h[], + int iv[], int liv, int lv, int n, double v[], double x[]) +{ + static void(*fun)(double[],double[],double,double[],double[], + int[],int,int,int,double[],double[]) = NULL; + if (fun == NULL) + fun = (void(*)(double[],double[],double,double[],double[], + int[],int,int,int,double[],double[])) + R_GetCCallable("stats", "nlminb_iterate"); + fun(b, d, fx, g, h, iv, liv, lv, n, v, x); +} + +void attribute_hidden +S_nlsb_iterate(double b[], double d[], double dr[], int iv[], int liv, + int lv, int n, int nd, int p, double r[], double rd[], + double v[], double x[]) +{ + static void(*fun)(double[],double[],double[],int[],int,int, + int,int,int,double[],double[],double[], + double[]) = NULL; + if (fun == NULL) + fun = (void(*)(double[],double[],double[],int[],int, + int, int,int,int,double[], + double[],double[],double[])) + R_GetCCallable("stats", "nlsb_iterate"); + fun(b, d, dr, iv, liv, lv, n, nd, p, r, rd, v, x); +} + diff --git a/var_lib_genenet_bnw/network_score b/var_lib_genenet_bnw/network_score new file mode 100644 index 00000000..bd062e72 --- /dev/null +++ b/var_lib_genenet_bnw/network_score Binary files differdiff --git a/var_lib_genenet_bnw/print_structure/structure.c b/var_lib_genenet_bnw/print_structure/structure.c new file mode 100644 index 00000000..0b490324 --- /dev/null +++ b/var_lib_genenet_bnw/print_structure/structure.c @@ -0,0 +1,86 @@ +#include<stdio.h> +#include<stdlib.h> +#include<string.h> +#include<math.h> + +struct st{ +char *name; +double *data; +}*st_tab; + +main(int argc,char *argv[]) +{ +FILE *fp1,*fp2,*fp3; +char line[2500]; +int i,j,rd; +double d,row; +double thr=atof(argv[5]); + +fp1=fopen(argv[2],"r"); +fp2=fopen(argv[3],"w"); + +fp3=fopen(argv[4],"w"); + + +row=0.0; +while(fgets(line,2500,fp1)!=NULL) + row++; + +rd=(int)sqrt(row); + +printf("%d\n",rd); + +fclose(fp1); +fp1=fopen(argv[1],"r"); + +st_tab=(struct st *)malloc(sizeof(struct st)*rd); + +for(i=0;i<rd;i++) +{ + fscanf(fp1,"%s",line); + st_tab[i].name=(char *)malloc(sizeof(char)*(sizeof(line)+1)); + strcpy(st_tab[i].name,line); + st_tab[i].data=(double *)calloc(rd,sizeof(double)); +} + +fclose(fp1); +fp1=fopen(argv[2],"r"); + +for(i=0;i<rd;i++) +{ + for(j=0;j<rd;j++) + { + fscanf(fp1,"%s",line); + fscanf(fp1,"%s",line); + fscanf(fp1,"%s",line); + fscanf(fp1,"%lf",&d); + st_tab[i].data[j]=d; + + } +} + + + +for(i=0;i<rd;i++) +{ + fprintf(fp2,"%s\t",st_tab[i].name); + fprintf(fp3,"%s\t",st_tab[i].name); +} +fprintf(fp2,"\n"); +fprintf(fp3,"\n"); + +for(i=0;i<rd;i++) +{ + for(j=0;j<rd;j++) + { + fprintf(fp2,"%lf\t",st_tab[j].data[i]); + if(st_tab[j].data[i]>thr) + fprintf(fp3,"1\t"); + else + fprintf(fp3,"0\t"); + } + fprintf(fp2,"\n"); + fprintf(fp3,"\n"); +} + +} diff --git a/var_lib_genenet_bnw/run.sh b/var_lib_genenet_bnw/run.sh new file mode 100644 index 00000000..d7389dad --- /dev/null +++ b/var_lib_genenet_bnw/run.sh @@ -0,0 +1,58 @@ +#!/bin/bash +d=`dirname $0` +#Name of the data directory +data=$1 + +DIR="$d/$data/tmp" +DIR_1="$d/$data/tmp/" + +mkdir -p $DIR +#Arguments. User can modify these arguments. + +#Input data file name. +input="$d/$data/input.txt" + +#Input banlist file +ban="$d/$data/banlist.txt" + +#Input whitelist file +white="$d/$data/whitelist.txt" + +#Max parents. We set the number of maximum parents to 4 +maxparent=4 + +#k is the numbeer of structure considered in each step of k-best structure learning algorithm. We set the value of k=100 +k=100 + +#Model averaging threshold. We set the model averaging threshold to 0.5 +THR=0.5 + + +echo "Dataset with number of variables:" +head -1 $input|wc -w +echo "Dataset with number of samples:" +wc -l $input|cut -d' ' -f1 +echo "Parameters are: max parent = $maxparent, k= $k and model averaging threshold = $THR" + +start_time1=`date +%s` +#execute local score +./network_score $input $ban $white $maxparent $DIR +end_time=`date +%s` +echo "Local score execution time was `expr $end_time - $start_time1` s." + +start_time=`date +%s` +#execute k-best structure learning +sh $d/k-best/src/data2netk_poster.sh $input $DIR $k $maxparent + +end_time=`date +%s` +echo "k-best parent total execution time was `expr $end_time - $start_time` s." + +start_time=`date +%s` +#execute print structure +./structure $input $DIR/postProbEachEdge.txt $d/$data/model_averaging_probabilities.txt $d/$data/model_structure.txt $THR + +end_time1=`date +%s` +echo "Preparing structure output file from model averaging matrix. Execution time was `expr $end_time1 - $start_time` s." +echo "Total execution time was `expr $end_time1 - $start_time1` s." +rm -r $DIR_1* +rmdir $DIR diff --git a/var_lib_genenet_bnw/structure b/var_lib_genenet_bnw/structure new file mode 100644 index 00000000..b8680416 --- /dev/null +++ b/var_lib_genenet_bnw/structure Binary files differ |
