view release on metacpan or  search on metacpan

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

    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

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

                        # _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";