*! version 0.6.2 2016-01-07 update help
* version 0.6.1 2015-05-25 *keep *drop odd and even
* version 0.6.0 2015-04-23 cleanup

*TODO: all multiple row/col inserts
*TODO: use syntax to allow abbrev of things like insert etc...
*TODO: how to trap if unknown options
*TODO: row cols spec allow 1/x

//  matrix operations on matrices

capture program drop matmath
capture program drop _help

program _help

di
di "Matrices"
di
di "    B & C are matices which can be e(b), e(V), r(b), r(V), or r(table)."
di "    S is either a matrix or scalar."
di
di "Binary element by element operations"
di
di "    matmath A = B + S       matmath A = B - S       matmath A = B * S"
di "    matmath A = B / S       matmath A = B ^ S"
di "    matmath A = B %of S     matmath A = B %dif S"
di
di "Binary element by element operations"
di
di "    matmath A = abs(B)      matmath A = exp(B)      matmath A = inv(B)"
di "    matmath A = log(B)      matmath A = log10(B)    matmath A = logit(B)"
di "    matmath A = odds(B)     matmath A = sq(B)       matmath A = sqrt(B)"
di
di "Extract from matrix"
di
di "    matmath A = diag(B): create row matrix containing diagonal"
di "    matmath A = noomit(B): remove omitted categories estimation matrices"
di
di "Concatenate possibly non-conformable matrices"
di
di "    matmath A = B before C      matmath A = B above C"
di
di "Rearrange a matrix"
di
di "    matmath A = sort(B), row(index) | col(index)"
di
di "Change values in a matrix"
di
di "    matmath A = round(B),
di "                   rowdecimals(integer list)|coldecimals(integer list)"
di "                   fmttype(f|g|e)"
di "    matmath A = fill(B), value(#) // replace existing values"
di
di "Insert rows/columns with specific values"
di
di "    matmath A = insertafter(B), row(index)|col(index) "
di "                                value(#) name(string)"
di " "
di "Options"
di " "
di "    rowdrop()|rowkeep() and coldrop()|colkeep()"
di "       : select rows/columns"
di "       : rows/columns can be reordered and duplicated."
di "       : indices can be #'s, #1/#2, l for last, lm1 for last-1"
di
di "    rownumber, colnumber: add #_ to the row and column names."
di
di "    transpose: saves the transposed matrix."
di
di "    list, format(), width(), decimals(): lists the matrix/"

end

program matmath, sclass

    version 11.2

    tempname origreturns tmp mymat
    _return hold `origreturns'
    _return restore `origreturns', hold

    local OPbinmath     "+ - / * ^" // bi1
    local OPbinpct      "%of %dif" // bi2
    local OPbinconcat   "before above" // bi3
    local OPunisimple   "sqrt log log10 exp abs" // un1
    local OPunicomplex  "sq inv logit odds" // un2
    local OPbookkeep    "keep drop insertafter insert sort round noomit" // bookops
    local OPbookuni     "diag fill" // un3
    local binaryops     "`OPbinmath' `OPbinpct' `OPbinconcat'"

    local input "`*'"

    if "`input'"=="" {
        _help
        exit
    }

//  retrieve return matrices
    * TODO: allow more return matrices

    tempname returnmat1 returnmat2
    local returnmatN = 1
    local retchk `""e(V)" "e(b)" "r(V)" "r(b)" "r(table)" "'
    foreach r in `retchk' `retchk' { // twice to allow for l and r
        local ipos = strpos("`input'","`r'")
        if `ipos'>1 {
            matrix `returnmat`returnmatN'' = `r'
            local input : subinstr local input "`r'" "`returnmat`returnmatN''"
            local ++returnmatN
        }
    }

//  syntax
    *TODO: are all of these needed?
    local input : subinstr local input "(  " "(", all
    local input : subinstr local input "( " "(", all
    local input : subinstr local input "  )" ")", all
    local input : subinstr local input " )" ")", all
    local input : subinstr local input "," " , ", all
    local tempinput : subinstr local input "," " ", all // for _decodeoptions
    foreach t in = `OPbinmath' `OPbinpct' `OPbinconcat' {
        local input = subinstr("`input'","`t'"," `t' ",.)
    }
*XX    local input : subinstr local input "," " , ", all
*XX    local input : subinstr local input "  " " ", all
    local input : subinstr local input "(" "( ", all
    local input : subinstr local input ")" " )", all

//  determine optype and and operator

    foreach grp in OPbinmath OPbinpct OPbinconcat {
        foreach t in ``grp'' {
            local ipos : list posof "`t'" in input
            if `ipos'>0 {
                local operator "`t'"
                local OPtype `grp'
            }
        }
    }
    foreach OPset in OPbookkeep OPunisimple OPunicomplex OPbookuni {
        foreach t in ``OPset'' {
            local ipos : list posof "`t'(" in input
            if `ipos'>0 {
                local operator "`t'"
                local OPtype `OPset'
            }
        }
    }

    if ("`operator'"=="insert") {
        local operator "insertafter"
        local ipos : list posof "name(" in tempinput
        if (`ipos'==0) local tempinput "`tempinput' name(`name')"
    }


**di "OPtype:     `OPtype'"
**di "operator:   `operator'"

    if "`operator'"=="keep" | "`operator'"=="drop" {
        display as error ///
        "matmath m1 = keep() replaced by"
        display as error ///
        "matmath m1 = m2, rowdrop() coldrop() rowkeep() colkeep()"
            exit
     }

//  determine matrices

    local decoded = 0
    if "`OPtype'"=="OPbinmath" | "`OPtype'"=="OPbinpct" ///
     | "`OPtype'"=="OPbinconcat" {
        _decodebinary `input'
        local matout   `s(matout)'
        local matleft  `s(matleft)'
        local matright `s(matright)'
        local eq "`s(eq)'"
        local operator `s(op)'
        local ipos : list posof "`operator'" in binaryops
        if `ipos'==0 {
            di as error "operator `operator' is invalid"
            exit
        }
        local decoded = 1
    }

    if "`OPtype'"=="OPunisimple" | "`OPtype'"=="OPunicomplex" ///
     | "`OPtype'"=="OPbookuni"   | "`OPtype'"=="OPbookkeep"  {
        local matout : word 1 of `input'
        local eq : word 2 of `input'
        local matleft : word 4 of `input'
        local matright ""
*XX        local isscalar = 0
        local decoded = 1
    }

/*
TODO: only keep letters then compare if name is same if so,
then is it a possible matrix : Cox stata list may 8, 14: only keep letters

gen newname = ""
gen length = length(songname)
su length, meanonly
forval i = 1/`r(max)' {
     local char substr(songname, `i', 1)
     local OK inrange(`char', "a", "z") | inrange(`char', "A", "Z") | inrange(`char', "0", "9")
     replace newname = newname + `char' if `OK'
}
*/

    * if a defined operator, assume it is equal operator
    *   e.g., matmath a, rowkeep(); matmath b = a, list

    if `decoded'==0 {
        local matout : word 1 of `input'
        local eq : word 2 of `input'
        local matright ""
*XX        local matleft ""
*XX        local isscalar = 0
        if "`eq'"=="=" {
            local matleft : word 3 of `input'
        }
        else { // only 1 matrix specified so mat it matleft and matout
            local eq "="
            local matleft "`matout'"
        }
        * trap matmat dog = zap(cat) where zap is not an oprator
        local ipos = strpos("`matleft'","(")
        if (`ipos'==0) local operator "equal"
    }

    if "`operator'"=="" {
        display as error ///
        "invalid command or operator specified"
        exit
    }

    if "`eq'"!="=" {
        di as error "missing = sign"
        exit
    }

*di "matout:     `matout'"
*di "matleft:    `matleft'"
*di "operator:   `operator'"
*di "noop:       `noop'"
*di "noeq:       `noeq'"

    capture confirm matrix `matleft'
    if _rc {
        di as error "matrix `matleft' does not exist"
        exit
    }
    else {
        local matleftrowsN = rowsof(`matleft')
        local matleftcolsN = colsof(`matleft')
    }

    if "`operator'"=="diag" {
        if "`matleftrowsN'"!="`matleftcolsN'" {
            di as error ///
            "matrix `matleft' must be square for diag()"
            exit
        }
    }

    if "`OPtype'"=="OPbinmath" | "`OPtype'"=="OPbinpct" {
        capture confirm matrix `matright'
        if _rc { // is not matrix
            capture scalar `tmp' = `matright'
            local matright "`mymat'" // put scalar in matrix `mymat'
            capture confirm scalar `tmp'
            if _rc!=0 { // not scalar
                di as error ///
                "the right element is not a matrix or a scalar"
                exit
            }
            else matrix `matright' = J(1,1,`tmp')
        }
        else { // two matrices are used
            local matrightrowsN = rowsof(`matright')
            local matrightcolsN = colsof(`matright')
            if "`operator'"!="before" & "`operator'"!="above" {
                if (`matleftrowsN'!=`matrightrowsN' ///
                    | `matleftcolsN'!=`matrightcolsN')  {
                    display as error ///
                    "dimensions of matrices are incompatabile"
                    exit
                }
            }
        } // not scalar for second element

    } // binary

//  decode options after the ,


    _decodeoptions, ///
        `tempinput' rowlast(`matleftrowsN') collast(`matleftcolsN') ///

    local value     "`s(value)'"
    local name     `"`s(name)'"'
    local list      "`s(list)'"
    local colis     "`s(columns)'"
    local rowis     "`s(rows)'"
    local format    "`s(format)'"
    local transpose "`s(transpose)'"
    local rowdec    "`s(rowdec)'"
    local coldec    "`s(coldec)'"
    local fmttype   "`s(fmttype)'"
    local rowdrop  "`s(rowdrop)'"
    local coldrop  "`s(coldrop)'"
    local rowkeep  "`s(rowkeep)'"
    local colkeep  "`s(colkeep)'"
    local rownum  "`s(rownumber)'"
    local colnum  "`s(colnumber)'"

    local isdropkeep = 1
    if ("`rowdrop'"=="" & "`coldrop'"=="" ///
      & "`rowkeep'"=="" & "`colkeep'"=="") local isdropkeep = 0

//  decode various operations

    if "`operator'"=="fill" & "`value'"=="" {
        di as error "fill() requires value()"
        exit
    }

    if "`operator'"=="round" {
        if "`rowdec'"=="" & "`coldec'"=="" {
            display as error ///
            "either rowdec() or coldec() is required with round"
            exit
        }
        if "`rowdec'"!="" & "`coldec'"!="" {
            display as error ///
            "only rowdec() or coldec() can be used; not both"
            exit
        }
    }

    if "`operator'"=="insertafter" | {

        if "`rowis'"=="" & "`colis'"=="" {
            display as error ///
            "either row() or col() is required with insertafter()"
            exit
        }

        if "`rowis'"!="" {
            local rowisN = wordcount("`rowis'")
            if `rowisN'>1 {
                display as error "only one row can be inserted"
                exit
            }
*XX            local rowis : word 1 of `rowis' // only one row allowed
            if `rowis'<0 | `rowis'>(`matleftrowsN'+1) {
                display as error ///
                "row() value must be between 0 and `matleftrowsN'"
                exit
            }
        }

        if "`colis'"!="" {
            local colisN = wordcount("`colis'")
*XX            local colis : word 1 of `colis' // only one col allowed
            if `colisN'>1 {
                display as error "only one column can be inserted"
                exit
            }
            else if `colis'<0 | `colis'>(`matleftcolsN'+1) {
                display as error ///
                "col() value must be between 0 and `matleftcolsN'"
                exit
            }
        }

    } // insertafter

    if "`operator'"=="sort" {

        if "`rowis'"!="" & "`colis'"!="" {
            display as error "row() or col() cannot be used together"
            exit
        }
        else if "`rowis'"=="" & "`colis'"=="" {
            display as error "either row() or col() must be specified"
            exit
        }
        else if "`rowis'"!="" {
            local rcN = wordcount("`rowis'")
            if `rcN'>1 {
                display as error "only one row() value is allowed"
                exit
            }
            else {
                local rowis : word 1 of `rowis' // only one row allowed
                if `rowis'<1 | `rowis'>(`matleftrowsN'+1) {
                    display as error ///
                    "row() value must be between 1 and `matleftrowsN'"
                    exit
                }
            }
        }
        else if "`colis'"!="" {
            local rcN = wordcount("`colis'")
            if `rcN'>1 {
                display as error "only one col() value is allowed"
                exit
            }
            else {
                local colis : word 1 of `colis' // only one col allowed
                if `colis'<1 | `colis'>(`matleftcolsN'+1) {
                    display as error ///
                    "col() value must be between 1 and `matleftcolsN'"
                    exit
                }
            }
        }
    } // sort

//  execute the operators

    if "`operator'"!="equal" {
        _matmath , matout(`matout') matleft(`matleft') matright(`matright') ///
            optype(`OPtype') operator(`operator') ///
            cols(`colis') rows(`rowis') ///
            value(`value') name(`name') `transpose' ///
            rowdec(`rowdec') coldec(`coldec') fmttype(`fmttype')
    }
    else matrix `matout' = `matleft'

//  options after operators

    if `isdropkeep' {
        matsel `matout', ///
            rowdrop(`rowdrop') coldrop(`coldrop') ///
            rowkeep(`rowkeep') colkeep(`colkeep')
    }

    if ("`transpose'"=="transpose") matrix `matout' = `matout''

    * add rownumber or colnumber
    foreach rc in row col {
        if "``rc'num'"=="`rc'num" {
    	    local oldnms : `rc'names `matout'
    		local newnms ""
    		local i = 0
    		foreach nm in `oldnms' {
    			local ++i
                * for factor variables
                local nm : subinstr local nm "." "-", all
    			local newnms `"`newnms' "`i'_`nm'" "'
    		}
    		matrix `rc'names `matout' = `newnms'
    }
    }

    if ("`list'"=="list") ///
        matlist `matout', title(matrix `matout') format(`format')

    _return restore `origreturns'
    local nrows = rowsof(`matout')
    local ncols = colsof(`matout')
    sreturn local nrows `nrows'
    sreturn local ncols `ncols'

end

program _decodeoptions, sclass

    syntax [ ,  Rows(string) Columns(string) List ///
        rowlast(string) collast(string) ///
        Format(string) Value(string) name(string) ///
        Transpose Width(integer 9) Decimals(integer 3) ///
        ROWDecimals(string) COLDecimals(string) FMTtype(string) ///
        ROWKeep(string) ROWDrop(string) ROWNumber ///
        COLKeep(string) COLDrop(string) COLNumber ///
        * ]

    if ("`value'"!="") local value = real("`value'")
    else local value = real(".") // default

    local rowlastm1 = `rowlast' - 1
    local collastm1 = `collast' - 1

* 2015-05-25 allow 1/N and odd and even

    if "`rowdrop'"!="" { // =================================================

local rowdrop : subinstr local rowdrop "/" "(1)", all // 1/10 -> 1(1)10
if "`rowdrop'"=="even" {
    numlist "2(2)`rowlast'"
    local rowdrop = r(numlist)
}
if "`rowdrop'"=="odd" {
    numlist "1(2)`rowlast'"
    local rowdrop = r(numlist)
}

        local rowdrop : subinstr local rowdrop "lm1" "`rowlastm1'", all
        local rowdrop : subinstr local rowdrop "l"   "`rowlast'", all
        numlist "`rowdrop'"
        local rowdrop "`r(numlist)'"

    } // rowdrop =============================================================

    if "`rowkeep'"!="" {

local rowkeep : subinstr local rowkeep "/" "(1)", all // 1/10 -> 1(1)10
if "`rowkeep'"=="even" {
    numlist "2(2)`rowlast'"
    local rowkeep = r(numlist)
}
if "`rowkeep'"=="odd" {
    numlist "1(2)`rowlast'"
    local rowkeep = r(numlist)
}

        local rowkeep : subinstr local rowkeep "lm1" "`rowlastm1'", all
        local rowkeep : subinstr local rowkeep "l"   "`rowlast'", all
        numlist "`rowkeep'"
        local rowkeep "`r(numlist)'"

    } // rowkeep =============================================================

    if "`coldrop'"!="" { // ==================================================

local coldrop : subinstr local coldrop "/" "(1)", all // 1/10 -> 1(1)10
if "`coldrop'"=="even" {
    numlist "2(2)`collast'"
    local coldrop = r(numlist)
}
if "`coldrop'"=="odd" {
    numlist "1(2)`collast'"
    local coldrop = r(numlist)
}

        local coldrop : subinstr local coldrop "lm1" "`collastm1'", all
        local coldrop : subinstr local coldrop "l"   "`collast'", all
        numlist "`coldrop'"
        local coldrop "`r(numlist)'"

    } // coldrop =============================================================

    if "`colkeep'"!="" { =====================================================

local colkeep : subinstr local colkeep "/" "(1)", all // 1/10 -> 1(1)10
if "`colkeep'"=="even" {
    numlist "2(2)`collast'"
    local colkeep = r(numlist)
}
if "`colkeep'"=="odd" {
    numlist "1(2)`collast'"
    local colkeep = r(numlist)
}
        local colkeep : subinstr local colkeep "lm1" "`collastm1'", all
        local colkeep : subinstr local colkeep "l" "`collast'", all
        numlist "`colkeep'"
        local colkeep "`r(numlist)'"

    } // colkeep =============================================================

*di "rowdrop: `rowdrop'"
*di "coldrop: `coldrop'"
*di "rowkeep: `rowkeep'"
*di "colkeep: `colkeep'"

    if "`rows'"!="" {
        local rows : subinstr local rows "lm1" "`rowlastm1'", all
        local rows : subinstr local rows "l" "`rowlast'", all
        numlist "`rows'"
        local rows "`r(numlist)'"
    }
    if "`columns'"!="" {
        local columns : subinstr local columns "lm1" "`collastm1'", all
        local columns : subinstr local columns "l" "`collast'", all
        numlist "`columns'"
        local columns "`r(numlist)'"
    }

    if ("`format'"=="") local format "%`width'.`decimals'f"

    local rownumber : subinstr local rownumber "number" "num", all
    local colnumber : subinstr local colnumber "number" "num", all

    sreturn local name `name'
    sreturn local value `value'
    sreturn local rows `rows'
    sreturn local columns `columns'
    sreturn local list `list'
    sreturn local format `format'
    sreturn local transpose `transpose'
    sreturn local rowdec `rowdecimals'
    sreturn local coldec `coldecimals'
    sreturn local fmttype `fmttype'
    sreturn local rowdrop `rowdrop'
    sreturn local coldrop `coldrop'
    sreturn local rowkeep `rowkeep'
    sreturn local colkeep `colkeep'
    sreturn local rownumber `rownumber'
    sreturn local colnumber `colnumber'

end

program _decodebinary, sclass
    args matout eq matleft op matright opt1 opt2 opt3 opt4
    sreturn local matout `matout'
    sreturn local eq "`eq'"
    sreturn local matleft `matleft'
    sreturn local op "`op'"
    sreturn local matright `matright'
end

exit