package MplusParser; use strict; #---------------------------------# # MplusParser.pm # Author: Joel S Steele # Version: 0.3b #---------------------------------# # This version currenty does not # handle | style syntax. # you will need to write out what # you mean. #---------------------------------# # for easy file creation... not just for HTML anymore use HTML::Template; # currently this assumes data in csv format... but why would you use anything else right? # -jss sub new{ my $class = shift; my $file = shift || 0; my $self = {}; bless $self, $class; # a bit of preprocessing if($file){ if($self->slurpMplus($file)){ $self->parseMplus(); } } # Any number of characters A-Z 0-9 and the underscore # | with either an @ or * symbol (? = maybe) # | | with a numer following, possibly negative allowing for the decimal point(? = maybe) # | | | with a starting '(' (? = maybe) # | | | | and anything not a ')' (? = maybe) # | | | | | followed by an ending ')' (? = maybe) # | |__ |______ | |___ | # | | | | | | | | | $self->{'re_pattern'} = '(\w+)(?:@|\*)?([\d\-\.]*)?\(?([^\)]*)?\)?'; # better than a split in case the starting values are negative $self->{'range_pattern'} = '([^\-]+)\-(.*)$'; return $self; } sub slurpMplus{ my $self = shift; my $infile = shift; local undef $/; # no input record separator... gimme the whole thing as a string!!! unless(open(FH, $infile)){ warn "unable to $infile for reading $!\n"; return 0; }; my $filetxt = ; #tasty... close(FH); $self->{'filetxt'} = $filetxt; return 1; } sub outputModelTxt{ my $self = shift; # first we set up the templates # --------------------------------------------------------------------- # # Just to keep things straight here are the # labels from the above template that need # to be filled in from the Mplus script # # filename = name of the input file # MISSING = missing values # datalabels = variable names from the file # uselabeles = variables in the usevar statement # model_name = what R will call this object # model_label = the human readable version of the above # data_type = raw, covariance, summary, etc # means_vect = vector of means # numobs = number of observations # mvars = manifest variables # lvars = latent variables # paths = a string representation of the specified paths # # --------------------------------------------------------------------- # my $modelTMPLT = qq'# change this to fit your needs # not everyone likes CSV. input.df <- read.csv("",header=FALSE,na.strings=""); names(input.df) <- c(); usedata <- input.df[,c()]; <- mxModel(name="", type="RAM", mxData(observed=usedata, type="""raw", means=c(""), numObs=), manifestVars=c(), latentVars=c(), ); '; # --------------------------------------------------------------------- # # More lables this time for the path template # # pth_fromvars = the beginning of the path(s) # pth_tovars = where the path(s) end # pth_arrows = the number of arrows needed for the path(s) # pth_free = free or fixed path(s) # pth_values = starting or fixed value(s) of the path(s) # pth_labels = parameter name(s) for the path(s) # # --------------------------------------------------------------------- # my $pathTMPLT = qq' mxPath( from=c(), to=c(), arrows=, free=c(), values=c(), labels=c() )'; my $model_tmpl = HTML::Template->new(scalarref => \$modelTMPLT, die_on_bad_params=>0); my $path_tmpl = HTML::Template->new(scalarref => \$pathTMPLT, die_on_bad_params=>0); # for cleaner easier output my @paths; for(@{$self->{'pathoutput'}}){ $path_tmpl->param($_); #load the current path parameters push @paths, $path_tmpl->output(); $path_tmpl->clear_params(); #clean up after. } $self->{'output'}->{'paths'} = join(",\n", @paths); $model_tmpl->param($self->{'output'}); #load the full model return($model_tmpl->output()); } sub parseMplus{ my $self = shift; my $filetxt = $self->{'filetxt'}; my %chunks; my $label; # clear out any comments $filetxt =~ s/!.*?$//mg; # blank lines $filetxt =~ s/^\s*$//mg; # and any leading whitespace. $filetxt =~ s/^\s+//mg; #set the input record separator to newline local $/ = "\n"; open FH, "<", \$filetxt; #open the string as a filehandle while(){ #read from it! my $ltxt; #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!# # this only matches for the basic input commands and will # not match for separate models as in multiple # group analysis or for model constraints. #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!# if(/^[a-z]+:[^\/\\]/i){ #colons are special in Mplus but we need to make sure we are not matching a physical drive. ($label,$ltxt) = $_ =~ /^([a-z]+):(.*?)$/i; #capture the section label based on the first colon in the line. $label = lc($label); # since Mplus commands can be shortened to 4 characters we will # use the first 4 for any command just to be safe $label = join('',(split(//,$label))[0..3]); }else{ $ltxt = $_; } #clean up whitespace $ltxt =~ s/^\s+//; #front... chomp($ltxt); #back... side to side. #only if it matches something other than white-space push @{$chunks{$label}},$ltxt if($ltxt =~ /\w/); } close(FH); # save this guy for later. $self->{'script_parts'} = \%chunks; } # split things up within each section sub processMplus{ my $self = shift; $self->_MplusData(); $self->_MplusTitle(); $self->_MplusVars(); $self->_MplusModel(); } sub _MplusData{ my $self = shift; # work with the data chunks my $data_arr = $self->{'script_parts'}->{'data'}; my $str = join('',@{$data_arr}); # bring it all back together # search for the filename my ($file) = $str =~ /FILE\s+IS|=\s?([^;]+);/si; if($file){ chomp($file); $self->{'output'}->{'filename'} = $file; } # the type if present if($str =~ /TYPE/){ my ($type) = $str =~ /TYPE\s+IS|=\s*([^;]+);/i; if(defined $type && $type =~ /cov/i){ $self->{'output'}->{'data_type'} = 'cov'; }elsif(defined $type && $type =~ /corr/i){ $self->{'output'}->{'data_type'} = 'cor'; } } # and the number of observations if present if($str =~ /NOBS/){ # this is crufty... my ($chunk) = $str =~ /NOBS([^;]+);/i; #weak. my ($nobs) = $chunk =~ /(\d+)/; #lame. if(defined $nobs && $nobs > 0){ $self->{'output'}->{'numobs'} = $nobs; } } } sub _MplusVars{ my $self = shift; my $vars_arr = $self->{'script_parts'}->{'vari'}; my $str = join(' ',@{$vars_arr}); # assuming everyone ends things in semicolons # we split each section up by the semicolon, # leaving the NAMES, USEVARIABLES and MISSING statements # to process as chunks of text my @secs = split(/;/,$str); # look for the NAMES statement in the resultant chunks of text my @datalabels = do{ my @ns = grep(/NAMES/i,@secs); $ns[0] =~ s/ARE/=/; # replace ARE with = if present my @v = split(/=/,$ns[0]); # now split on the = sign # this will leave the text 'NAMES' as $v[0] and everything else # as $v[1] in the @v array. my @n = split(/\s+/, $v[1]); #split up the variable names based on # one or more spaces in the text. my @arr; for my $n (@n){ #loop through each element from the above split # this is to handle ranges in specification if($n =~ /\-/){ # look for the - character signifying a range my ($start, $stop) = split(/\-/,$n); # split it up on the - and # capture the starting and stopping values of the range. # Since this is generally of the form A1-A20 or something similar # we need to separate the leading character from the numerical parts my ($pre1, $num1) = $start =~ /([a-zA-Z_]+)(\d+)/; my ($pre2, $num2) = $stop =~ /([a-zA-Z_]+)(\d+)/; if($pre1 eq $pre2){ # Make sure the non numeric parts match up. for my $c ($num1 .. $num2){ # us the start and stop numerical parts to # create the range... here we just use one of the prefixes since # the both match. push @arr, $pre1.$c; } } }elsif($n =~ /\w+/){ #if there was no range make sure the element matches something push @arr, $n; } } @arr; # return the results }; # quote for R's sake $self->{'output'}->{'datalabels'} = join(',',(map{qq~"$_"~;}@datalabels)); my @uselabels = do{ my @ns = grep(/USEVAR/i,@secs); $ns[0] =~ s/ARE/=/; my @v = split(/=/,$ns[0]); my @n = split(/\s+/, $v[1]); my @arr; for my $n (@n){ # this is to handle ranges in specification if($n =~ /\-/){ my ($start, $stop) = split(/\-/,$n); my ($pre1, $num1) = $start =~ /([a-zA-Z_]+)(\d+)/; my ($pre2, $num2) = $stop =~ /([a-zA-Z_]+)(\d+)/; if($pre1 eq $pre2){ for my $c ($num1 .. $num2){ push @arr, $pre1.$c; } } }elsif($n =~ /\w+/){ push @arr, $n; } } @arr; }; $self->{'output'}->{'uselabels'} = join(',',(map{qq~"$_"~;}@uselabels)); $self->{'output'}->{'mvars'} = $self->{'output'}->{'uselabels'}; # missing values??? if(grep(/MISSING/i,@secs)){ my @ns = grep(/MISSING/i,@secs); $ns[0] =~ s/ARE/=/; my @v = split(/=/,$ns[0]); my $mvalstr; if($v[1] =~ /(\.)/ || $v[1] =~ /(\*)/){ $mvalstr = 'c("'.$1.'")'; }elsif($v[1] =~ /\([^\)]+\)/){ my @mvals = $v[1] =~ /\(([^\)]+)\)/g; $mvalstr = join(' ',@mvals); $mvalstr =~ s/\s+/,/g; $mvalstr =~ s/\-/../g; $mvalstr = 'c('.$mvalstr.')'; } $self->{'output'}->{'missing'} = $mvalstr; } } sub _MplusModel{ my $self = shift; # working with the model part, here shortened to mode # because of the four character shortcuts allowed in Mplus my $model_arr = $self->{'script_parts'}->{'mode'}; my $str = join(' ',@{$model_arr}); # bring it all back together my %part_hash; my @mparts = split(';',$str); # split the big string on semicolons # search through the resultant chunks for @{$part_hash{'bylist'}} = grep(/ BY /i, @mparts); # BY statements @{$part_hash{'onlist'}} = grep(/ ON /i, @mparts); # ON statements @{$part_hash{'withlist'}} = grep(/ WITH /i, @mparts); # WITH statements # notice we left some space around each of these so they wouldn't match the ones below. # shortcut support @{$part_hash{'ponlist'}} = grep(/ PON /i, @mparts); # PON statements @{$part_hash{'pwithlist'}} = grep(/ PWITH /i, @mparts); # PWITH statements @{$part_hash{'meanslist'}} = grep(/\[[^\]]+\]/, @mparts); # []'s so means # anything not accompanied by an ON,PON,BY,WITH,PWITH or []'s is a variance @{$part_hash{'varslist'}} = grep{$_ !~ /\bP?ON|BY|P?WITH\b/ && $_ !~ /\[|\]/}@mparts; $self->{'model_parts'} = \%part_hash; $self->_modelBY(); # do the BY first to collect latent variables $self->_modelON(); $self->_modelWITH(); $self->_modelPON(); $self->_modelPWITH(); $self->_modelVariances(); $self->_modelMeans(); if(exists $self->{'latents'}){ $self->{'output'}->{'lvars'} = join(',',(map{qq~"$_"~}(keys %{$self->{'latents'}}))); } } sub _modelBY{ my $self = shift; $self->_modelParseArrows('bylist','BY','L_'); # Lambda } sub _modelON{ my $self = shift; $self->_modelParseArrows('onlist','ON','B_'); # Beta } sub _modelWITH{ my $self = shift; $self->_modelParseArrows('withlist','WITH','C_'); # Covariance } # it is ALL possible... how much time to invest is the question. # We don't want to give the following elements the same labels as those # above so we add a leading 'p' sub _modelPON{ my $self = shift; $self->_modelParseArrows2('ponlist','PON','pB_'); # paired Beta } sub _modelPWITH{ my $self = shift; $self->_modelParseArrows2('pwithlist','PWITH','pC_'); # paired Covariance } sub _modelParseArrows{ my $self = shift; my $lst = shift; my $split = shift; my $label = shift; return 0 if(!exists $self->{'model_parts'}->{$lst}); my $list = $self->{'model_parts'}->{$lst}; my @paths; # A range could include manifest and latent variables. Check both if we have them. # This is why we run the BY statements first. # Trust me there is a ternary in there. my @mvars = (exists $self->{'latents'})? ((map{s/"//g;$_;}(split /,/,$self->{'output'}->{'mvars'})),(keys %{$self->{'latents'}})): (map{s/"//g;$_;}(split /,/,$self->{'output'}->{'mvars'})); chomp(@mvars); my %mvars = map{($_,1);}@mvars; my $pcount = 0; for(@{$list}){ # using the supplied split characters create # a left hand side and right hand side of the statement my ($lhs, $rhs) = split(/$split/,$_); # cuddle things up to each other for free, fixed and labeled stuff $lhs =~ s/\s//g; # remove a single space globally $rhs =~ s/^\s+//; # remove leading spaces $rhs =~ s/\s*\@\s*/@/g; # remove spaces around the @ symbols $rhs =~ s/\s*\(/(/g; # remove spaces around ()'s, well at least the first one $rhs =~ s/\s*\*\s*/*/g; # remove spaces around the * symbols my %tmp; my (@rhs, @labs, @frees, @vals); #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!# # Here we only look for right hand side ranges. This may # need updating if people regress a list of variables # onto a single variable... hmmmmm. #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!# if($rhs =~ /\-\s*[^\d\.]/){ # do we have a range here? #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!# # this could really get mucky if people regularly abuse the # range operator in Mplus. Hopefully the only define ranges # with the same prefixes. #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!# # split up the range in to start and stop values. my ($start, $stop) = $rhs =~ /$self->{'range_pattern'}/o; # here we extract parts of the right hand side my ($rhs1, $val1, $lab1) = $start =~ /$self->{'re_pattern'}/o; my ($rhs2, $val2, $lab2) = $stop =~ /$self->{'re_pattern'}/o; my $keep = 0; # Schwartzian Transformation. # Read from the bottom up. # We need to sort the varaibles we currently have since we are not sure they all came in order. # So we split up each one by its leading characters and possible trailing digits # We then store those values along with the original value foreach my $cv(map{$_->[2]} # Step 7: return the copy of the original based on the sort below. sort{$a->[0] cmp $b->[0] # Step 5: Sort on the leading characters || $a->[1] <=> $b->[1];} # Step 6: or sort on the digits map{ my $v = $_; # Step 2: set a temp variable to the incoming value $_ my ($w, $d) = $v =~ /(\D+)(\d+)?/; # Step 3: capture the leading characters and the trailing digits (defined $d)?[$w, $d, $v]:[$v,$v,$v]; # Step 4: store the leading characters, digits and the original, # or just three copies of the original }keys %mvars # Step 1: for each variable ){ # loop through each variable already collected from the sorted list above if($cv eq $rhs1){ # is this the start of our range? $keep = 1; }elsif($cv eq $rhs2){ # or the end of our range? $keep = 0; push @rhs, $cv; # check if the regexp caught anything otherwise default push @vals, (defined $val2 && $val2 =~ /\S/)?$val2:'0'; push @labs, (defined $lab2 && $lab2 =~ /\S/)?$lab2:$label.$pcount++; push @frees, ($stop =~ /@/)?'FALSE':'TRUE'; #is there an @ on the end of this range? } if($keep){ push @rhs, $cv; push @vals, (defined $val2 && $val2 =~ /\S/)?$val2:'0'; push @labs, (defined $lab2 && $lab2 =~ /\S/)?$lab2:$label.$pcount++; push @frees, ($stop =~ /@/)?'FALSE':'TRUE'; } } }else{ for my $c (split(/\s+/,$rhs)){ my ($rhs1, $val, $lab) = $c =~ /$self->{'re_pattern'}/o; push @rhs, $rhs1; push @vals, (defined $val && $val =~ /\S/)?$val:'0'; push @labs, (defined $lab && $lab =~ /\S/)?$lab:$label.$pcount++; push @frees, ($c =~ /@/)?'FALSE':'TRUE'; } } # check the arrow directions if($split eq "ON"){ $tmp{'pth_tovars'} = qq~"$lhs"~; $tmp{'pth_fromvars'} = join(',',(map{qq~"$_"~}@rhs)); }else{ # collect latent variables if($split eq "BY"){ $self->{'latents'}->{$lhs}++; $mvars{$lhs}++; } $tmp{'pth_fromvars'} = qq~"$lhs"~; $tmp{'pth_tovars'} = join(',',(map{qq~"$_"~}@rhs)); } # check arrow numbers if($split eq "WITH"){ $tmp{'pth_arrows'} = 2; }else{ $tmp{'pth_arrows'} = 1; } $tmp{'pth_free'} = join(',',@frees); $tmp{'pth_values'} = join(',',@vals); # we do the quoting for R's sake $tmp{'pth_labels'} = join(',',(map{qq~"$_"~}@labs)); push @paths,\%tmp; } push @{$self->{'pathoutput'}}, $_ for(@paths); } # here we handle PON's and PWITH's for paired arrow specification shortcuts. sub _modelParseArrows2{ my $self = shift; my $lst = shift; my $split = shift; my $label = shift; my $list = $self->{'model_parts'}->{$lst}; return 0 if(!exists $self->{'model_parts'}->{$lst}); my @paths; my $pcount = 0; # a range could include manifest and latent variables. Check both if we have them. # This is why we run the BY statements first. my @mvars = (exists $self->{'latents'})? ((map{s/"//g;$_;}(split /,/,$self->{'output'}->{'mvars'})),(keys %{$self->{'latents'}})): (map{s/"//g;$_;}(split /,/,$self->{'output'}->{'mvars'})); chomp(@mvars); my %mvars = map{($_,1);}@mvars; for(@{$list}){ my ($lhs, $rhs) = split(/$split/,$_); # cuddle things up to each other for free, fixed and labeled stuff $rhs =~ s/^\s+//; # remove leading spaces $rhs =~ s/\s*\@\s*/@/g; # remove spaces around the @ symbol $rhs =~ s/\s*\(/(/g; # remove spaces around ()'s, well at least the first one $rhs =~ s/\s*\*\s*/*/g; # remove spaces around the * symbol my (@lhs); if($lhs =~ /\-\s*[^\d\.]/){ # do we have a range here? my ($start, $stop) = $lhs =~ /$self->{'range_pattern'}/o; my $lhs1 = $start; # no labels or free fixin's on this side of things. my $lhs2 = $stop; $lhs1 =~ s/\s+//g; $lhs2 =~ s/\s+//g; chomp($lhs1); chomp($lhs2); my $keep = 0; # Schwartzian Transformation. foreach my $cv(map{$_->[2]} sort{$a->[0] cmp $b->[0] || $a->[1] <=> $b->[1];} map{my $v = $_;my ($w, $d) = $v =~ /(\D+)(\d+)?/; (defined $d)?[$w, $d, $v]:[$v,$v,$v];}keys %mvars ){ if($cv eq $lhs1){ $keep = 1; }elsif($cv eq $lhs2){ $keep = 0; push @lhs, $cv; } if($keep){ push @lhs, $cv; } } }else{ for my $c (split(/\s+/,$lhs)){ push @lhs, $c; } } my (@rhs, @labs, @frees, @vals); if($rhs =~ /\-\s*[^\d\.]/){ # do we have a range here? my ($start, $stop) = $rhs =~ /$self->{'range_pattern'}/o; my ($rhs1, $val1, $lab1) = $start =~ /$self->{'re_pattern'}/o; my ($rhs2, $val2, $lab2) = $stop =~ /$self->{'re_pattern'}/o; my $keep = 0; # Schwartzian Transformation. foreach my $cv(map{$_->[2]} sort{$a->[0] cmp $b->[0] || $a->[1] <=> $b->[1];} map{my $v = $_;my ($w, $d) = $v =~ /(\D+)(\d+)?/; (defined $d)?[$w, $d, $v]:[$v,$v,$v];}keys %mvars ){ if($cv eq $rhs1){ $keep = 1; }elsif($cv eq $rhs2){ $keep = 0; push @rhs, $cv; push @vals, (defined $val2 && $val2 =~ /\S/)?$val2:'0'; push @labs, (defined $lab2 && $lab2 =~ /\S/)?$lab2:$label.$pcount++; push @frees, ($stop =~ /@/)?'FALSE':'TRUE'; #is there an @ on the end of this range? } if($keep){ push @rhs, $cv; push @vals, (defined $val2 && $val2 =~ /\S/)?$val2:'0'; push @labs, (defined $lab2 && $lab2 =~ /\S/)?$lab2:$label.$pcount++; push @frees, ($stop =~ /@/)?'FALSE':'TRUE'; } } }else{ for my $c (split(/\s+/,$rhs)){ my ($rhs1, $val, $lab) = $c =~ /$self->{'re_pattern'}/o; push @rhs, $rhs1; push @vals, (defined $val && $val =~ /\S/)?$val:'0'; push @labs, (defined $lab && $lab =~ /\S/)?$lab:$label.$pcount++; push @frees, ($c =~ /@/)?'FALSE':'TRUE'; } } my ($numarrows,$from, $to); # check arrow numbers if($split eq "PWITH"){ $numarrows = 2; $from = 'pth_fromvars'; $to = 'pth_tovars'; }else{ $numarrows = 1; $from = 'pth_tovars'; $to = 'pth_fromvars'; } if($#lhs == $#rhs){ for my $i (0 .. $#lhs){ my %p_tmp; $p_tmp{$from} = qq~"$lhs[$i]"~; $p_tmp{$to} = qq~"$rhs[$i]"~; $p_tmp{'pth_arrows'} = $numarrows; $p_tmp{'pth_free'} = $frees[$i]; $p_tmp{'pth_values'} = $vals[$i]; $p_tmp{'pth_labels'} = qq~"$labs[$i]"~; push @paths, \%p_tmp; } }else{ print "@lhs\n"; print "\n===\n"; print "@rhs\n"; die "Things don't match up in the $split statement!\nCheck your syntax."; } } push @{$self->{'pathoutput'}}, $_ for(@paths); } # these two could be factored out more, but it is only two subs... meh. sub _modelVariances{ my $self = shift; return 0 if(!exists $self->{'model_parts'}->{'varslist'}); my @paths; # this handles multiple specification prior to the ';' my @list = grep{ /\w/ }map{ $_ =~ s/^\s+//; # remove leading spaces $_ =~ s/\s*\@\s*/@/g; # remove spaces around the @ symbol $_ =~ s/\s*\(/(/g; # remove spaces around ()'s, well at least the first one $_ =~ s/\s*\*\s*/*/g; # remove spaces around the * symbol split(/\s/,$_); }@{$self->{'model_parts'}->{'varslist'}}; my $label = 'V_'; my $pcount = 0; # a range could include manifest and latent variables. Check both if we have them. # This is why we run the BY statements first. my @mvars = (exists $self->{'latents'})? ((map{s/"//g;$_;}(split /,/,$self->{'output'}->{'mvars'})),(keys %{$self->{'latents'}})): (map{s/"//g;$_;}(split /,/,$self->{'output'}->{'mvars'})); chomp(@mvars); my %mvars = map{($_,1);}@mvars; for(@list){ my (%tmp,@rhs,@vals,@frees,@labs); if($_ =~ /\-\s*[^\d\.]/){ # range here? my ($start, $stop) = $_ =~ /$self->{'range_pattern'}/o; my ($rhs1, $val1, $lab1) = $start =~ /$self->{'re_pattern'}/o; my ($rhs2, $val2, $lab2) = $stop =~ /$self->{'re_pattern'}/o; my $keep = 0; # Schwartzian Transformation. foreach my $cv(map{$_->[2]} sort{$a->[0] cmp $b->[0] || $a->[1] <=> $b->[1];} map{my $v = $_;my ($w, $d) = $v =~ /(\D+)(\d+)?/; (defined $d)?[$w, $d, $v]:[$v,$v,$v];}keys %mvars ){ if($cv eq $rhs1){ $keep = 1; }elsif($cv eq $rhs2){ $keep = 0; push @rhs, $cv; push @vals, (defined $val2 && $val2 =~ /\S/)?$val2:'0'; push @labs, (defined $lab2 && $lab2 =~ /\S/)?$lab2:$label.$pcount++; push @frees, ($stop =~ /@/)?'FALSE':'TRUE'; } if($keep){ push @rhs, $cv; push @vals, (defined $val2 && $val2 =~ /\S/)?$val2:'0'; push @labs, (defined $lab2 && $lab2 =~ /\S/)?$lab2:$label.$pcount++; push @frees, ($stop =~ /@/)?'FALSE':'TRUE'; } } }else{ my ($rhs1, $val, $lab) = $_ =~ /$self->{'re_pattern'}/o; push @rhs, $rhs1; push @vals, (defined $val && $val =~ /\S/)?$val:'0'; push @labs, (defined $lab && $lab =~ /\S/)?$lab:$label.$pcount++; push @frees, ($_ =~ /@/)?'FALSE':'TRUE'; } $tmp{'pth_arrows'} = 2; $tmp{'pth_fromvars'} = join(',',(map{qq~"$_"~}@rhs)); $tmp{'pth_tovars'} = join(',',(map{qq~"$_"~}@rhs)); # I guess this could be dropped since it is implied by OpenMx... $tmp{'pth_free'} = join(',',@frees); $tmp{'pth_values'} = join(',',@vals); $tmp{'pth_labels'} = join(',',(map{qq~"$_"~}@labs)); push @paths,\%tmp; } push @{$self->{'pathoutput'}}, $_ for(@paths); } sub _modelMeans{ my $self = shift; return 0 if(!exists $self->{'model_parts'}->{'meanslist'}); my @paths; # this handles multiple specifications in the same set of []'s my @list = grep{ /\w/ }map{ $_ =~ s/^\s+//; # remove leading spaces $_ =~ s/\s*\@\s*/@/g; # remove spaces around the @ symbol $_ =~ s/\s*\(/(/g; # remove spaces around ()'s, well at least the first one $_ =~ s/\s*\*\s*/*/g; # remove spaces around the * symbol split(/\s/,$_); }@{$self->{'model_parts'}->{'meanslist'}}; my $label = 'M_'; my $pcount = 0; # a range could include manifest and latent variables. Check both if we have them. # This is why we run the BY statements first. my @mvars = (exists $self->{'latents'})? ((map{s/"//g;$_;}(split /,/,$self->{'output'}->{'mvars'})),(keys %{$self->{'latents'}})): (map{s/"//g;$_;}(split /,/,$self->{'output'}->{'mvars'})); chomp(@mvars); my %mvars = map{($_,1);}@mvars; for(@list){ $_ =~ s/[\[\]]//g; my (%tmp,@rhs,@vals,@frees,@labs); if($_ =~ /\-\s*[^\d\.]/){ my ($start, $stop) = $_ =~ /$self->{'range_pattern'}/o; my ($rhs1, $val1, $lab1) = $start =~ /$self->{'re_pattern'}/o; my ($rhs2, $val2, $lab2) = $stop =~ /$self->{'re_pattern'}/o; my $keep = 0; # Schwartzian Transformation. foreach my $cv(map{$_->[2]} sort{$a->[0] cmp $b->[0] || $a->[1] <=> $b->[1];} map{my $v = $_;my ($w, $d) = $v =~ /(\D+)(\d+)?/; (defined $d)?[$w, $d, $v]:[$v,$v,$v];}keys %mvars ){ if($cv eq $rhs1){ $keep = 1; }elsif($cv eq $rhs2){ $keep = 0; push @rhs, $cv; push @vals, (defined $val2 && $val2 =~ /\S/)?$val2:'0'; push @labs, (defined $lab2 && $lab2 =~ /\S/)?$lab2:$label.$pcount++; push @frees, ($stop =~ /@/)?'FALSE':'TRUE'; } if($keep){ push @rhs, $cv; push @vals, (defined $val2 && $val2 =~ /\S/)?$val2:'0'; push @labs, (defined $lab2 && $lab2 =~ /\S/)?$lab2:$label.$pcount++; push @frees, ($stop =~ /@/)?'FALSE':'TRUE'; } } }else{ my ($rhs1, $val, $lab) = $_ =~ /$self->{'re_pattern'}/o; push @rhs, $rhs1; push @vals, (defined $val && $val =~ /\S/)?$val:'0'; push @labs, (defined $lab && $lab =~ /\S/)?$lab:$label.$pcount++; push @frees, ($_ =~ /@/)?'FALSE':'TRUE'; } $tmp{'pth_arrows'} = 1; $tmp{'pth_fromvars'} = qq~"one"~; $tmp{'pth_tovars'} = join(',',(map{qq~"$_"~}@rhs)); $tmp{'pth_free'} = join(',',@frees); $tmp{'pth_values'} = join(',',@vals); $tmp{'pth_labels'} = join(',',(map{qq~"$_"~}@labs)); push @paths,\%tmp; } push @{$self->{'pathoutput'}}, $_ for(@paths); } sub _MplusTitle{ my $self = shift; my $title_arr = $self->{'script_parts'}->{'titl'}; my $title = join('',@{$title_arr}); if($title){ chomp($title); $self->{'output'}->{'model_label'} = $title; }else{ $self->{'output'}->{'model_label'} = 'Model1'; } $self->{'output'}->{'model_name'} = 'Model1'; } # "You only record your first album once" -Lapdog 1;