#delim ;
prog def factext,rclass;
version 16.0;
syntax [newvarlist] [if] [in] [, FRom(varlist min=1 string) STring DOfile(string) PArse(string) FMissing(name) FAST ];
*
 Extract factors named in -newvarlist- from string variables in -from-
 (assumed to contain labels of form "varname==value" as generated by -parmest,label-
 corresponding to dummy variables created by -tabulate-, -xi- or -desmat-)
 parsing with parse string specified in -parse-
 and running -dofile-
 (assumed to be created by -descsave- to reconstruct variable attributes).
 Then generate new binary variable -fmiss()-
 indicating observations in which all variables in -newvarlist- are missing.
*! Author: Roger Newson
*! Date: 25 November 2020
*;

* Default parameter values *;
if "`from'"=="" {;
  local from="label";
};
if `"`parse'"'=="" {;
  local parse "==";
};

* Number of -from- variables *;
local nfrom:word count `from';

* Mark sample for use *;
marksample touse, novarlist;

* Temporary variables *;
tempvar lhs rhs mrg;

* Fill in varlist from -from- if not given *;
if "`varlist'"=="" {;
  tempname vfcur;
  local i1=0;
  while `i1'<`nfrom' {;
    local i1=`i1'+1;
    local fromcur:word `i1' of `from';
    strsep `fromcur' if index(`fromcur',`"`parse'"')>0, lhs(`lhs') rhs(`rhs') sep(`"`parse'"');
    frame put `lhs' if `touse' & strtoname(`lhs')==`lhs', into(`vfcur');
    qui frame `vfcur' {;
      levelsof `lhs', clean lo(vlcur);
      local varlist "`varlist' `vlcur'";
      local varlist: list uniq varlist;
    };
    frame drop `vfcur';
    drop `lhs' `rhs';
  };
};

if "`fast'"=="" {;
  preserve;
};

*
 Beginning of variable evaluation section (UNINDENTED)
*;
cap conf new var `varlist';
if _rc {;
  disp as text "No factor variables generated";
};
else {;

*
 Fill in values of new variables
*;
* Initialise values to missing *;
if `"`string'"'=="" {;
  * Numeric variables to be generated *;
  foreach X of new `varlist' {;
    qui gene double `X'=.;
  };
};
else {;
  * String variables to be generated *;
  foreach X of new `varlist' {;
    qui gene strL `X'="";
  };
};
* Insert nonmissing values if present *;
foreach F of var `from' {;
  strsep `F' if `touse', lhs(`lhs') rhs(`rhs') separator(`"`parse'"');
  foreach X of var `varlist' {;
    if `"`string'"'=="" {;
      qui replace `X'=real(`rhs') if  `touse'&(`lhs'=="`X'")&(index(`F',`"`parse'"')>0);
    };
    else{;
      qui replace `X'=`rhs' if  `touse'&(`lhs'=="`X'")&(index(`F',`"`parse'"')>0);
    };
  };
  drop `lhs' `rhs';
};
* Save space *;
qui compress `varlist';

* Execute -dofile- if provided *;
if "`dofile'"!="" {;
  run "`dofile'";
};

* Add -fmissing()- variable *;
if `"`fmissing'"'!="" {;
  local nfmissing:word count `fmissing';
  if `nfmissing'!=1 {;
    disp as error "Invalid fmissing()";
    error 198;
  };
  conf new var `fmissing';
  qui gene byte `fmissing'=1 if `touse';
  if "`varlist'"!="" {;
    foreach X of var `varlist' {;
      qui replace `fmissing'=0 if `touse' & !missing(`X');
    };
    lab var `fmissing' "All missing: `varlist'";
  };
};

};
*
 End of variable evaluation section (UNINDENTED)
*;

if "`fast'"=="" {;
  restore, not;
};

* Returned results *;
retu local faclist `"`varlist'"';

end;

prog def strsep;
version 16.0;
*
 Input a string variable
 and output two parts of that variable,
 the left and right hand sides
 (separated by a separator string).
*;
syntax varlist(string min=1 max=1) [if] [in] [, Separator(string)
 Lhs(string) Rhs(string) noCompress];
*
 varname is the input string
 separator is the separator string
 lhs is the left-hand side output string
 rhs is the right-hand side output string
 nocompress specifies that lhs and rhs should not be compressed
*;

* Default options *;
if "`separator'"=="" {;
  local separator "==";
};
if "`lhs'"=="" {;
  tempvar lhs;
};
if("`rhs'"==""){;
  tempvar rhs;
};

* Mark sample and stor varname in macro input *;
marksample touse,strok;
local input "`varlist'";

*
 Check that newvarnames are OK
 and mark the sample
*;
local 0 "`lhs'";
syntax newvarlist(min=1 max=1);
local 0 "`rhs'";
syntax newvarlist(min=1 max=1);

* Generate output variables *;
local lensep=length("`separator'");
qui{;
  gene strL `lhs'="";
  gene strL `rhs'="";
  tempvar begsep;
  gene int `begsep'=index(`input',"`separator'") if(`touse');
  replace `lhs'=`input' if(`touse'&(`begsep'==0));
  replace `lhs'=substr(`input',1,`begsep'-1) if(`touse'&(`begsep'>0));
  replace `rhs'=substr(`input',`begsep'+`lensep',.)
    if(`touse'&(`begsep'>0));
  if("`compress'"!="nocompress"){;
    compress `lhs' `rhs';
  };
};

end;