Astro::Correlate::Method::RITMatch - Correlation using RIT Match.

  ( $corrcat1, $corrcat2 ) = Astro::Correlate::Match::RITMatch->correlate( catalog1 => $cat1, catalog2 => $cat2 );

package Astro::Correlate::Method::RITMatch;

use 5.006;
use strict;
use warnings;
use warnings::register;

use Carp;
use File::Temp qw/ tempfile /;
use File::SearchPath qw/ searchpath /;
use Storable qw/ dclone /;

our $VERSION = '0.02';
our $DEBUG = 0;

sub correlate {
  my $class = shift;

# Grab the arguments, and make sure they're defined and are
# Astro::Catalog objects (the catalogues, at least).
  my %args = @_;
  my $cat1 = dclone( $args{'catalog1'} );
  my $cat2 = dclone( $args{'catalog2'} );

  if( ! defined( $cat1 ) ||
      ! UNIVERSAL::isa( $cat1, "Astro::Catalog" ) ) {
    croak "catalog1 parameter to Astro::Correlate::Method::RITMatch->correlate "
        . "method must be defined and must be an Astro::Catalog object"
        ;
  }
  if( ! defined( $cat2 ) ||
      ! UNIVERSAL::isa( $cat2, "Astro::Catalog" ) ) {
    croak "catalog2 parameter to Astro::Correlate::Method::RITMatch->correlate "
        . "method must be defined and must be an Astro::Catalog object"
        ;
  }

# Retrieve the scaling factor.
  my $scale = _determine_scaling_factor( $cat1, $cat2 );

  my $keeptemps = defined( $args{'keeptemps'} ) ? $args{'keeptemps'} : 0;
  my $temp;
  if( exists( $args{'temp'} ) && defined( $args{'temp'} ) ) {
    $temp = $args{'temp'};
  } else {
    $temp = tempdir ( UNLINK => ! $keeptemps );
  }
  my $verbose = defined( $args{'verbose'} ) ? $args{'verbose'} : 0;
  my $cat1magtype = defined( $args{'cat1magtype'} ) ? $args{'cat1magtype'} : 'mag';
  my $cat2magtype = defined( $args{'cat2magtype'} ) ? $args{'cat2magtype'} : 'mag';

# Try to find the match binary in the directory pointed to by the
# MATCH_DIR environment variable. If that doesn't work, check the
# user's $PATH. If that doesn't work, croak.
  my $match_bin;
  if( defined( $ENV{'MATCH_DIR'} ) &&
      -d $ENV{'MATCH_DIR'} &&
      -e File::Spec->catfile( $ENV{'MATCH_DIR'}, "match" ) ) {
    $match_bin = File::Spec->catfile( $ENV{'MATCH_DIR'}, "match" );
  } else {
    $match_bin = searchpath( "match" );
    if( ! defined( $match_bin ) ) {
      croak "Could not find match binary. Ensure MATCH_DIR environment variable is set";
    }
  }

  print "match binary is in $match_bin\n" if $DEBUG;

# Get two temporary filenames for catalog files.
  ( undef, my $catfile1 ) = tempfile( DIR => $temp );
  ( undef, my $catfile2 ) = tempfile( DIR => $temp );

# Match is sensitive to the scaling of the problem, requiring that the
# error is of order 1, and certainly less than 50. To meet this requirement
# scale the X and Y coordinates to have a range of 200 (XXX make this some
# multiple of the image scale).
  my $cat1stars = $cat1->stars;
  foreach my $cat1star ( @$cat1stars ) {
    $cat1star->x( $cat1star->x() / $scale );
    $cat1star->y( $cat1star->y() / $scale );
  }
  my $cat2stars = $cat2->stars;
  foreach my $cat2star ( @$cat2stars ) {
    $cat2star->x( $cat2star->x() / $scale );
    $cat2star->y( $cat2star->y() / $scale );
  }

# Write the two input catalogues for match.
  print "Writing catalog 1 to $catfile1 using $cat1magtype magnitude.\n" if $DEBUG;
  $cat1->write_catalog( Format => 'RITMatch',
                        File => $catfile1,
                        mag_type => $cat1magtype );
  print "Input catalog 1 written to $catfile1.\n" if $DEBUG;
  print "Writing catalog 2 to $catfile2 using $cat2magtype magnitude.\n" if $DEBUG;
  $cat2->write_catalog( Format => 'RITMatch',
                        File => $catfile2,
                        mag_type => $cat2magtype );
  print "Input catalog 2 written to $catfile2.\n" if $DEBUG;

# Create two hash lookup tables. Key will be the "match-ed" ID, which
# is the original ID with all non-numeric characters removed, and
# value will be the original ID. This will allow us to match up stars
# after the correlation has happened.
  my %lookup_cat1;
  my %lookup_cat2;

  $cat1stars = $cat1->stars;
  my $newid = 1;
  foreach my $cat1star ( @$cat1stars ) {
    $lookup_cat1{$newid} = $cat1star->id;
    $newid++;
  }

  $cat2stars = $cat2->stars;
  $newid = 1;
  foreach my $cat2star ( @$cat2stars ) {
    $lookup_cat2{$newid} = $cat2star->id;
    $newid++;
  }

# Create a base filename for the output catalogues. Put it in the
# temporary directory previously set up.
  my $outfilebase = File::Spec->catfile( $temp, "outfile$$" );

# Set up the parameter list for match.
  my @matchargs = ( "$catfile1",
                    "1",
                    "2",
                    "3",
                    "$catfile2",
                    "1",
                    "2",
                    "3",
                    "outfile=$outfilebase",
                    "nobj=30",
                    "id1=0",
                    "id2=0",
                  );

# Run match.
  my $pid = open my $stdout, "$match_bin " . ( join ' ', @matchargs ) . "|" or croak "Could not execute match: $!";
  close $stdout;

# Read in the first output catalogue of matching objects. The old ID
# will be in the comment field.
  my $tempcat = new Astro::Catalog( Format => 'RITMatch',
                                    File => $outfilebase . ".mtA" );

# Loop through the stars, making a new catalogue with new stars using
# a combination of the new ID and the old information.
  my $corrcat1 = new Astro::Catalog();
  my @stars = $tempcat->stars;
  $newid = 1;
  foreach my $star ( @stars ) {

# The old ID is found in the first column of the star's comment.
# However, this old ID has been "match-ed", i.e. all non-numeric
# characters have been stripped from it. Use the lookup table we
# generated earlier to find the proper old ID.
    $star->id =~ /^(\w+)/;
    my $oldmatchid = $1;
    my $oldid = $lookup_cat1{$oldmatchid};

# Get the star's information.
    my $oldstar = $cat1->popstarbyid( $oldid );
    $oldstar = $oldstar->[0];
    next if ! defined( $oldstar );

# Set the ID to the new star's ID.
    $oldstar->id( $newid );

# Restore X and Y.
    $oldstar->x( $oldstar->x() * $scale );
    $oldstar->y( $oldstar->y() * $scale );

# Set the comment denoting the old ID.
    $oldstar->comment( "Old ID: " . $oldid );

# And push this star onto the output catalogue.
    $corrcat1->pushstar( $oldstar );

    $newid++;
  }

# And do the same for the second catalogue.
  $tempcat = new Astro::Catalog( Format => 'RITMatch',
                                 File => $outfilebase . ".mtB" );

  my $corrcat2 = new Astro::Catalog();
  @stars = $tempcat->stars;
  $newid = 1;
  foreach my $star ( @stars ) {

# The old ID is found in the first column of the star's comment.
# However, this old ID has been "match-ed", i.e. all non-numeric
# characters have been stripped from it. Use the lookup table we
# generated earlier to find the proper old ID.
    $star->id =~ /^(\w+)/;
    my $oldmatchid = $1;
    my $oldid = $lookup_cat2{$oldmatchid};

# Get the star's information.
    my $oldstar = $cat2->popstarbyid( $oldid );
    $oldstar = $oldstar->[0];
    next if ! defined( $oldstar );

# Set the ID to the new star's ID.
    $oldstar->id( $newid );

# Restore X and Y.
    $oldstar->x( $oldstar->x() * $scale );
    $oldstar->y( $oldstar->y() * $scale );

# Set the comment denoting the old ID.
    $oldstar->comment( "Old ID: " . $oldid );

# And push this star onto the output catalogue.
    $corrcat2->pushstar( $oldstar );

    $newid++;
  }

# Delete the temporary files if we're not in debug mode.
  if( ! $DEBUG ) {
    unlink $catfile1;
    unlink $catfile2;
    unlink $outfilebase . ".mtA";
    unlink $outfilebase . ".mtB";
    unlink $outfilebase . ".unA";
    unlink $outfilebase . ".unB";
  }

  return ( $corrcat1, $corrcat2 );
}

sub _determine_scaling_factor {
  my $cat1 = shift;
  my $cat2 = shift;

  my $max = 0;
  my $max_pos = 500;

  foreach my $cat ( ( $cat1, $cat2 ) ) {
    foreach my $item ( $cat->stars ) {
      if( $item->x > $max ) {
        $max = $item->x;
      }
      if( $item->y > $max ) {
        $max = $item->y;
      }
    }
  }

  my $scale = ( $max > $max_pos ? $max / $max_pos : 1 );

  return $scale;

}

1;