view release on metacpan or  search on metacpan

lib/Astro/Catalog/IO/JCMT.pm  view on Meta::CPAN

Supported options (with defaults) are:

=over 4

=item incheader

Add a comment header to the start of the catalog.  [default: true]

=item removeduplicates

Check for duplicates.  Remove if the coordinates match.  Add suffix
to disambiguate otherwise.  [default: true]

=back

=cut

sub _write_catalog {
    my $class = shift;
    my $cat = shift;

    # Default options
    my %defaults = (
        incheader => 1,
        removeduplicates => 1,
    );

    my %options = (%defaults, @_);

    # Would make more sense to use the array ref here
    my @sources = $cat->stars;

    # Counter for unknown targets
    my $unk = 1;

    # Hash for storing target information
    # so that we can search for duplicates
    my %targets;

    # Create hash of all unique target names present
    # after cleaning. We need this so that we can make sure
    # a generated name derived from a duplication (with target mismatch)
    # does not generate a name that already existed explicitly.
    my %allnames = map {$class->clean_target_name($_->coords->name), undef}
        @sources;

    # Loop over each source and extract catalog information
    # Make sure that we remove unique entries
    # BUT THAT WE RETAIN THE ORDER OF THE SOURCES IN THE CATALOG
    # Hence an array for the information
    my @processed;
    for my $star (@sources) {
        # Extract the coordinate object
        my $src = $star->coords;

        # Get the name but do not deal with undef yet
        # in case the type is not valid
        my $name = $src->name;

        # Somewhere to store the extracted information
        my %srcdata;

        # Store the name (stripped of spaces) and
        # treat srcdata{name} as the primary name from here on
        $srcdata{name} = $class->clean_target_name($name);

        # Store a comment
        $srcdata{comment} = $star->comment;

        # prepopulate the default velocity settings
        $srcdata{rv}    = 'n/a';
        $srcdata{vdefn}  = 'RADIO';
        $srcdata{vframe} = 'LSR';

        # Default proper motion and parallax.
        $srcdata{'pm1'} = 'n/a';
        $srcdata{'pm2'} = 'n/a';
        $srcdata{'parallax'} = 'n/a';

        # Get the miscellaneous data.
        my $misc = $star->misc;
        if (defined $misc) {
            $srcdata{vrange} = ((defined $misc->{'velocity_range'})
                ? sprintf("%s", $misc->{'velocity_range'})
                : "n/a");
            $srcdata{flux850} = ((defined $misc->{'flux850'})
                ?  sprintf("%s", $misc->{'flux850'})
                : "n/a" );
        }
        else {
            $srcdata{vrange} = "n/a";
            $srcdata{flux850} = "n/a";
        }

        foreach (qw/_jcmt_com_before _jcmt_com_after/) {
            $srcdata{$_} = $misc->{$_} if exists $misc->{$_};
        }

        # Get the type of source
        my $type = $src->type;
        if ($type eq 'RADEC') {
            $srcdata{system} = "RJ";

            # Need to get the space separated RA/Dec and the sign
            $srcdata{long} = $src->ra2000(format => 'array');
            $srcdata{lat} = $src->dec2000(format => 'array');

            # Get the velocity information
            my $rv = $src->rv;
            if ($rv) {
                $srcdata{rv}    = $rv;
                $srcdata{vdefn}  = $src->vdefn;
                $srcdata{vframe} = $src->vframe;

                # JCMT compatibility
                $srcdata{vframe} = "LSR" if $srcdata{vframe} eq 'LSRK';

            }

            my $parallax = $src->parallax;
            my @pm = $src->pm;
            if (scalar @pm) {
                if (not $parallax) {
                    my $errname = (defined $srcdata{name} ? $srcdata{name} : "<undefined>");
                    warnings::warnif "Proper motion for target $errname specified without parallax";
                }
                $srcdata{'pm1'} = $pm[0] * 1000.0;
                $srcdata{'pm2'} = $pm[1] * 1000.0;
            }
            if ($parallax) {
                $srcdata{'parallax'} = $parallax * 1000.0;
            }

        }
        elsif ($type eq 'PLANET') {
            # Planets are not supported in catalog form. Skip them
            next;

        }
        elsif ($type eq 'FIXED') {
            $srcdata{system} = "AZ";

            $srcdata{long} = $src->az(format => 'array');
            $srcdata{lat} = $src->el(format => 'array');

            # Need to remove + sign from long/AZ since we are not expecting
            # it in RA/DEC. This is probably a bug in Astro::Coords
            shift(@{$srcdata{long}}) if $srcdata{long}->[0] eq '+';

        }
        else {
            my $errname = (defined $srcdata{name} ? $srcdata{name} : "<undefined>");
            warnings::warnif "Coordinate of type $type for target $errname not supported in JCMT catalog files\n";
            next;
        }

        # Generate a name if not defined
        if (!defined $srcdata{name}) {
            $srcdata{name} = "UNKNOWN$unk";
            $unk++;
        }

        # See if we already have this source and that it is really the
        # same source Note that we do not see whether this name is the
        # same as one of the derived names. Eg if CRL618 is in the
        # pointing catalog 3 times with identical coords and we add a
        # new CRL618 with different coords then we trigger 3 warning
        # messages rather than 1 because we do not check that CRL618_2 is
        # the same as CRL618_1

        # Note that velocity specification is included in this comparison

        if ($options{'removeduplicates'} and exists $targets{$srcdata{name}}) {
            my $previous = $targets{$srcdata{name}};

            # Create stringified form of previous coordinate with same name
            # and current coordinate
            my $prevcoords = join(" ",@{$previous->{long}},@{$previous->{lat}},
                    $previous->{rv}, $previous->{vdefn}, $previous->{vframe});
            my $curcoords = join(" ",@{$srcdata{long}},@{$srcdata{lat}},
                    $srcdata{rv}, $srcdata{vdefn}, $srcdata{vframe});

            if ($prevcoords eq $curcoords) {
                # This is the same target so we can ignore it
            }
            else {
                # Make up a new name. Use a counter for this.
                my $oldname = $srcdata{name};

                # loop for 100 times
                my $count;
                while (1) {
                    # protection loop
                    $count++;

                    # Try to construct a new name based on the counter.
                    my $suffix = "_$count";

                    # Abort if we have gone round too many times
                    if ($count > 100) {
                        $srcdata{name} = substr($oldname, 0, int(MAX_SRC_LENGTH / 2)) .
                            int(rand(10000) + 1000);
                        warn "Uncontrollable looping (or unfeasibly large number of duplicate sources with different coordinates). Panicked and generated random source name of $srcdata{name}\n";
                        last;
                    }

                    # Assume the old name will do fine
                    my $root = $oldname;

                    # Do not want to truncate the _XX off the end later on
                    if (length($oldname) > MAX_SRC_LENGTH - length($suffix)) {
                        # This may well be confusing but we have no choice. Since
                        # _XX is unique the only time we will get a name clash by
                        # simply chopping the string is if we have a duplicate
                        # that is too long along with a target name that includes
                        # _XX amd matches the truncated source name!
                        $root = substr($oldname, 0, (MAX_SRC_LENGTH - length($suffix)) );
                    }

                    # Form the new name
                    my $newname = $root . $suffix;

                    # check to see if this name is in the existing target list
                    unless ((exists $allnames{$newname}) or (exists $targets{$newname})) {
                        # Store it in the targets array and exit loop
                        $srcdata{name} = $newname;
                        last;
                    }
                }

                # different target
                warn "Found target with the same name [$oldname] but with different coordinates, renaming it to $srcdata{name}\n";

                $targets{$srcdata{name}} = \%srcdata;

                # Store it in the array
                push @processed, \%srcdata;
            }
        }
        else {
            # Store in hash for easy lookup for duplicates
            $targets{$srcdata{name}} = \%srcdata;

            # Store it in the array
            push @processed, \%srcdata;
        }
    }

    # Output array for new catalog lines
    my @lines;

    if ($options{'incheader'}) {
        # Write a header
        push @lines, "*\n";
        push @lines, "* Catalog written automatically by class ". __PACKAGE__ ."\n";
        push @lines, "* on date " . gmtime . "UT\n";
        push @lines, "* Origin of catalog: ". $cat->origin ."\n";
        push @lines, "*\n";
    }

    # Now need to go through the targets and write them to disk
    for my $src (@processed) {
        if (exists $src->{'_jcmt_com_before'}) {
            push @lines, '*' . $_ foreach @{$src->{'_jcmt_com_before'}};
        }

        my $name    = $src->{name};
        my $long    = $src->{long};
        my $lat     = $src->{lat};
        my $system  = $src->{system};
        my $comment = $src->{comment};
        my $rv      = $src->{rv};
        my $vdefn   = $src->{vdefn};
        my $vframe  = $src->{vframe};
        my $vrange  = $src->{vrange};
        my $flux850 = $src->{flux850};
        my $pm1     = $src->{'pm1'};
        my $pm2     = $src->{'pm2'};
        my $px      = $src->{'parallax'};

        $comment = '' unless defined $comment;

        # Velocity can not easily be done with a sprintf since it can be either
        # a string or a 2 column number
        $rv  = _format_value($rv, '%6.1f', '  n/a   ', 1);

        # Similarly format proper motion and parallax.
        $pm1 = _format_value($pm1, '%8.3f', '   n/a    ', 1);
        $pm2 = _format_value($pm2, '%8.3f', '   n/a    ', 1);
        $px  = _format_value($px,  '%8.4f', '  n/a   ', 0);

        # Name must be limited to MAX_SRC_LENGTH characters
        # [this should be taken care of by clean_target_name but
        # if we have appended _X....
        $name = substr($name,0,MAX_SRC_LENGTH);

        # Maybe shift flux by 1 space to align decimal point in
        # 1dp values with that in 2dp values and also middle of n/a.
        $flux850 .= ' ' if $flux850 =~ /(?:\.\d|n\/a)$/ and 5 > length $flux850;

        push @lines, sprintf(
            "%-" . MAX_SRC_LENGTH .  "s %02d %02d %06.3f %1s %02d %02d %05.2f %2s  %s %5s  %5s  %-4s %s %s %s %s %s\n",
            $name, @$long, @$lat, $system,
            $rv, $flux850, $vrange, $vframe, $vdefn,
            $pm1, $pm2, $px,