mds_p.ado

是一个经济学管理应用软件 很难找的 但是经济学学生又必须用到

*! version 1.0.1  09may2005
program mds_p
	version 9

	if !inlist("`e(cmd)'","mds","mdsmat","mdslong") { 
		error 301
	}

	#del ;
	syntax  anything [if] [in],  
	[
		CONfig
		PAIRwise
		noTRANSform 
		SAVing(passthru) 
		REPLACE
		FULL 
	];
	#del cr

	if "`e(cmd)'" == "mdsmat" & `"`if'`in'"' != "" { 
		dis as err "if and in not allowed with predict after mdsmat"
		exit 100
	}
	if `"`saving'"' != ""  & `"`if'`in'"' != "" { 
		dis as err "if and in not allowed with saving()"
		exit 100
	}

	opts_exclusive "`config' `transform'"
	opts_exclusive "`config' `full'"

	local stat `config' `pairwise' 
	if `:list sizeof stat' == 0 {
		dis as txt "(config assumed)"
		local stat config
	}
	opts_exclusive "`stat'"
	if ("`stat'"=="config")	preserve

	if `"`if'`in'"' != "" {
		marksample touse, novarlist
		local iftouse if `touse' 
	}

	if "`e(cmd)'" != "mdsmat" & "`e(id)'" != "" {
		capture confirm var `e(id)' 
		if _rc {
			dis as err "id variable `e(id)' not found"
			exit 198
		}
	}
	if "`stat'" == "config" { 
		cap noi Config `anything' `iftouse', `saving' `replace' 
		if (`"`saving'"'=="" & _rc==0) restore, not
		exit _rc
	}

	if "`stat'" == "pairwise" { 
		qui Pairwise `anything' `iftouse', /// 
		    `saving' `replace' `full' `transform'
		if "`r(tagged)'" != "" { 
			di as txt "{p}id variable `e(id)' was identified as " 	///
			 "having duplicate values; adding index numbers to "	///
			 "labels to make them unique{p_end}"
		}
	}
end


program Config
	syntax anything [if] [, saving(str) replace keep ] 

	if inlist("`e(cmd)'","mdslong","mdsmat") & `"`saving'"'=="" {
		dis as err "saving() required with `e(cmd)'"
		exit 198
	}
	
	if "`saving'" != "" { 
		Newvarlist `anything' 
		local varlist `s(varlist)'
		local typlist `s(typlist)'
	}
	else {
		marksample touse , novarlist
		local 0 `anything'
		syntax newvarlist
	}

	local nnew : list sizeof varlist 
	if `nnew' > `e(p)' {
		error 103
	}
	if `nnew' < `e(p)' {
		dis as txt "(`=`e(p)'-`nnew'' dimensions ignored)"
	}

	if "`saving'" != "" { 
		local id `e(id)' 
	}
	else if "`e(duplicates)'" != "0" {
		/* merge on id will fail */
		di as error "{p}saving() required since id variable " ///
		 "`e(id)' was identified as having duplicate values{p_end}"
		exit 115
	} 
	else {
		tempfile fmaster
		tempname key index
		local id `key'
		qui gen int `index' = _n
		qui Id2String `e(id)' `key' `touse' 
		qui sort `key'
		qui save `"`fmaster'"', replace
	}
	qui ObjectFile `id' 
	local id `r(id)' 
	tempvar i
	qui gen int `i' = _n 
	local vlist `"`varlist'"'
	forvalues j = 1 / `nnew' {
		gettoken v  vlist : vlist
		gettoken tp typlist : typlist
		
		qui gen `tp' `v' = el(e(Y),`i',`j') 
		label var `v' "MDS dimension `j'"
	}
	drop `i' 
	
	if "`saving'" != "" { 
		if "`e(idtype)'"=="int" | "`e(idtype)'"=="float" {
			CnvNumeric `id' 
		}
		qui compress
		qui sort `id', stable
		local t    "method=`e(method)',dim=`e(p)'" 
		label data "unit statistics for MDS (`t')"
		qui save `"`saving'"' , `replace' 
	}
	else {
		sort `id'
		tempfile fmerge
		qui save `"`fmerge'"', replace
		qui drop _all
		qui use `"`fmaster'"'
		qui merge `id' using `"`fmerge'"'
		qui drop if _merge == 2
		foreach vi of local varlist {
			qui replace `vi' = . if `touse' == 0
		}
		qui sort `index'
		qui drop _merge 
	}
end


program Pairwise, rclass
	syntax anything [if] [, ///
	   saving(str) replace full notransform ]

	if inlist("`e(cmd)'","mds","mdsmat") & `"`saving'"' == "" {
		dis as err "saving() required with option pairwise"
		exit 198
	}

	local id `e(id)' 
	gettoken id1 id2 : id
	if `"`saving'"' != "" { 
		preserve
		Newvarlist `anything', n(3)
		local varlist `"`s(varlist)'"'
		local typlist `"`s(typlist)'"'
		PairFile "`full'" `id' 
		local id1 `r(id1)'
		local id2 `r(id2)'
		if `"`r(names)'"' != "" {
			tempname Y D
			matrix `Y' = e(Y)
			matrix rownames `Y' = `r(names)'
			matrix `D' = e(D)
			matrix rownames `D' = `r(names)'
			matrix colnames `D' = `r(names)'
			return local tagged tagged
		}
		else {
			local Y e(Y)
			local D e(D)
		}
		local Done restore
	}	
	else {
		local 0 `anything'
		syntax newvarlist(min=3 max=3)
		local Y e(Y)
		local D e(D)
	}
	
	local vn1 : word 1 of `varlist' 
	local vn2 : word 2 of `varlist' 
	local vn3 : word 3 of `varlist' 
	
	local tp1 : word 1 of `typlist' 
	local tp2 : word 2 of `typlist' 
	local tp3 : word 3 of `typlist' 
	
	if substr("`:type `id1''",1,3) == "str" {
		local ID1  `id1' 
		local ID2  `id2' 
	}
	else {
		local ID1  string(`id1') 
		local ID2  string(`id2') 
	}
	
	tempname Ta Tb 
	if "`transform'" == "" { 
		scalar `Ta' = el(e(linearf),1,1)
		scalar `Tb' = el(e(linearf),1,2)
		local ttxt modified
	}
	else {
		scalar `Ta' = 0
		scalar `Tb' = 1
		local ttxt unmodified
	}
	
	marksample touse, novarlist
	
	gen `tp1' `vn1' = `Ta' + `Tb' * ///
	        el(`D',rownumb(`D',`ID1'),colnumb(`D',`ID2')) if `touse'  
	label var `vn1' "`ttx' dissimilarities `id'-units"
	
	tempname F 
	_mds_euclidean `F' = `Y' 
	
	gen `tp2' `vn2' = ///
	        el(`F',rownumb(`F',`ID1'),colnumb(`F',`ID2')) if `touse' 
	label var `vn2' "L2-distance approx configuration"

	gen `tp3' `vn3' = `vn1' - `vn2'  if `touse'  
	label var `vn3' "residual = dissim - distance"

	drop `touse' 
	
	if `"`saving'"'	!= "" { 
		local t    "method=`e(method)',dim=`e(p)'"
		label data "pairwise statistics for MDS (`t')"
		if ("`e(idtype)'"=="int" | "`e(idtype)'"=="float") & ///
  			"`e(duplicates)'"=="0"{
			CnvNumeric `id1' 
			CnvNumeric `id2' 
		}
		compress
		sort `id1' `id2'   
		save `"`saving'"' , `replace' 
		`Done' 
	}
end

// ============================================================================

program ObjectFile, rclass
	args id
	
	if "`id'" == "" {  
		local id id
	}	
	
	drop _all
	tempname Y
	matrix `Y' = e(Y)
	local n = rowsof(`Y')
	local names : rownames `Y' 
	matrix drop `Y'
	
	set obs `n' 
	if "`e(strfmt)'" != "" {
		gen `e(strfmt)' `id' = ""
		mata : _elabels2var("`id'")
	}
	else {
		else gen `id' = ""
		forvalues i = 1/`n' { 
			gettoken name names : names
			replace `id' = "`name'" in `i' 
		}
	}
	
	return local id `id' 
end


program PairFile, rclass
	args full id1 id2
	
	if "`id1'" == "" & "`id2'" == "" { 
		local id1 id1
		local id2 id2
	}
	else if "`id2'" == "" {
		local id2 `id1'2
		local id1 `id1'1
	}	
	
	tempname Y
	tempvar  idx idx2 rest
	
	matrix `Y' = e(Y)
	local n = rowsof(`Y')
	local names : rownames `Y' 
	matrix drop `Y'

	drop _all
	set obs `n' 
	gen `id1' = "" 
	forvalues i = 1/`n' { 
		gettoken name names : names
		replace `id1' = "`name'" in `i' 
	}
	if `"`e(duplicates)'"' == "1" {
		// tag #_n on duplicates
		tempvar j tmp
		gen int `j' = _n
		gen `tmp' = `id1'
		sort `id1', stable
		by `id1' : replace `id1' = cond(_N>1,`id1'+"#"+string(`j'),`id1')
		cap bys `id1' : assert _N==1
		if (_rc) replace `id1' = `tmp'+"#"+string(`j')
		sort `j'
		mata : _pastenames("`id1'", "names")
		return local names `"`names'"'
	}
	
	gen `idx' = _n
	if "`full'" == "" { 
		expand = `idx'-1
	}
	else {
		expand = `n' 
	}
	
	bys `idx' : gen byte `rest' = _n>1
	bys `idx' : gen `idx2' = _n
	sort `rest' `idx' 
	gen `id2' = `id1'[`idx2']
	
	if "`full'" == "" { 
		drop if `id1' == `id2'
	}
	
	return local id1 `id1' 
	return local id2 `id2' 
end


program CnvNumeric
	args id 
	
	tempname newid

	if ("`e(idtype)'"=="float") qui replace `id' = subinstr(`id',"_",".",1) 

	qui gen `newid' = real(`id') 

	qui count if missing(`newid')
	if r(N) > 0 {
		dis as err "impossible to generate numeric id variable"
		exit 198
	}
	
	qui drop `id' 
	rename `newid' `id' 
end


program Id2String, rclass 
	args id ID touse

	if ("`touse'" != "") local iff if `touse'

	local idtype = substr("`:type `id''",1,3)
	if "`idtype'" == "str" {
		gen `ID' = `id'
	}
	else {
		local label : value label `id'
		if "`label'" != "" {
			qui decode `id' `iff', gen(`ID') 
			local idtype label
	 
		}
		else {
			local fmt: format `id'
			cap assert `id'==round(`id') `iif'
			if (_rc == 0) local idtype int
			else local idtype float

			qui gen `ID' = string(`id',"`fmt'") `iff'
		}	
	}
	return local idtype `idtype'
end


program Newvarlist, sclass 
	syntax anything [, n(integer 0)]

	local 0 `anything'
	if (`n' > 0) cap syntax newvarlist(min=`n' max=`n')
	else cap syntax newvarlist
	if _rc == 0 {
		sreturn local varlist `"`varlist'"'
		sreturn local typlist `"`typlist'"'
		exit 0
	}
	preserve
	drop _all
	if (`n' > 0) cap noi syntax newvarlist(min=`n' max=`n')
	else cap noi syntax newvarlist
	local rc = _rc
	restore
	if (`rc'>0) exit `rc'

	sreturn local varlist `"`varlist'"'
	sreturn local typlist `"`typlist'"' 
	foreach vi of local varlist {
		cap drop `vi'
	}
end


mata:

function _elabels2var(string scalar svar)
{
	st_sstore(., svar, tokens(st_global("e(labels)"))')
}

function _pastenames(string scalar svar, string scalar smac)
{
	real scalar i, n
	string scalar names
	string colvector vnames

	st_sview(vnames,.,svar)
	n = rows(vnames)
	names = vnames[1]
	for (i=2; i<=n; i++) {
		names = names + " " + vnames[i]
	}
	st_local(smac, names)
}

end

exit