File Coverage

lib/ClarID/Tools/Command/code.pm

Criterion	Covered	Total	%
statement	527	547	96.3
branch	174	308	56.4
condition	73	157	46.5
subroutine	41	41	100.0
pod	1	2	50.0
total	816	1055	77.3

package ClarID::Tools::Command::code;
use strict;
use warnings;
use feature qw(say);
use ClarID::Tools;
use ClarID::Tools::Util qw(load_yaml_file load_json_file);
use Moo;
use MooX::Options
  auto_help        => 1,
  version          => $ClarID::Tools::VERSION,
  usage            => 'pod',
  config_from_hash => {};
use Text::CSV_XS;
use Carp                   qw(croak);
use Types::Standard        qw(Str Int Enum HashRef Undef ArrayRef);
use IO::Uncompress::Gunzip qw(gunzip $GunzipError);
use IO::Compress::Gzip     qw(gzip   $GzipError);
use JSON::XS               qw(decode_json);
use File::Spec::Functions  qw(catdir catfile);

# Tell App::Cmd this is a command
use App::Cmd::Setup -command;
use namespace::autoclean;

# Set development mode
use constant DEVEL_MODE => 0;

# CLI options
# NB: Invalid parameter values (e.g., --format=foo) trigger App::Cmd usage/help
# This hides the detailed Types::Standard error
# Fix by overriding usage_error/options_usage
#
# Example (Types::Standard):
# perl -Ilib -MClarID::Tools::Command::code -we \
# 'ClarID::Tools::Command::code->new(format=>"stube", action=>"encode", entity=>"biosample")'
#
# Value "stube" did not pass type constraint "Enum["human","stub"]" (in $args->{"format"}) at -e line 1
#    "Enum["human","stub"]" requires that the value is equal to "human" or "stub"
option entity => (
    is     => 'ro',
    format => 's',
    isa    => Enum [qw/biosample subject biospecimen individual/],
    coerce => sub {
        return 'biosample' if $_[0] eq 'biospecimen';
        return 'subject'   if $_[0] eq 'individual';
        return $_[0];
    },
    doc =>
'biosample | subject (accepts synonyms: biospecimen -> biosample; individual -> subject)',
    required => 1,
);
option format => (
    is       => 'ro',
    format   => 's',
    isa      => Enum [qw/human stub/],
    doc      => 'human | stub',
    required => 1,
);
option action => (
    is       => 'ro',
    format   => 's',
    isa      => Enum [qw/encode decode/],
    doc      => 'encode | decode',
    required => 1,
);
option codebook => (
    is     => 'ro',
    format => 's',
    isa    => HashRef,
    coerce => sub {
        my $cb = load_yaml_file( $_[0] );
        _apply_defaults($cb);
        return $cb;
    },
    doc     => 'path to codebook.yaml',
    default =>
      sub { catfile( $ClarID::Tools::share_dir, 'clarid-codebook.yaml' ) },
    required => 1,
);
option infile => (
    is     => 'ro',
    format => 's',
    isa    => Undef | Str,
    doc    => 'bulk input CSV/TSV',
);
option outfile => (
    is     => 'ro',
    format => 's',
    isa    => Undef | Str,
    doc    => 'bulk output file',
);
option sep => (
    is      => 'ro',
    format  => 's',
    isa     => Str,
    default => sub { ',' },
    doc     => 'separator',
);
option icd10_map => (
    is      => 'ro',
    format  => 's',
    isa     => Str,
    default => sub { catfile( $ClarID::Tools::share_dir, 'icd10.json' ) },
    doc     => 'path to ICD-10 map JSON',
);
option with_condition_name => (
    is      => 'ro',
    is_flag => 1,
    doc     => 'append human-readable condition_name on decode',
);
option subject_id_base62_width => (
    is      => 'ro',
    format  => 'i',
    default => sub { 3 },
    doc     => 'number of Base-62 characters to use for subject ID stubs',
);
option subject_id_pad_length => (
    is      => 'ro',
    format  => 'i',
    default => sub { 5 },
    doc     =>
      'decimal padding width for subject IDs in biosample/subject human format',
);
option clar_id => (
    is     => 'ro',
    format => 's',
    isa    => Undef | Str,
    doc    => 'ID to decode (use --clar_id or --stub_id)',
    short  => 'stub_id',
);

# Always load the ICD-10 order map at startup (JSON::XS parses ~70K entries in ~100 ms on modern hardware), simplifying stub logic.
# This one-time cost (~0.1 s, ~10 MB RAM) is negligible compared to the complexity of conditional or lazy loading.
option icd10_order => (
    is      => 'ro',
    format  => 's',
    isa     => HashRef,
    coerce  => \&load_json_file,
    default => sub { catfile( $ClarID::Tools::share_dir, 'icd10_order.json' ) },
    doc     => 'path to icd10_order.json',
);

has icd10_by_order => (
    is      => 'ro',
    isa     => ArrayRef,
    lazy    => 1,
    builder => '_build_icd10_by_order',
);

option max_conditions => (
    is      => 'ro',
    format  => 'i',
    isa     => Int,
    default => sub { 10 },
    doc     => 'maximum number of ICD-10 codes allowed',
);

# biosample fields
option project =>
  ( is => 'ro', format => 's', isa => Undef | Str, doc => 'project key' );
option species =>
  ( is => 'ro', format => 's', isa => Undef | Str, doc => 'species key' );
option tissue =>
  ( is => 'ro', format => 's', isa => Undef | Str, doc => 'tissue key' );
option sample_type => (
    is     => 'ro',
    format => 's',
    isa    => Undef | Str,
    doc    => 'sample_type key'
);
option assay =>
  ( is => 'ro', format => 's', isa => Undef | Str, doc => 'assay key' );
option timepoint =>
  ( is => 'ro', format => 's', isa => Undef | Str, doc => 'timepoint' );
option duration => (
    is     => 'ro',
    format => 's',
    isa    => Undef | Str,
    doc    => 'duration: P or P0N (Not Available)'
);
option batch =>
  ( is => 'ro', format => 's', isa => Undef | Int, doc => 'batch' );
option replicate => (
    is     => 'ro',
    format => 'i',
    isa    => Undef | Int,
    doc    => 'replicate number'
);

# subject fields
option study =>
  ( is => 'ro', format => 's', isa => Undef | Str, doc => 'study' );
option type => ( is => 'ro', format => 's', isa => Undef | Str, doc => 'type' );
option sex  => ( is => 'ro', format => 's', isa => Undef | Str, doc => 'sex' );
option age_group =>
  ( is => 'ro', format => 's', isa => Undef | Str, doc => 'age_group' );

# Biosample + subject
option subject_id =>
  ( is => 'ro', format => 'i', isa => Undef | Int, doc => 'subject_id' );
option condition => (
    is     => 'ro',
    format => 's',
    isa    => Undef | Str,
    doc    => 'comma-separated ICD-10 codes (e.g. C22.0,C18.1)'
);

# declare once, reuse everywhere:
my %FIELDS = (
    biosample => {
        encode => [
            qw(
              project species subject_id tissue sample_type assay
              condition timepoint duration batch replicate
            )
        ],
        decode => [
            qw(
              project species subject_id tissue sample_type assay
              condition timepoint duration batch replicate
            )
        ],
    },
    subject => {
        encode => [
            qw(
              study subject_id type condition sex age_group
            )
        ],
        decode => [
            qw(
              study subject_id type condition sex age_group
            )
        ],
    },
);

sub _encode_fields {
    my $self = shift;
    my $e    = $self->entity;
    Carp::croak "Unknown entity '$e'" unless exists $FIELDS{$e};
    return @{ $FIELDS{$e}{encode} };
}

sub _decode_fields {
    my $self = shift;
    my $e    = $self->entity;
    Carp::croak "Unknown entity '$e'" unless exists $FIELDS{$e};
    return @{ $FIELDS{$e}{decode} };
}

# Validate required options
sub BUILD {
    my $self = shift;

    # If we're in bulk mode, skip ALL of the single-record checks,
    # including the CLI --condition parsing.
    return if defined $self->infile;

    # Only from here on is single-record mode…

    # 1) Ensure --with-condition-name only on decode
    if ( $self->with_condition_name && $self->action ne 'decode' ) {
        croak "--with-condition-name only makes sense when --action decode";
    }

    # 2) Single-record encode: parse & validate the CLI --condition
    if ( $self->action eq 'encode' ) {

        # split into individual codes (profiled on Aug-09-25)
        my @conds = split /\s*,\s*/, ( $self->condition // '' );
        croak "--condition must not be empty" unless @conds;

        # enforce max
        if ( @conds > $self->max_conditions ) {
            croak sprintf
              "You passed %d conditions but max is %d",
              scalar(@conds), $self->max_conditions;
        }

        # pull regex from your codebook
        my $pat_cfg =
          $self->codebook->{entities}{ $self->entity }{condition_pattern}
          or croak "No condition_pattern defined in your codebook";
        my $re = $pat_cfg->{regex}
          or croak "condition_pattern has no regex";

        # validate each
        for my $c (@conds) {
            croak "Invalid condition '$c'"
              unless $c =~ /^$re$/;
        }

        # stash for the encoder
        $self->{_conds} = \@conds;

        # 3) Now enforce the usual “required field” checks
        for my $field ( $self->_encode_fields ) {
            next if $field eq 'batch'     && !defined $self->batch;
            next if $field eq 'replicate' && !defined $self->replicate;
            croak "--$field is required for single-record encode"
              unless defined $self->$field;
        }
    }
    elsif ( $self->action eq 'decode' ) {

        # 4) Single-record decode needs a clar_id
        croak "--clar_id is required for decode"
          unless defined $self->clar_id;
    }
}

# lazy load
sub _build_icd10_by_order {
    my $self = shift;

    # force-load the order hash if not done yet
    my $ord_hash = $self->icd10_order;
    my @by;
    $by[ $ord_hash->{$_} ] = $_ for keys %$ord_hash;
    return \@by;
}

# Main dispatch
sub execute {
    my $self = shift;

    # lazy load ICD-10 map if requested
    my $code2name;
    if ( $self->action eq 'decode' && $self->with_condition_name ) {
        croak "ICD-10 map not found at '" . $self->icd10_map . "'"
          unless -e $self->icd10_map;
        open my $jh, '<', $self->icd10_map or croak $!;
        local $/;
        my $jtxt = <$jh>;
        close $jh;
        $code2name = decode_json($jtxt);
    }

    # bulk vs single-record
    my ( $in_fh, $out_fh );
    if ( defined( my $infile = $self->infile ) ) {

        # Input handle (auto‐gunzip for .gz)
        if ( $infile =~ /\.gz$/ ) {
            $in_fh = IO::Uncompress::Gunzip->new($infile)
              or croak "gunzip failed on '$infile': $GunzipError";
        }
        else {
            open my $fh_in, '<', $infile
              or croak "Could not open '$infile': $!";
            $in_fh = $fh_in;
        }

        # Output handle (auto‐gzip for .gz, else file or STDOUT)
        if ( defined $self->outfile ) {
            if ( $self->outfile =~ /\.gz$/ ) {
                $out_fh = IO::Compress::Gzip->new( $self->outfile )
                  or croak "gzip failed on '$self->outfile': $GzipError";
            }
            else {
                open my $fh_out, '>', $self->outfile
                  or croak "Could not open '$self->outfile' for writing: $!";
                $out_fh = $fh_out;
            }
        }
        else {
            $out_fh = *STDOUT;
        }

        # Delegate to bulk processor
        return $self->_run_bulk( $in_fh, $self->sep, $out_fh, $code2name );
    }

    # single-record mode — unwrap either top-level or entities-wrapped codebook
    my $full = $self->codebook;

    # if the YAML has an "entities:" wrapper, drill into it; otherwise assume old style
    my $root =
      exists $full->{entities}
      ? $full->{entities}
      : $full;
    my $cb = $root->{ $self->entity }
      or croak "No codebook for '" . $self->entity . "' in your YAML";
    if ( $self->action eq 'encode' ) {
        my @vals = map { $self->$_ } $self->_encode_fields;
        my $meth = sprintf '_encode_%s_%s', $self->format, $self->entity;
        say $self->$meth( $cb, @vals );
    }
    else {
        my $meth = sprintf '_decode_%s_%s', $self->format, $self->entity;
        my $res  = $self->$meth( $cb, $self->clar_id );

        # Print each field in order
        say "$_: $res->{$_}" for $self->_decode_fields;

        # Optionally append human-readable condition_name
        if ( $self->with_condition_name ) {

            # split whatever separator you're using in $res->{condition}
            my @keys = split /[+;]/, $res->{condition};

            # normalize to dot‐free lookup key and fetch each name
            my @names = map {
                ( my $clean = $_ ) =~ s/\W//g;
                $code2name->{$clean} // ''
            } @keys;

            # join multiple names with semicolons
            say "condition_name: " . join( ';', @names );
        }
    }
}

# Bulk processing for single or multiple records
sub _run_bulk {
    my ( $self, $in_fh, $sep, $out_fh, $code2name ) = @_;
    $sep ||= ',';

    # set up CSV parser
    my $csv = Text::CSV_XS->new( { sep_char => $sep } );

    # read header row and set column names
    my $hdr = $csv->getline($in_fh)
      or croak "Failed to read header";
    $csv->column_names(@$hdr);

    # unwrap entity wrapper in the codebook for bulk mode
    my $full = $self->codebook;
    my $root = exists $full->{entities} ? $full->{entities} : $full;
    my $cb   = $root->{ $self->entity }
      or croak "No codebook for '" . $self->entity . "'";

    # write output header
    if ( $self->action eq 'encode' ) {
        my $label = $self->format eq 'stub' ? 'stub_id' : 'clar_id';
        say $out_fh join( $sep, ( @$hdr, $label ) );
    }
    else {
        my @cols = ( @$hdr, $self->_decode_fields );
        push @cols, 'condition_name' if $self->with_condition_name;
        say $out_fh join( $sep, @cols );
    }

    # process each row
    while ( my $row = $csv->getline_hr($in_fh) ) {

        if ( $self->action eq 'encode' ) {

            # ——— per-row multi‐condition support (CSV uses ';') ———
            my @conds = split /\s*;\s*/, $row->{condition} // '';
            croak "Missing or empty condition in row" unless @conds;
            if ( @conds > $self->max_conditions ) {
                croak sprintf
                  "You passed %d conditions but max is %d",
                  scalar(@conds), $self->max_conditions;
            }

            # validate each against the codebook regex
            my $pat_cfg = $cb->{condition_pattern}
              or croak "No condition_pattern in codebook";
            my $re = $pat_cfg->{regex}
              or croak "condition_pattern has no regex";
            for my $c (@conds) {
                croak "Invalid condition '$c'"
                  unless $c =~ /^$re$/;
            }

            # stash for the encoder
            $self->{_conds} = \@conds;

            my @args = map { $row->{$_} } $self->_encode_fields;
            my $meth = sprintf '_encode_%s_%s', $self->format, $self->entity;
            my $out  = $self->$meth( $cb, @args );
            say $out_fh join( $sep, ( map { $row->{$_} // '' } @$hdr ), $out );
        }
        else {
            # enforce column based on --format
            my ( $meth, $id_col );
            if ( $self->format eq 'human' ) {
                $meth   = sprintf '_decode_human_%s', $self->entity;
                $id_col = 'clar_id';
            }
            else {    # format eq 'stub'
                $meth   = sprintf '_decode_stub_%s', $self->entity;
                $id_col = 'stub_id';
            }

            croak "Missing $id_col in input row"
              unless defined $row->{$id_col};

            my $res = $self->$meth( $cb, $row->{$id_col} );

            my @out = map { $res->{$_} // '' } $self->_decode_fields;
            if ( $self->with_condition_name && $code2name ) {
                my @codes = split /[+;]/, $res->{condition};
                my @names = map {
                    ( my $c = $_ ) =~ s/\W//g;
                    $code2name->{$c} // ''
                } @codes;
                push @out, join( ';', @names );
            }

            say $out_fh join( $sep, ( map { $row->{$_} // '' } @$hdr ), @out );
        }
    }

    return;
}

sub _validate_field {
    my ( $fmap, $f, $v ) = @_;
    croak "Invalid $f '$v'" unless defined $v && exists $fmap->{$v};
}

# Cache compiled regex + placeholder counts per pattern config
sub _prep_pattern {
    my ( $pcfg, $mode ) = @_;
    $pcfg->{_re} ||= qr/^(?:$pcfg->{regex})$/;

    my $fmt =
      $mode eq 'human'
      ? ( $pcfg->{code_format} // '%s' )
      : ( $pcfg->{stub_format} // '%s' );

    my $need_key = $mode eq 'human' ? '_need_human' : '_need_stub';
    $pcfg->{$need_key} //= do {
        ( my $t = $fmt ) =~ s/%%//g;    # ignore literal %%
        scalar( () = $t =~ /%/g )       # count % directives
    };

    return ( $pcfg->{_re}, $fmt, $pcfg->{$need_key} );
}

# Generic parser (grab captures; safe for alternation like P0N)
sub _parse_field {
    my ( $val, $map, $pcfg, $mode, $field ) = @_;

    croak "Missing value for $field" unless defined $val;
    croak "No pattern for $field"    unless $pcfg && $pcfg->{regex};

    my ( $re, $fmt, $need ) = _prep_pattern( $pcfg, $mode );
    croak "Invalid $field '$val'" unless $val =~ $re;

    my @caps = grep { defined } ( $val =~ $re );    # drop undef from alternation
    splice @caps, $need if @caps > $need;           # never pass extra args

    return $need ? sprintf( $fmt, @caps ? @caps : ($val) ) : $fmt;
}

# Static-or-pattern parser (uses codebook map first, then pattern)
sub _parse_from_codebook {
    my ( $val, $map, $pcfg, $mode ) = @_;

    # 1) static map entry (e.g., tokens)
    if ( $map && ref $map eq 'HASH' && exists $map->{$val} ) {
        my $k = $mode eq 'human' ? 'code' : 'stub_code';
        return $map->{$val}{$k} if defined $map->{$val}{$k};
    }

    # 2) require a value
    croak "Missing value for field" unless defined $val;

    # 3) pattern path (captures-aware) or raw fallback
    if ( $pcfg && $pcfg->{regex} ) {
        my ( $re, $fmt, $need ) = _prep_pattern( $pcfg, $mode );
        croak "Invalid value '$val' for field" unless $val =~ $re;

        my @caps = grep { defined } ( $val =~ $re );
        splice @caps, $need if @caps > $need;

        # for stub mode, if no captures, normalize raw by stripping non-word
        if ( !@caps && $need == 1 && $mode eq 'stub' ) {
            ( my $raw = $val ) =~ s/\W//g;
            return sprintf( $fmt, $raw );
        }

        return @caps ? sprintf( $fmt, @caps ) : sprintf( $fmt, $val );
    }

    return $val;
}

#----------------------------------------------------------------
# Human biosample encoder
#----------------------------------------------------------------
# Human biosample encoder
sub _encode_human_biosample {
    my (
        $self, $cb, $pr_raw, $sp, $sid, $ti, $st,
        $as,   $co, $tp,     $du, $ba,  $re
    ) = @_;

    # normalize project key
    my $pr = $pr_raw;
    unless ( exists $cb->{project}{$pr} ) {
        ( my $alt = $pr_raw ) =~ tr/-/_/;
        $pr = $alt if exists $cb->{project}{$alt};
    }
    croak "Invalid project '$pr_raw'" unless exists $cb->{project}{$pr};

    # basic field validation
    _validate_field( $cb->{project},     'project',     $pr );
    _validate_field( $cb->{species},     'species',     $sp );
    _validate_field( $cb->{tissue},      'tissue',      $ti );
    _validate_field( $cb->{sample_type}, 'sample_type', $st );
    _validate_field( $cb->{assay},       'assay',       $as );

    # subject_id
    my $pad = $self->subject_id_pad_length;
    croak "Invalid pad length '$pad'" unless $pad =~ /^\d+$/ && $pad > 0;
    my $max = 10**$pad - 1;
    croak "Bad subject_id '$sid' (0-$max)"
      unless $sid =~ /^\d+$/ && $sid >= 0 && $sid <= $max;

    # ------ multi‐condition support ------
    my @conds = @{ delete $self->{_conds} };    # pull in the validated list
    my @human = map {
        _parse_from_codebook( $_, $cb->{condition}, $cb->{condition_pattern},
            'human' )
    } @conds;
    my $cond_code = join '+', @human;

    # -------------------------------------
    # timepoint (strict codebook lookup)
    _validate_field( $cb->{timepoint}, 'timepoint', $tp );
    my $pt_code = $cb->{timepoint}{$tp}{code};

    # duration (pattern-drivem only)
    my $dur_code =
      _parse_field( $du, undef, $cb->{duration_pattern}, 'human', 'duration' );

    # batch (pattern-driven only)
    my $batch_code =
      defined $ba
      ? _parse_field( $ba, undef, $cb->{batch_pattern}, 'human', 'batch' )
      : ();

    # replicate (pattern-driven only)
    my $rep_code =
      defined $re
      ? _parse_field( $re, undef, $cb->{replicate_pattern}, 'human',
        'replicate' )
      : ();

    # assemble
    my @parts = (
        $cb->{project}{$pr}{code},     $cb->{species}{$sp}{code},
        sprintf( "%0${pad}d", $sid ),  $cb->{tissue}{$ti}{code},
        $cb->{sample_type}{$st}{code}, $cb->{assay}{$as}{code},
        $cond_code,                    $pt_code,
        $dur_code,
    );
    push @parts, $batch_code if defined $batch_code;
    push @parts, $rep_code   if defined $rep_code;

    return join( '-', @parts );
}

# Human biosample decoder
sub _decode_human_biosample {
    my ( $self, $cb, $id ) = @_;
    my @p = split /-/, $id;
    croak "Bad biosample ID" unless @p >= 9;
    my ( $prc, $sc, $sid, $tc, $stc, $ac, $cn, $ptc, $du, @rest ) = @p;

    my ($project) =
      grep { $cb->{project}{$_}{code} eq $prc } keys %{ $cb->{project} };
    croak "Unknown project code '$prc'" unless defined $project;
    my ($species) =
      grep { $cb->{species}{$_}{code} eq $sc } keys %{ $cb->{species} };
    croak "Unknown species code '$sc'" unless defined $species;
    my ($tissue) =
      grep { $cb->{tissue}{$_}{code} eq $tc } keys %{ $cb->{tissue} };
    croak "Unknown tissue code '$tc'" unless defined $tissue;
    my ($stype) = grep { $cb->{sample_type}{$_}{code} eq $stc }
      keys %{ $cb->{sample_type} };
    croak "Unknown sample_type code '$stc'" unless defined $stype;
    my ($assay) = grep { $cb->{assay}{$_}{code} eq $ac } keys %{ $cb->{assay} };
    croak "Unknown assay code '$ac'" unless defined $assay;

    # parse subject_id using dynamic pad length
    my $pad = $self->subject_id_pad_length;
    croak "Invalid pad length '$pad'" unless $pad =~ /^\d+$/ && $pad > 0;
    croak "Bad subject_id in ID '$sid'"
      unless $sid =~ /^\d{$pad}$/;
    my $subject_id = int($sid);

    # Extract batch and replicate (just the integer)
    my ( $batch, $replicate );
    if (@rest) {

        # last element R## -> replicate
        if ( $rest[-1] =~ /^R(\d{2})$/ ) {
            $replicate = int $1;
            pop @rest;
        }

        # now maybe B## -> batch
        if ( @rest && $rest[-1] =~ /^B(\d{2})$/ ) {
            $batch = int $1;
            pop @rest;
        }
    }

    # timepoint decode (strict codebook reverse lookup)
    my ($timepoint) =
      grep { $cb->{timepoint}{$_}{code} eq $ptc } keys %{ $cb->{timepoint} };
    croak "Unknown timepoint code '$ptc'" unless defined $timepoint;

    # condition decode (allow multiple codes separated by '+')
    my @parts = split /\+/, $cn;
    my @norm;
    for my $code (@parts) {

        # if it exists verbatim, use it
        if ( exists $cb->{condition}{$code} ) {
            push @norm, $code;
        }
        else {
            # insert dot after 3rd char if missing
            if ( $code !~ /\./ && length($code) > 3 ) {
                $code = substr( $code, 0, 3 ) . '.' . substr( $code, 3 );
            }
            push @norm, $code;
        }
    }

    # join with semicolons for human readability
    my $condition = join ';', @norm;

    # ensure we don't get warnings when printing
    $batch     = '' unless defined $batch;
    $replicate = '' unless defined $replicate;

    return {
        project     => $project,
        species     => $species,
        subject_id  => $subject_id,
        tissue      => $tissue,
        sample_type => $stype,
        assay       => $assay,
        condition   => $condition,
        timepoint   => $timepoint,
        duration    => $du,
        batch       => $batch,
        replicate   => $replicate,
    };
}

#----------------------------------------------------------------
# Stub biosample encoder
#----------------------------------------------------------------
sub _encode_stub_biosample {
    my ( $self, $cb, $pr, $sp, $sid, $ti, $st, $as, $co, $tp, $du, $ba, $re ) =
      @_;

    # 1) static validations
    _validate_field( $cb->{project},     'project',     $pr );
    _validate_field( $cb->{species},     'species',     $sp );
    _validate_field( $cb->{tissue},      'tissue',      $ti );
    _validate_field( $cb->{sample_type}, 'sample_type', $st );
    _validate_field( $cb->{assay},       'assay',       $as );

    # 2) subject_id -> stub
    my $w = $self->subject_id_base62_width;
    croak "Invalid stub width '$w'" unless $w =~ /^\d+$/ && $w > 0;
    croak "Bad subject_id '$sid' (0–" . ( 62**$w - 1 ) . ")"
      unless defined $sid && $sid =~ /^\d+$/ && $sid <= 62**$w - 1;
    my $sid_stub = $self->_subject_id_to_stub( $sid, $w );

    # 3) pull in previously-parsed conditions (bulk) or split the raw string
    my $conds_aref = delete $self->{_conds};
    my @conds =
        $conds_aref
      ? @$conds_aref
      : split /\s*[+,;]\s*/, ( defined $co ? $co : '' );
    croak "No conditions provided" unless @conds;
    croak sprintf "You passed %d conditions but max is %d",
      scalar(@conds), $self->max_conditions
      if @conds > $self->max_conditions;

    # 4) map each ICD-10 -> 3-char stub
    my @stubs = map {
        ( my $c = $_ ) =~ s/\.//g;    # strip dots
        croak "Unknown ICD-10 '$_'"
          unless exists $self->icd10_order->{$c};
        $self->_subject_id_to_stub( $self->icd10_order->{$c}, 3 )
    } @conds;
    my $cond_stub    = join '', @stubs;
    my $count_prefix = sprintf( "%02d", scalar @stubs );    # << count added

    # 5) timepoint stub (strict codebook lookup)
    _validate_field( $cb->{timepoint}, 'timepoint', $tp );
    my $tp_stub = $cb->{timepoint}{$tp}{stub_code};

    # 6) duration stub (pattern-driven only)
    my $du_stub =
      _parse_field( $du, undef, $cb->{duration_pattern}, 'stub', 'duration' );

    # 7) batch & replicate (optional)
    my $ba_stub =
      defined $ba
      ? _parse_field( $ba, undef, $cb->{batch_pattern}, 'stub', 'batch' )
      : '';
    my $re_stub =
      defined $re
      ? _parse_field( $re, undef, $cb->{replicate_pattern}, 'stub',
        'replicate' )
      : '';

    # 8) assemble and return
    return join '', (
        $cb->{project}{$pr}{stub_code},     $cb->{species}{$sp}{stub_code},
        $sid_stub,                          $cb->{tissue}{$ti}{stub_code},
        $cb->{sample_type}{$st}{stub_code}, $cb->{assay}{$as}{stub_code},
        $cond_stub,                         $count_prefix,                    # << here
        $tp_stub,                           $du_stub,
        $ba_stub,                           $re_stub,
    );
}

# Stub biosample decoder
sub _decode_stub_biosample {
    my ( $self, $cb, $id ) = @_;
    croak "Bad stub ID" unless defined $id && length $id;

    # Use codebook-driven tail peel for replicate & batch
    my $repl_fmt  = $cb->{replicate_pattern}{stub_format} // '%02d';
    my $batch_fmt = $cb->{batch_pattern}{stub_format}     // '%02d';

    # 1) strip off replicate using stub_format (e.g. 'R%02d' or '%02d')
    my $replicate = _strip_tail_using_fmt( \$id, $repl_fmt );

    # 2) strip off batch using stub_format
    my $batch = _strip_tail_using_fmt( \$id, $batch_fmt );

    # Legacy fallback for old (unprefixed) stubs: peel bare 2 digits if still present
    if ( !defined $replicate && $id =~ s/(\d{2})$// ) { $replicate = 0 + $1 }
    if ( !defined $batch     && $id =~ s/(\d{2})$// ) { $batch     = 0 + $1 }

    # 3) strip off duration: allow D/W/M/Y or 0N
    croak "Bad stub ID (duration)" unless $id =~ s/(\d+)([DWMYN])$//;
    my ( $d_num, $d_unit ) = ( $1, $2 );
    croak "Invalid duration unit 'N' with non-zero"
      if $d_unit eq 'N' && $d_num != 0;
    my $duration = 'P' . $d_num . $d_unit;

    # 4) strip off timepoint (variable-length stub_code from codebook)
    my %tp_by =
      map { $cb->{timepoint}{$_}{stub_code} => $_ } keys %{ $cb->{timepoint} };
    my $timepoint;
    for my $stub ( sort { length($b) <=> length($a) } keys %tp_by ) {
        if ( $id =~ s/\Q$stub\E$// ) { $timepoint = $tp_by{$stub}; last }
    }
    croak "Unknown timepoint stub at end of ID" unless defined $timepoint;

    # 4b) peel 2-digit condition COUNT (immediately before timepoint)
    croak "Missing condition count" unless $id =~ s/(\d{2})$//;
    my $cond_count = int $1;
    croak "Invalid condition count '$cond_count'" unless $cond_count > 0;

    # now $id is the head: project + species + sid + tissue + sample_type + assay + COND_SEGMENT
    my $head = $id;

    # 5) project (match longest stub_code at start)
    my %proj_by = map { $cb->{project}{$_}{stub_code} => $_ }
      keys %{ $cb->{project} };
    my ($project);
    for my $stub ( sort { length($b) <=> length($a) } keys %proj_by ) {
        if ( $head =~ s/^\Q$stub\E// ) { $project = $proj_by{$stub}; last }
    }
    croak "Unknown project stub" unless defined $project;

    # 6) species (always 2 chars)
    my $spec_stub = substr( $head, 0, 2 );
    substr( $head, 0, 2 ) = '';
    my %sp_by = map { $cb->{species}{$_}{stub_code} => $_ }
      keys %{ $cb->{species} };
    croak "Unknown species stub '$spec_stub'" unless exists $sp_by{$spec_stub};
    my $species = $sp_by{$spec_stub};

    # 7) subject_id (base-62 width)
    my $w = $self->subject_id_base62_width;
    croak "Bad stub width" unless $w =~ /^\d+$/ && $w > 0;
    my $sid_stub = substr( $head, 0, $w );
    substr( $head, 0, $w ) = '';
    my $subject_id = $self->_stub_to_subject_id($sid_stub);

    # 8) tissue (match longest)
    my %ti_by = map { $cb->{tissue}{$_}{stub_code} => $_ }
      keys %{ $cb->{tissue} };
    my $tissue;
    for my $stub ( sort { length($b) <=> length($a) } keys %ti_by ) {
        if ( $head =~ s/^\Q$stub\E// ) { $tissue = $ti_by{$stub}; last }
    }
    croak "Unknown tissue stub '$head'" unless defined $tissue;

    # 9) sample_type (match longest)
    my %st_by = map { $cb->{sample_type}{$_}{stub_code} => $_ }
      keys %{ $cb->{sample_type} };
    my $stype;
    for my $stub ( sort { length($b) <=> length($a) } keys %st_by ) {
        if ( $head =~ s/^\Q$stub\E// ) { $stype = $st_by{$stub}; last }
    }
    croak "Unknown sample_type stub" unless defined $stype;

    # 10) assay (match longest)
    my %as_by = map { $cb->{assay}{$_}{stub_code} => $_ }
      keys %{ $cb->{assay} };
    my $assay;
    for my $stub ( sort { length($b) <=> length($a) } keys %as_by ) {
        if ( $head =~ s/^\Q$stub\E// ) { $assay = $as_by{$stub}; last }
    }
    croak "Unknown assay stub" unless defined $assay;

    # 11) remaining $head must be exactly cond_count * 3 chars (ICD ordinals stubs)
    croak "Bad condition stub length" unless length($head) % 3 == 0;
    my @c_stubs = $head =~ /(.{3})/g;
    croak "Condition count mismatch (have "
      . scalar(@c_stubs)
      . ", expected $cond_count)"
      unless @c_stubs == $cond_count;

    my @conds = map {
        my $ord = $self->_stub_to_subject_id($_);
        croak "Invalid condition ordinal '$ord'"
          unless $ord >= 1 && $ord < @{ $self->icd10_by_order };
        _format_icd10( $self->icd10_by_order->[$ord] );
    } @c_stubs;

    my $condition = join ';', @conds;

    if (DEVEL_MODE) {
        say "DEBUG biosample cond_count = $cond_count";
        say "DEBUG biosample cond_stubs = [" . join( ',', @c_stubs ) . "]";
    }

    return {
        project     => $project,
        species     => $species,
        subject_id  => $subject_id,
        tissue      => $tissue,
        sample_type => $stype,
        assay       => $assay,
        condition   => $condition,    # ';' joined
        timepoint   => $timepoint,
        duration    => $duration,
        batch       => $batch     // '',
        replicate   => $replicate // '',
    };
}

# Human-mode subject encoder
sub _encode_human_subject {
    my (
        $self, $cb,
        $study,                       # study
        $sid,                         # subject_id
        $ty,                          # type
        $co,                          # raw condition string
        $sx,                          # sex
        $ag                           # age_group
    ) = @_;

    # 1) Validate type, sex & age_group
    _validate_field( $cb->{type},      'type',      $ty );
    _validate_field( $cb->{sex},       'sex',       $sx );
    _validate_field( $cb->{age_group}, 'age_group', $ag );

    # 2) Pad subject_id
    my $pad = $self->subject_id_pad_length;
    croak "Invalid pad length '$pad'"
      unless $pad =~ /^\d+$/ && $pad > 0;
    my $max = 10**$pad - 1;
    croak "Bad subject_id '$sid' (must be 0-$max)"
      unless defined $sid && $sid =~ /^\d+$/ && $sid <= $max;
    $study =~ tr/-/_/;    # normalize study key

    # 3) Split & validate multiple ICD-10 codes
    my @conds = split /\s*[+,;]\s*/, ( defined $co ? $co : '' );
    croak "No conditions provided" unless @conds;
    for my $c (@conds) {
        my $pat_cfg = $cb->{condition_pattern}
          or croak "No condition_pattern in codebook";
        croak "Invalid condition '$c'"
          unless $c =~ /^$pat_cfg->{regex}$/;
    }

    # 4) Re-join with '+' for the final code
    my $cond_code = join '+', @conds;

    # 5) Assemble the ID
    return join( '-',
        $study,
        sprintf( "%0${pad}d", $sid ),
        $cb->{type}{$ty}{code},
        $cond_code,
        $cb->{sex}{$sx}{code},
        $cb->{age_group}{$ag}{code},
    );
}

# Human-mode subject decoder
sub _decode_human_subject {
    my ( $self, $cb, $id ) = @_;

    my @p = split /-/, $id;
    croak "Bad subject ID" unless @p == 6;
    my ( $study, $sid, $type_c, $co, $sex_c, $ag_code ) = @p;

    my ($ag_key) = grep { $cb->{age_group}{$_}{code} eq $ag_code }
      keys %{ $cb->{age_group} };
    croak "Unknown age_group code '$ag_code'" unless defined $ag_key;

    return {
        study      => $study,
        type       => $type_c,
        sex        => $sex_c,
        age_group  => $ag_key,
        condition  => $co,
        subject_id => int($sid),
    };
}

# Stub-mode subject encoder (with 2-digit condition count prefix)
# Stub-mode subject **encoder**, with COUNT just before sex
sub _encode_stub_subject {
    my (
        $self, $cb,
        $study,         # study key
        $subject_id,    # integer
        $type,          # type key
        $condition,     # comma-separated ICD list
        $sex,           # sex key
        $age_group      # age_group key
    ) = @_;

    # study stub
    my $study_stub = $cb->{study}{$study}{stub_code} // $study;

    # validate & get stubs for type/sex/age_group
    croak "Unknown type '$type'" unless exists $cb->{type}{$type};
    croak "Unknown sex '$sex'"   unless exists $cb->{sex}{$sex};
    croak "Unknown age_group '$age_group'"
      unless exists $cb->{age_group}{$age_group};
    my $type_stub      = $cb->{type}{$type}{stub_code};
    my $sex_stub       = $cb->{sex}{$sex}{stub_code};
    my $age_group_stub = $cb->{age_group}{$age_group}{stub_code};

    # subject_id -> base-62
    my $w = $self->subject_id_base62_width;
    croak "Invalid stub width '$w'" unless $w =~ /^\d+$/ && $w > 0;
    my $sid_stub = $self->_subject_id_to_stub( $subject_id, $w );

    # split and encode ICDs
    my @conds = split /\s*,\s*/, $condition;
    croak "No conditions provided" unless @conds;
    croak "Too many conditions" if @conds > 99;
    my @cond_stubs = map {
        ( my $c = $_ ) =~ s/\.//g;
        croak "Unknown ICD-10 '$_'" unless exists $self->icd10_order->{$c};
        $self->_subject_id_to_stub( $self->icd10_order->{$c}, 3 )
    } @conds;

    # build count + conds string
    my $count_prefix = sprintf( "%02d", scalar @cond_stubs );
    my $conds_part   = join "", @cond_stubs;

    # final: STUDY + SID + TYPE + CONDS + COUNT + SEX + AGE
    return join "",
      (
        $study_stub,   $sid_stub, $type_stub, $conds_part,
        $count_prefix, $sex_stub, $age_group_stub,
      );
}

# Stub-mode subject **decoder**, reading backwards with COUNT before sex
sub _decode_stub_subject {
    my ( $self, $cb, $stub ) = @_;

    # 1) sanity on base-62 width
    my $w = $self->subject_id_base62_width;
    croak "Invalid stub length '$w'"
      unless defined $w && $w =~ /^\d+$/ && $w > 0;

    # 2) reverse the entire stub
    my $rev = reverse $stub;

    # 3) pull off age_group (2 chars) + sex (1 char)
    my $rev_age = substr( $rev, 0, 2 );
    my $rev_sex = substr( $rev, 2, 1 );
    my $rest    = substr( $rev, 3 );

    # 4) next two chars are the **reversed** condition count
    croak "Bad condition count in stub" unless length($rest) >= 2;
    my $count_rev = substr( $rest, 0, 2 );

    # restore correct order, parse as integer
    my $cond_count = int reverse $count_rev;
    croak "Invalid condition count '$cond_count'" unless $cond_count > 0;
    $rest = substr( $rest, 2 );

    # 5) peel off exactly cond_count * 3 chars for all condition stubs
    my $conds_len = $cond_count * 3;
    croak "Bad condition stub length"
      unless length($rest) >= $conds_len;
    my $rev_conds_rev = substr( $rest, 0, $conds_len );
    $rest = substr( $rest, $conds_len );

    # 6) next is the type stub (1 char)
    croak "Missing type stub" unless length($rest) >= 1;
    my $rev_type = substr( $rest, 0, 1 );
    $rest = substr( $rest, 1 );

    # 7) then the subject_id stub (width $w)
    croak "Missing subject_id stub" unless length($rest) >= $w;
    my $rev_id_rev = substr( $rest, 0, $w );
    $rest = substr( $rest, $w );

    # 8) and whatever remains is the study stub
    my $rev_study_rev = $rest;

    # 9) DEBUG dumps
    if (DEVEL_MODE) {
        say "DEBUG rev            = '$rev'";
        say "DEBUG rev_age        = '$rev_age'";
        say "DEBUG rev_sex        = '$rev_sex'";
        say "DEBUG count_rev      = '"
          . ( reverse $count_rev )
          . "' -> cond_count=$cond_count";
        say "DEBUG rev_conds_rev  = '$rev_conds_rev'";
        say "DEBUG rev_type       = '$rev_type'";
        say "DEBUG rev_id_rev     = '$rev_id_rev'";
        say "DEBUG rev_study_rev  = '$rev_study_rev'";
    }

    # 10) reverse back simple fields
    my $age_s    = reverse $rev_age;         # stub for age_group
    my $sex_s    = reverse $rev_sex;         # stub for sex
    my $type_s   = reverse $rev_type;        # stub for type
    my $sid_stub = reverse $rev_id_rev;      # base62 subject_id
    my $study    = reverse $rev_study_rev;

    # 11) decode subject_id
    my $subject_id = $self->_stub_to_subject_id($sid_stub);

    # 12) map back type, sex, and age_group via codebook
    my ($type) =
      grep { $cb->{type}{$_}{stub_code} eq $type_s } keys %{ $cb->{type} };
    croak "Unknown type stub '$type_s'" unless defined $type;

    my ($sex_key) =
      grep { $cb->{sex}{$_}{stub_code} eq $sex_s } keys %{ $cb->{sex} };
    croak "Unknown sex stub '$sex_s'" unless defined $sex_key;

    my ($age_group_key) = grep { $cb->{age_group}{$_}{stub_code} eq $age_s }
      keys %{ $cb->{age_group} };
    croak "Unknown age_group stub '$age_s'" unless defined $age_group_key;

    # 13) split condition segment into reversed 3-char chunks
    my @rev_chunks = $rev_conds_rev =~ /(.{3})/g;
    croak "Condition stub parsing mismatch"
      unless @rev_chunks == $cond_count;

    # *** restore original left-to-right order ***
    @rev_chunks = reverse @rev_chunks;

    # 14) reverse each back, then decode ordinal -> ICD-10
    my @conds = map {
        my $stub3 = reverse $_;                            # un-reverse it
        my $ord   = $self->_stub_to_subject_id($stub3);    # base62 -> ordinal
        croak "Invalid condition ordinal '$ord'"
          unless $ord >= 1 && $ord < @{ $self->icd10_by_order };
        _format_icd10( $self->icd10_by_order->[$ord] );
    } @rev_chunks;

    # 15) assemble final hash
    return {
        study      => $study,
        subject_id => $subject_id,
        type       => $type,
        condition  => join( ';', @conds ),
        sex        => $sex_key,
        age_group  => $age_group_key,        # <-- now mapped via codebook
    };
}

# ------------------------------------------------------------------------
# Helper functions for subject_id ↔ stub conversion
#
# _subject_id_to_stub($id, $width):
#   - Converts a non-negative integer $id into a fixed-width base‑62 string.
#   - Pads with '0' on the left to exactly $width characters.
#
# _stub_to_subject_id($stub):
#   - Parses a base‑62 string $stub back into the original integer.
#   - Validates characters against the 0-9, A-Z, a-z alphabet.
#
# These allow you to shrink a 5‑digit decimal ID into 3 base‑62 chars in stub mode,
# and recover the original integer when decoding.
# ------------------------------------------------------------------------

# Base‑62 alphabet
my @BASE62     = ( '0' .. '9', 'A' .. 'Z', 'a' .. 'z' );
my %BASE62_REV = map { $BASE62[$_] => $_ } 0 .. $#BASE62;

# ------------------------------------------------------------------------
# Convert a non‑negative integer into a fixed-width base‑62 stub
#   $id    : integer subject ID (>=0)
#   $width : desired stub length (default 3)
# Returns a $width-char string in [0-9A-Za-z], zero-padded on the left.
# ------------------------------------------------------------------------
sub _subject_id_to_stub {
    my ( $self, $id, $width ) = @_;
    $width ||= 3;    # default stub length

    croak "Bad subject_id '$id'"
      unless defined $id && $id =~ /^\d+$/ && $id >= 0;

    return '0' x $width if $id == 0;    # special‑case zero

    my $s   = '';
    my $num = $id;
    while ( $num > 0 ) {

        # prepend the next base‑62 digit
        $s   = $BASE62[ $num % 62 ] . $s;
        $num = int( $num / 62 );
    }

    # left‑pad with '0' to exactly $width chars
    return substr( ( '0' x $width ) . $s, -$width );
}

# Convert a base‑62 string back to an integer
sub _stub_to_subject_id {
    my ( $self, $stub ) = @_;
    croak "Bad stub '$stub'"
      unless defined $stub && $stub =~ /^[0-9A-Za-z]+$/;
    my $id = 0;
    for my $char ( split //, $stub ) {
        croak "Invalid base62 char '$char'" unless exists $BASE62_REV{$char};
        $id = $id * 62 + $BASE62_REV{$char};
    }
    return $id;
}

# Private helper: if an ICD‑10 code has no dot but is >3 chars,
# stick a dot after the third character.
sub _format_icd10 {
    my ($code) = @_;
    return $code if $code =~ /\./ || length($code) <= 3;
    return substr( $code, 0, 3 ) . '.' . substr( $code, 3 );
}

sub _apply_defaults {
    my ($doc)    = @_;
    my $ents     = $doc->{entities} or return;
    my $defaults = delete $ents->{_defaults} || {};

    for my $entity (qw/biosample subject/) {
        next unless my $cat = $ents->{$entity};
        for my $slot ( grep { ref $cat->{$_} eq 'HASH' } keys %$cat ) {
            my $map = $cat->{$slot};

            # skip the default‐holder itself
            next if $slot eq '_defaults';

            # for each of your two default keys, only add if missing:
            # NB: 'age_group' already has its own so it is skipped here
            for my $k ( keys %$defaults ) {
                $map->{$k} //= { %{ $defaults->{$k} } };
            }
        }
    }

    warn
"!  Note: injected global 'Unknown' + 'Not Available' defaults into each category\n"
      if DEVEL_MODE;
}

# Turn a stub_format like 'R%02d' or '%02d' into a tail regex with one capture
sub _fmt_to_tail_regex {
    my ($fmt) = @_;
    my $re = quotemeta($fmt);            # escape literal chars
    $re =~ s/\\%0?(\d+)d/(\\d{$1})/g;    # %02d -> (\d{2}), %3d -> (\d{3})
    return qr/$re$/;                     # anchor at end
}

# Try to strip a value from the *end* of a string using stub_format
# Returns the captured integer or undef if no match; modifies $$sref
sub _strip_tail_using_fmt {
    my ( $sref, $fmt ) = @_;
    my $re = _fmt_to_tail_regex($fmt);
    if ( $$sref =~ s/$re// ) { return 0 + $1 }
    return undef;
}

1;