~ubuntu-branches/ubuntu/lucid/bioperl/lucid

$self->throw("Going to overwrite a taxon which is $node that is already stored here, set the ignore overwrite flag (parameter 2) to true to ignore this in the future");

140

}

141

142

$self->{'_desc'}->{$node->internal_id} = $node; # is this safely unique - we've tested before at any rate??

143

144

$self->invalidate_height();

145

146

return scalar keys %{$self->{'_desc'}};

147

}

148

149

150

=head2 each_Descendent

151

152

Title : each_Descendent($sortby)

153

Usage : my @taxa = $taxon->each_Descendent;

154

Function: all the descendents for this taxon (but not their descendents

155

i.e. not a recursive fetchall)

156

Returns : Array of Bio::Taxonomy::Taxon objects

157

Args : $sortby [optional] "height", "creation" or coderef to be used

158

to sort the order of children taxa.

159

160

161

=cut

162

163

sub each_Descendent{

164

my ($self, $sortby) = @_;

165

166

# order can be based on branch length (and sub branchlength)

167

168

$sortby ||= 'height';

169

170

if (ref $sortby eq 'CODE') {

171

return sort $sortby values %{$self->{'_desc'}};

172

} else {

173

if ($sortby eq 'height') {

174

return map { $_->[0] }

175

sort { $a->[1] <=> $b->[1] ||

176

$a->[2] <=> $b->[2] }

177

map { [$_, $_->height, $_->internal_id ] }

178

values %{$self->{'_desc'}};

179

} else {

180

return map { $_->[0] }

181

sort { $a->[1] <=> $b->[1] }

182

map { [$_, $_->height ] }

183

values %{$self->{'_desc'}};

184

}

185

}

186

}

187

188

=head2 remove_Descendent

189

190

Title : remove_Descendent

191

Usage : $taxon->remove_Descedent($taxon_foo);

192

Function: Removes a specific taxon from being a Descendent of this taxon

193

Returns : nothing

194

Args : An array of Bio::taxonomy::Taxon objects which have be previously

195

passed to the add_Descendent call of this object.

196

197

=cut

198

199

sub remove_Descendent{

200

my ($self,@nodes) = @_;

201

foreach my $n ( @nodes ) {

202

if( $self->{'_desc'}->{$n->internal_id} ) {

203

$n->{'_ancestor'} = undef;

204

$self->{'_desc'}->{$n->internal_id}->{'_ancestor'} = undef;

205

delete $self->{'_desc'}->{$n->internal_id};

206

207

} else {

208

$self->debug(sprintf("no taxon %s (%s) listed as a descendent in this taxon %s (%s)\n",$n->id, $n,$self->id,$self));

209

$self->debug("Descendents are " . join(',', keys %{$self->{'_desc'}})."\n");

210

}

211

}

212

213

}

214

215

216

=head2 remove_all_Descendents

217

218

Title : remove_all_Descendents

219

Usage : $taxon->remove_All_Descendents()

220

Function: Cleanup the taxon's reference to descendents and reset

221

their ancestor pointers to undef, if you don't have a reference

222

to these objects after this call they will be cleanedup - so

223

a get_nodes from the Tree object would be a safe thing to do first

224

Returns : nothing

225

Args : none

226

227

228

=cut

229

230

sub remove_all_Descendents{

231

my ($self) = @_;

232

# this won't cleanup the taxa themselves if you also have

233

# a copy/pointer of them (I think)...

234

while( my ($node,$val) = each %{ $self->{'_desc'} } ) {

235

$val->{'_ancestor'} = undef;

236

}

237

$self->{'_desc'} = {};

238

239

}

240

241

=head2 get_Descendents

242

243

Title : get_Descendents

244

Usage : my @taxa = $taxon->get_Descendents;

245

Function: Recursively fetch all the taxa and their descendents

246

*NOTE* This is different from each_Descendent

247

Returns : Array or Bio::Taxonomy::Taxon objects

248

Args : none

249

250

=cut

251

252

# implemented in the interface

253

254

=head2 ancestor

255

256

Title : ancestor

257

Usage : $taxon->ancestor($newval)

258

Function: Set the Ancestor

259

Returns : value of ancestor

260

Args : newvalue (optional)

261

262

=cut

263

264

sub ancestor {

265

my ($self, $value) = @_;

266

if (defined $value) {

267

$self->{'_ancestor'} = $value;

268

}

269

return $self->{'_ancestor'};

270

}

271

272

=head2 branch_length

273

274

Title : branch_length

275

Usage : $obj->branch_length($newval)

276

Function:

277

Example :

278

Returns : value of branch_length

279

Args : newvalue (optional)

280

281

282

=cut

283

284

sub branch_length {

285

my ($self,$value) = @_;

286

if( defined $value) {

287

$self->{'branch_length'} = $value;

288

}

289

return $self->{'branch_length'};

290

}

291

292

=head2 description

293

294

Title : description

295

Usage : $obj->description($newval)

296

Function:

297

Example :

298

Returns : value of description

299

Args : newvalue (optional)

300

301

302

=cut

303

304

sub description {

305

my ($self,$value) = @_;

306

if( defined $value ) {

307

$self->{'_desc'} = $value;

308

}

309

return $self->{'_desc'};

310

}

311

312

313

=head2 rank

314

315

Title : rank

316

Usage : $obj->rank($newval)

317

Function: Set the taxonomic rank

318

Example :

319

Returns : taxonomic rank of taxon

320

Args : newvalue (optional)

321

322

323

=cut

324

325

sub rank {

326

my ($self,$value) = @_;

327

if (defined $value) {

328

my $ranks=join("|",@RANK);

329

if ($value=~/$ranks/) {

330

$self->{'_rank'} = $value;

331

} else {

332

$self->throw("Attempted to set unknown taxonomic rank: $value.\n");

333

}

334

}

335

return $self->{'_rank'};

336

}

337

338

339

=head2 taxon

340

341

Title : taxon

342

Usage : $obj->taxon($newtaxon)

343

Function: Set the name of the taxon

344

Example :

345

Returns : name of taxon

346

Args : newtaxon (optional)

347

348

349

=cut

350

351

# because internal taxa have names too...

352

sub taxon {

353

my ($self,$value) = @_;

354

if( defined $value ) {

355

$self->{'_taxon'} = $value;

356

}

357

return $self->{'_taxon'};

358

}

359

360

361

=head2 id

362

363

Title : id

364

Usage : $obj->id($newval)

365

Function:

366

Example :

367

Returns : value of id

368

Args : newvalue (optional)

369

370

371

=cut

372

373

sub id {

374

my ($self,$value) = @_;

375

if( defined $value ) {

376

$self->{'_id'} = $value;

377

}

378

return $self->{'_id'};

379

}

380

381

382

383

sub DESTROY {

384

my ($self) = @_;

385

# try to insure that everything is cleaned up

386

$self->SUPER::DESTROY();

387

if( defined $self->{'_desc'} &&

388

ref($self->{'_desc'}) =~ /ARRAY/i ) {

389

while( my ($nodeid,$node) = each %{ $self->{'_desc'} } ) {

390

$node->{'_ancestor'} = undef; # ensure no circular references

391

$node->DESTROY();

392

$node = undef;

393

}

394

$self->{'_desc'} = {};

395

}

396

}

397

398

=head2 internal_id

399

400

Title : internal_id

401

Usage : my $internalid = $taxon->internal_id

402

Function: Returns the internal unique id for this taxon

403

(a monotonically increasing number for this in-memory implementation

404

but could be a database determined unique id in other

405

implementations)

406

Returns : unique id

407

Args : none

408

409

=cut

410

411

sub internal_id {

412

return $_[0]->_creation_id;

413

}

414

415

416

=head2 _creation_id

417

418

Title : _creation_id

419

Usage : $obj->_creation_id($newval)

420

Function: a private method signifying the internal creation order

421

Returns : value of _creation_id

422

Args : newvalue (optional)

423

424

425

=cut

426

427

sub _creation_id {

428

my ($self,$value) = @_;

429

if( defined $value) {

430

$self->{'_creation_id'} = $value;

431

}

432

return $self->{'_creation_id'} || 0;

433

}

434

435

436

# The following methods are implemented by NodeI decorated interface

437

438

=head2 is_Leaf

439

440

Title : is_Leaf

441

Usage : if( $node->is_Leaf )

442

Function: Get Leaf status

443

Returns : boolean

444

Args : none

445

446

=cut

447

448

sub is_Leaf {

449

my ($self) = @_;

450

my $rc = 0;

451

$rc = 1 if( ! defined $self->{'_desc'} ||

452

keys %{$self->{'_desc'}} == 0);

453

return $rc;

454

}

455

456

=head2 to_string

457

458

Title : to_string

459

Usage : my $str = $taxon->to_string()

460

Function: For debugging, provide a taxon as a string

461

Returns : string

462

Args : none

463

464

=cut

465

466

=head2 height

467

468

Title : height

469

Usage : my $len = $taxon->height

470

Function: Returns the height of the tree starting at this

471

taxon. Height is the maximum branchlength.

472

Returns : The longest length (weighting branches with branch_length) to a leaf

473

Args : none

474

475

=cut

476

477

sub height {

478

my ($self) = @_;

479

480

return $self->{'_height'} if( defined $self->{'_height'} );

481

482

if( $self->is_Leaf ) {

483

if( !defined $self->branch_length ) {

484

$self->debug(sprintf("Trying to calculate height of a taxon when a taxon (%s) has an undefined branch_length",$self->id || '?' ));

485

return 0;

486

}

487

return $self->branch_length;

488

}

489

my $max = 0;

490

foreach my $subnode ( $self->each_Descendent ) {

491

my $s = $subnode->height;

492

if( $s > $max ) { $max = $s; }

493

}

494

return ($self->{'_height'} = $max + ($self->branch_length || 1));

495

}

496

497

498

=head2 invalidate_height

499

500

Title : invalidate_height

501

Usage : private helper method

502

Function: Invalidate our cached value of the taxon's height in the tree

503

Returns : nothing

504

Args : none

505

506

=cut

507

508

509

sub invalidate_height {

510

my ($self) = @_;

511

512

$self->{'_height'} = undef;

513

if( $self->ancestor ) {

514

$self->ancestor->invalidate_height;

515

}

516

}

517

518

=head2 classify

519

520

Title : classify

521

Usage : @obj->classify()

522

Function: a method to return the classification of a species

523

Returns : name of taxon and ancestor's taxon recursively

524

Args : boolean to specify whether we want all taxa not just ranked

525

levels

526

527

528

=cut

529

530

sub classify {

531

my ($self,$allnodes) = @_;

532

533

my @classification=($self->taxon);

534

my $node=$self;

535

536

while (defined $node->ancestor) {

537

push @classification, $node->ancestor->taxon if $allnodes==1;

538

$node=$node->ancestor;

539

}

540

541

return (@classification);

542

}

543

544

545

=head2 has_rank

546

547

Title : has_rank

548

Usage : $obj->has_rank($rank)

549

Function: a method to query ancestors' rank

550

Returns : boolean

551

Args : $rank

552

553

554

=cut

555

556

sub has_rank {

557

my ($self,$rank) = @_;

558

559

return $self if $self->rank eq $rank;

560

561

while (defined $self->ancestor) {

562

return $self if $self->ancestor->rank eq $rank;

563

$self=$self->ancestor;

564

}

565

566

return undef;

567

}

568

569

570

=head2 has_taxon

571

572

Title : has_taxon

573

Usage : $obj->has_taxon($taxon)

574

Function: a method to query ancestors' taxa

575

Returns : boolean

576

Args : Bio::Taxonomy::Taxon object

577

578

579

=cut

580

581

sub has_taxon {

582

my ($self,$taxon) = @_;

583

584

return $self if

585

((defined $self->id && $self->id == $taxon->id) ||

586

($self->taxon eq $taxon->taxon && $self->rank eq $taxon->rank));

587

588

while (defined $self->ancestor) {

589

return $self if

590

((defined $self->id && $self->id == $taxon->id) ||

591

($self->taxon eq $taxon->taxon && $self->rank eq $taxon->rank) &&

592

($self->taxon ne 'no rank'));

593

$self=$self->ancestor;

594

}

595

596

return undef;

597

}

598

599

600

=head2 distance_to_root

601

602

Title : distance_to_root

603

Usage : $obj->distance_to_root

604

Function: a method to query ancestors' taxa

605

Returns : number of links to root

606

Args :

607

608

609

=cut

610

611

sub distance_to_root {

612

my ($self,$taxon) = @_;

613

614

my $count=0;

615

616

while (defined $self->ancestor) {

617

$count++;

618

$self=$self->ancestor;

619

}

620

621

return $count;

622

}

623

624

625

=head2 recent_common_ancestor

626

627

Title : recent_common_ancestor

628

Usage : $obj->recent_common_ancestor($taxon)

629

Function: a method to query find common ancestors

630

Returns : Bio::Taxonomy::Taxon of query or undef if no ancestor of rank

631

Args : Bio::Taxonomy::Taxon

632

633

634

=cut

635

636

sub recent_common_ancestor {

637

my ($self,$node) = @_;

638

639

while (defined $node->ancestor) {

640

my $common=$self->has_taxon($node);

641

return $common if defined $common;

642

$node=$node->ancestor;

643

}

644

645

return undef;

646

}

647

648

=head2 species

649

650

Title : species

651

Usage : $obj=$taxon->species;

652

Function: Returns a Bio::Species object reflecting the taxon's tree position

653

Returns : a Bio::Species object

654

Args : none

655

656

=cut

657

658

sub species {

659

my ($self) = @_;

660

my $species;

661

662

if ($self->has_rank('subspecies') && $self->ancestor->rank eq 'species') {

663

$species = Bio::Species->new(-classification => $self->ancestor->classify);

664

$species->genus($self->ancestor->ancestor->taxon);

665

$species->species($self->ancestor->taxon);

666

$species->sub_species($self->taxon);

667

} elsif ($self->has_rank('species')) {

668

$species = Bio::Species->new(-classification => $self->classify);

669

$species->genus($self->ancestor->taxon);

670

$species->species($self->taxon);

671

} else {

672

$self->throw("Trying to create a species from a taxonomic entity without species rank. Use classify instead of species.\n");

673

}

674

return $species;

675

}

676

677

Older »