*! prob1nx V1.11  C F Baum / P Gottschalk   0118 rev 0131 for atanh,sigma
* Ref: Smith and Blundell, Econometrica 54:3, 679-686

program define prob1nx, eclass
	version 6.0
	
* parsing code and subroutines taken from -ivreg-  5.0.4
	local n 0

	gettoken lhs 0 : 0, parse(" ,[") match(paren)
	IsStop `lhs'
	if `s(stop)' { error 198 }
	while `s(stop)'==0 { 
		if "`paren'"=="(" {
		local n = `n' + 1
		if `n'>1 { 
			capture noi error 198 
			di in red `"syntax is "(all instrumented variables = instrument variables)""'
			exit 198
		}
		gettoken p lhs : lhs, parse(" =")
		while "`p'"!="=" {
			if "`p'"=="" {
			exit 198 
			}
			local end`n' `end`n'' `p'
			gettoken p lhs : lhs, parse(" =")
		}
		tsunab end`n' : `end`n''
		tsunab exog`n' : `lhs'
		}
		else {
		local exog `exog' `lhs'
		}
		gettoken lhs 0 : 0, parse(" ,[") match(paren)
		IsStop `lhs'
	}
	local 0 `"`lhs' `0'"'

	tsunab exog : `exog'
	tokenize `exog'
	local lhs "`1'"
	local 1 " " 
	local exog `*'

	syntax [if] [in]
/*	 [fw pw iw] [,noConstant]
	local wtype `weight'
        local wtexp "`exp'"
        if "`weight'" != "" { local wgt `"[`weight' `exp']"' }
*/
	marksample touse
	markout `touse' `lhs' `exog' `exog1' `end1'

	Subtract newexog : "`exog1'" "`exog'"
	local endo_ct : word count `end1'
	local ex_ct : word count `newexog'
	if `endo_ct' > 1 {
		di in red "No more than one RHS endogenous variable can be used" /*
		*/ in prob1nx."
	exit 481
	}
	if `endo_ct' > `ex_ct' {
		di in red "equation not identified; must have at " /*
		*/ "least as many instruments not in"
		di in red "the model as there are "           /*
		*/ "instrumented variables"
		exit 481
	}
* generate starting values for the regression part; do not allow weights
	regress `end1' `exog' `newexog' if `touse'
	tempvar rhadd b0 p0 athrho rho ival
* pred as double
	qui predict double `rhadd',r
	matrix b0=e(b)
	matrix coleq b0 = eq3
	matrix sigma=e(rmse)
	matrix coleq sigma = sigma:_cons
* generate starting values for the probit part and correlation term; do not allow weights
	local insts `exog' `newexog'
	probit `lhs' `end1' `exog' `rhadd' if `touse' ,`constant'
* produce test results via option?
	qui test `rhadd'
	di in gr _n "Smith-Blundell test of exogeneity: "   /*
	*/ in ye %9.0g r(chi2) in gr            /* 
	*/ in gr "  Chi-sq(" %2.0f in ye r(df) /*
	*/ in gr ")  P-value = " in ye %6.0g r(p)
	matrix p0=e(b)
	matrix coleq p0 = `lhs'
* requires matdelrc from Nick Cox -matodd- package (STB-50, dm69), brought inline	
	local nc=colsof(p0)-1
	local rho = p0[1,`nc']
	if `rho'>0.9 {local rho=0.9 }
	if `rho'<-0.9 {local rho=-0.9 }
*	dis "`rho'"
	mat athrho = 0.5*log((1+`rho')/(1-`rho'))
*	mat athrho = 0
	mat colnames athrho = athrho:_cons
	_matdlrc p0,c(`nc')
	mat ival=p0,athrho,b0,sigma
	ml model lf pr1nx_lf (`lhs':`lhs'=`exog' `end1') /athrho (`end1'=`exog' `newexog') /sigma
	ml init ival
	ml query
	ml maximize, nooutput
	ml display, neq(4)
	local level $S_level
	local dispopt "level(`level')"
	DispAl `level'
end

program define DispAl
	local level = `1'
	_diparm athrho, level(`level')
        di in gr _dup(9) "-" "+" _dup(68) "-"
	_diparm athrho, level(`level') tanh label("rho")
        di in gr _dup(78) "-"
end

program define IsStop, sclass
		/* sic, must do tests one-at-a-time, 
		 * 0, may be very large */
	if `"`0'"' == "[" {	
	sret local stop 1
	exit
	}
	if `"`0'"' == "," {
	sret local stop 1
	exit
	}
	if `"`0'"' == "if" {
	sret local stop 1
	exit
	}
	if `"`0'"' == "in" {
	sret local stop 1
	exit
	}
	if `"`0'"' == "" {
	sret local stop 1
	exit
	}
	else	sret local stop 0
end

/*  Remove all tokens in dirt from full */
 *  Returns "cleaned" full list in cleaned */

program define Subtract   /* <cleaned> : <full> <dirt> */
	args	    cleaned     /*  macro name to hold cleaned list
	*/  colon	/*  ":"
	*/  full	/*  list to be cleaned 
	*/  dirt	/*  tokens to be cleaned from full */
	
	tokenize `dirt'
	local i 1
	while "``i''" != "" {
	local full : subinstr local full "``i''" "", word all
	local i = `i' + 1
	}

	tokenize `full'		/* cleans up extra spaces */
	c_local `cleaned' `*'       
end

program def _matdlrc
*! from matdelrc.ado NJC 1.0.0 22 Jan 1999 after WWG Statalist 21 Jan 1999
        version 6.0
        gettoken matname 0 : 0, parse(" ,")

        syntax , [ Row(str) Col(str) ]
        if "`row'`col'" == "" {
                di in bl "nothing to do"
                exit 0
        }

        tempname A
        mat `A' = `matname' /* this will fail if `matname' not a matrix */

        if "`col'" != "" {
                local col = `col' /* evaluate any expression */
                confirm integer n `col'
                if `col' < 1 | `col' > colsof(`matname') {
                        di in r "column number out of range"
                        exit 498
                }
                if colsof(`matname') == 1 {
                        di in r "no; would delete entire column vector"
                        exit 498
                }
                if `col' == 1 { mat `A' = `A'[1..., 2...] }
                else if `col' == colsof(`A') {
                        mat `A' = `A'[1..., 1..`col'-1]
                }
                else mat `A' = `A'[1..., 1..`col'-1], `A'[1..., `col'+1...]
        }
        if "`row'" != "" {
                local row = `row' /* evaluate any expression */
                confirm integer n `row'
                if `row' < 1 | `row' > rowsof(`matname') {
                        di in r "row number out of range"
                        exit 498
                }
                if rowsof(`matname') == 1 {
                        di in r "no; would delete entire row vector"
                        exit 498
                }
                if `row' == 1 { mat `A' = `A'[2..., 1...] }
                else if `row' == rowsof(`A') {
                        mat `A' = `A'[1..`row'-1, 1...]
                }
                else mat `A' = `A'[1..`row'-1,1...] \ `A'[`row'+1..., 1...]
        }

        mat `matname' = `A'
end

exit