Algorithm-Cluster
view release on metacpan or search on metacpan
perl/Cluster.xs view on Meta::CPAN
dSP;
I32 count;
bool isEnabled;
SV * mysv;
ENTER ;
SAVETMPS;
PUSHMARK(SP) ;
XPUSHs(sv_2mortal(newSVpv("Algorithm::Cluster",18)));
PUTBACK ;
count = perl_call_pv("warnings::enabled", G_SCALAR) ;
if (count != 1) croak("No arguments returned from call_pv()\n") ;
mysv = POPs;
isEnabled = (bool) SvTRUE(mysv);
PUTBACK ;
FREETMPS ;
LEAVE ;
return isEnabled;
}
/* -------------------------------------------------
* Create a row of doubles, initialized to a value
*/
static double*
perl/Cluster.xs view on Meta::CPAN
CODE:
node = malloc(sizeof(Node));
RETVAL = newSViv(0);
obj = newSVrv(RETVAL, class);
node->left = left;
node->right = right;
node->distance = distance;
sv_setiv(obj, PTR2IV(node));
SvREADONLY_on(obj);
OUTPUT:
RETVAL
int
left (obj)
SV* obj
CODE:
RETVAL = (INT2PTR(Node*,SvIV(SvRV(obj))))->left;
OUTPUT:
RETVAL
int
right (obj)
SV* obj
CODE:
RETVAL = (INT2PTR(Node*,SvIV(SvRV(obj))))->right;
OUTPUT:
RETVAL
double
distance (obj)
SV* obj
CODE:
RETVAL = (INT2PTR(Node*,SvIV(SvRV(obj))))->distance;
OUTPUT:
RETVAL
void
set_left (obj, left)
SV* obj
int left
PREINIT:
Node* node;
CODE:
if (!sv_isa(obj, "Algorithm::Cluster::Node")) {
perl/Cluster.xs view on Meta::CPAN
free(tree->nodes);
free(tree);
croak("the array of nodes passed to Algorithm::Cluster::Tree::new does not represent a valid tree\n");
}
RETVAL = newSViv(0);
obj = newSVrv(RETVAL, class);
sv_setiv(obj, PTR2IV(tree));
SvREADONLY_on(obj);
OUTPUT:
RETVAL
int
length (obj)
SV* obj
CODE:
RETVAL = (INT2PTR(Tree*,SvIV(SvRV(obj))))->n;
OUTPUT:
RETVAL
SV *
get (obj, index)
SV* obj
int index
PREINIT:
Tree* tree;
Node* node;
perl/Cluster.xs view on Meta::CPAN
scalar = newSVrv(RETVAL, "Algorithm::Cluster::Node");
node = malloc(sizeof(Node));
if (!node) {
croak("Memory allocation failure in Algorithm::Cluster::Tree::get\n");
}
node->left = tree->nodes[index].left;
node->right = tree->nodes[index].right;
node->distance = tree->nodes[index].distance;
sv_setiv(scalar, PTR2IV(node));
SvREADONLY_on(scalar);
OUTPUT:
RETVAL
void
scale(obj)
SV* obj
PREINIT:
int i;
int n;
Tree* tree;
Node* nodes;
perl/Cluster.xs view on Meta::CPAN
MODULE = Algorithm::Cluster PACKAGE = Algorithm::Cluster
PROTOTYPES: ENABLE
SV *
_version()
CODE:
RETVAL = newSVpv( CLUSTERVERSION , 0);
OUTPUT:
RETVAL
SV *
_mean(input)
SV * input;
PREINIT:
int array_length;
perl/Cluster.xs view on Meta::CPAN
}
data = malloc_row_perl2c_dbl (aTHX_ input, &array_length);
if (data) {
RETVAL = newSVnv( mean(array_length, data) );
free(data);
} else {
croak("memory allocation failure in _mean\n");
}
OUTPUT:
RETVAL
SV *
_median(input)
SV * input;
PREINIT:
int array_length;
double * data; /* one-dimensional array of doubles */
perl/Cluster.xs view on Meta::CPAN
}
data = malloc_row_perl2c_dbl (aTHX_ input, &array_length);
if (data) {
RETVAL = newSVnv( median(array_length, data) );
free(data);
} else {
croak("memory allocation failure in _median\n");
}
OUTPUT:
RETVAL
SV *
_treecluster(nrows,ncols,data_ref,mask_ref,weight_ref,transpose,dist,method)
int nrows;
int ncols;
SV * data_ref;
SV * mask_ref;
SV * weight_ref;
perl/Cluster.xs view on Meta::CPAN
*/
if (matrix) {
free_matrix_int(mask, nrows);
free_matrix_dbl(matrix, nrows);
free(weight);
} else {
free_ragged_matrix_dbl(distancematrix, nelements);
}
/* Finished _treecluster() */
OUTPUT:
RETVAL
void
_kcluster(nclusters,nrows,ncols,data_ref,mask_ref,weight_ref,transpose,npass,method,dist,initialid_ref)
int nclusters;
int nrows;
int ncols;
SV * data_ref;
SV * mask_ref;
perl/Cluster.xs view on Meta::CPAN
* Free what we've malloc'ed
*/
free_matrix_int(mask, nrows);
free_matrix_dbl(matrix, nrows);
free(weight);
free(cluster1);
free(cluster2);
/* Finished _clusterdistance() */
OUTPUT:
RETVAL
void
_clustercentroids(nclusters,nrows,ncols,data_ref,mask_ref,clusterid_ref,transpose,method)
int nclusters;
int nrows;
int ncols;
SV * data_ref;
perl/Record.pm view on Meta::CPAN
my ($extension, $keyword);
if ($transpose==0) {
$extension = 'gtr';
$keyword = 'GENE';
}
else {
$extension = 'atr';
$keyword = 'ARRY';
}
my $nnodes = $tree->length;
open OUTPUT, ">$jobname.$extension" or die 'Error: Unable to open output file';
my @nodeID = ('') x $nnodes;
my @nodedist;
my $i;
for ($i = 0; $i < $nnodes; $i++) {
my $node = $tree->get($i);
push (@nodedist, $node->distance);
}
for (my $nodeindex = 0; $nodeindex < $nnodes; $nodeindex++) {
my $min1 = $tree->get($nodeindex)->left;
my $min2 = $tree->get($nodeindex)->right;
$nodeID[$nodeindex] = "NODE" . ($nodeindex+1) . "X";
print OUTPUT $nodeID[$nodeindex];
print OUTPUT "\t";
if ($min1 < 0) {
my $index1 = -$min1-1;
print OUTPUT $nodeID[$index1];
print OUTPUT "\t";
if ($nodedist[$index1] > $nodedist[$nodeindex]) {
$nodedist[$nodeindex] = $nodedist[$index1];
}
}
else {
print OUTPUT $keyword . $min1 . "X\t";
}
if ($min2 < 0) {
my $index2 = -$min2-1;
print OUTPUT $nodeID[$index2];
print OUTPUT "\t";
if ($nodedist[$index2] > $nodedist[$nodeindex]) {
$nodedist[$nodeindex] = $nodedist[$index2];
}
}
else {
print OUTPUT $keyword . $min2 . "X\t";
}
print OUTPUT 1.0-$nodedist[$nodeindex];
print OUTPUT "\n";
}
close(OUTPUT);
# Now set up order based on the tree structure
return $tree->sort(\@order);
}
sub _savekmeans {
my ($self, %param) = @_;
my $filename = $param{filename};
my @clusterids = @{$param{clusterids}};
my @order = @{$param{order}};
my $transpose = $param{transpose};
my $label;
my @names;
if ($transpose == 0) {
$label = $self->{uniqid};
@names = @{$self->{geneid}};
}
else {
$label = 'ARRAY';
@names = @{$self->{expid}};
}
open OUTPUT, ">$filename" or die 'Error: Unable to open output file';
print OUTPUT "$label\tGROUP\n";
my $n = scalar @names;
my @result = sort { $order[$a] <=> $order[$b] } (0..$n-1);
my @sortedindex;
my $cluster = 0;
while (scalar @sortedindex < $n) {
foreach (@result) {
my $j = $_;
my $cid = $clusterids[$j];
if ($clusterids[$j]==$cluster) {
print OUTPUT $names[$j] . "\t$cluster\n";
push (@sortedindex, $j);
}
}
$cluster++;
}
close(OUTPUT);
return @sortedindex;
}
sub _savedata {
my ($self, %param) = @_;
my $jobname = $param{jobname};
my $gid = $param{gid};
my $aid = $param{aid};
my @geneindex = @{$param{geneindex}};
my @expindex = @{$param{expindex}};
my @genename;
if (defined $self->{genename}) {
@genename = @{$self->{genename}};
}
else {
@genename = @{$self->{geneid}};
}
my $ngenes = scalar @{$self->{geneid}};
my $nexps = scalar @{$self->{expid}};
open OUTPUT, ">$jobname.cdt" or die 'Error: Unable to open output file';
my @mask;
if (defined $self->{mask}) {
@mask = @{$self->{mask}};
}
else {
@mask = ([(1) x $nexps]) x $ngenes;
# Each row contains identical shallow copies of the same vector;
# modifying one row would affect the other rows.
}
my @gweight;
perl/Record.pm view on Meta::CPAN
@gweight = (1) x $ngenes;
}
my @eweight;
if (defined $self->{eweight}) {
@eweight = @{$self->{eweight}};
}
else {
@eweight = (1) x $nexps;
}
if ($gid) {
print OUTPUT "GID\t";
}
print OUTPUT $self->{uniqid};
print OUTPUT "\tNAME\tGWEIGHT";
# Now add headers for data columns
foreach (@expindex) {
print OUTPUT "\t" . $self->{expid}[$_];
}
print OUTPUT "\n";
if ($aid) {
print OUTPUT "AID";
if ($gid) {
print OUTPUT "\t";
}
print OUTPUT "\t\t";
foreach (@expindex) {
print OUTPUT "\tARRY" . $_ . 'X';
}
print OUTPUT "\n";
}
print OUTPUT "EWEIGHT";
if ($gid) {
print OUTPUT "\t";
}
print OUTPUT "\t\t";
foreach (@expindex) {
print OUTPUT "\t" . $eweight[$_];
}
print OUTPUT "\n";
foreach (@geneindex) {
my $i = $_;
if ($gid) {
print OUTPUT "GENE" . $i . "X\t";
}
print OUTPUT $self->{geneid}[$i] . "\t" . $genename[$i] . "\t" . $gweight[$i];
foreach (@expindex) {
my $j = $_;
print OUTPUT "\t";
if ($mask[$i][$j]) {
print OUTPUT $self->{data}[$i][$j];
}
}
print OUTPUT "\n";
}
close(OUTPUT);
}
1;
( run in 0.428 second using v1.01-cache-2.11-cpan-4e96b696675 )