mds.ado

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

*! version 1.0.0  11mar2005
program mds, byable(onecall)
	version 9

	if replay() {
		if _by() {
			error 190
		}
		if "`e(cmd)'" != "mds" {
			dis as err "mds estimation results not found"
			exit 301
		}
		Display `0'
		exit
	}

	if _by() {
		by `_byvars'`_byrc0' : Estimate `0'
	}
	else {
		Estimate `0'
	}
end


program Estimate, eclass byable(recall)

	#del ;
	syntax  varlist(numeric) [if] [in] ,
		ID(varname)
	[
	// data options
		MEAsure(str)
		s2d(str)
		STD
		STDv(varlist)
		UNIT
		UNITv(varlist)
	// model options
		METhod(str)
		DIMensions(numlist integer >=1 max=1)  // documented as dim()
		ADDconstant
	// display options
		*
	];
	#del cr

	_mds_parse_method `method'
	local method `s(method)'

	_mds_parse_dopts `options' , method(`method')
	local display_options  `s(opts)'

	parse_dissim `measure'
	local dname `s(unab)'    // measure
	local dtype `s(dtype)'   // (dis)similarity

	if `"`s2d'"' != "" {
		if "`dtype'" == "dissimilarity" {
			dis as err "s2d() not allowed with " ///
				   "a dissimilarity measure"
			exit 198
		}
		_mds_parse_s2d `s2d'
		local s2d `s(s2d)'
	}
	else if "`dtype'" == "similarity" {
		local s2d standard
	}

	if "`dimensions'" != "" {
		local dim dim(`dimensions')
	}

	marksample touse
	quietly count if `touse'
	local N = r(N)
	if (`N' == 0)  error 2000
	if (`N' == 1)  error 2001

	if "`std'" != "" & "`stdv'" != "" {
		opts_exclusive "std std()"
	}
	if "`unit'" != "" & "`unitv'" != "" {
		opts_exclusive "unit unit()"
	}
	if "`std'" != "" {
		local stdv _all
	}
	if "`unit'" != "" {
		local unitv _all
	}
	if "`stdv'" != "" {
		unab stdv : `stdv'
	}
	if "`unitv'" != "" {
		unab unitv : `unitv'
	}

	/*
		if "`:list stdv - varlist'" != "" {
			dis as txt "(std() contains variables not in varlist)"
		}
		if "`:list unitv - varlist'" != "" {
			dis as txt "(unit() contains variables not in varlist)"
		}
	*/

	if "`:list stdv & unitv'" != "" {
		dis as err "options std() and unit() have variables in common"
		exit 198
	}

// check id //////////////////////////////////////////////////////////////////
	tempvar ID
	Id2String `id' `touse' `ID'
	local idtype `r(idtype)'
	local duplicates = `r(duplicates)'
	if "`idtype'"!="int" & `duplicates'==0 {
		local mxlen = `r(mxlen)'
		local labels `"`r(labels)'"'
	}

// compute dissimilarity matrix of observations //////////////////////////////

	tempname codes D X

	local nvar : list sizeof varlist
	matrix `codes' = J(`nvar',1,0), J(`nvar',1,1)
	matrix rownames `codes' = `varlist'
	matrix colnames `codes' = loc scale

	if "`unitv'`stdv'" != "" {
		local ustd : list stdv | unitv

		local i = 0
		foreach v of local varlist {
			local ++i
			if !`:list v in ustd' {
				local Varlist `Varlist' `v'
				continue
			}

			tempvar v`i'
			quietly summ `v' if `touse'
			if r(sd) < 1e-8*(1+abs(r(mean))) {
				dis as err "variable `v' is constant"
				exit 198
			}

			if `:list v in unitv' {
				matrix `codes'[`i',1] = r(min)
				matrix `codes'[`i',2] = r(max)-r(min)
			}
			else {
				matrix `codes'[`i',1] = r(mean)
				matrix `codes'[`i',2] = r(sd)
			}

			quietly gen `v`i'' = ///
			   (`v'-`codes'[`i',1])/`codes'[`i',2] if `touse'
			local Varlist `Varlist' `v`i''
		}
	}
	else {
		local Varlist `varlist'
	}
	matrix dissim `D' = `Varlist' if `touse' , `dname' name(`ID')

	// convert to dissimilarities
	if "`s2d'" != "" {
		_mds_s2d `D', `s2d'
	}

// MDS on dissimilarity matrix ////////////////////////////////////////////////

	if "`method'" == "classical" {
		capture noisily {
			_mds_classical `D', `dim' `addconstant'
		}
	}
	else {
		dis as err "method `method' not available"
		exit 198
	}
	local rc = _rc
	if `rc' {
		dis as err "failure to compute MDS"
		exit `rc'
	}

// save results from r() into e() and display /////////////////////////////////

	quietly ereturn post, esample(`touse') properties(nob noV eigen)

	foreach x in `:r(macros)' {
		ereturn local `x' `r(`x')'
	}
	foreach x in `:r(scalars)'  {
		ereturn scalar `x' = r(`x')
	}
	foreach x in `:r(matrices)' {
		matrix `X' = r(`x')
		ereturn matrix `x' = `X'
	}

	ereturn scalar N            = `N'
	ereturn matrix D            = `D'    // "observed dissimilarities"
	ereturn matrix coding       = `codes'
	ereturn local  varlist      `varlist'
	ereturn local  id           `id'
	ereturn local  idtype        `idtype'
	ereturn local  duplicates   = `duplicates'
	if "`idtype'"!="int" & `duplicates'==0 {
		ereturn local labels `"`labels'"'
		ereturn local strfmt  "str`mxlen'"
	}

	ereturn local  dname        `dname'
	ereturn local  dtype        `dtype'
	ereturn local  s2d          `s2d'
	ereturn local  method       `method'

	ereturn local  predict      mds_p
	ereturn local  estat_cmd    mds_estat
	ereturn local  properties   nob noV eigen

	ereturn local  cmd          mds

	Display, `display_options'
end


program Display
	syntax [, *]

	_mds_display, `options'
end


program Id2String, rclass 
	args id touse ID

	/* if you change the logic here be sure to change it in mds_p */
	local idtype = substr("`:type `id''",1,3)
	local id1 `id'
	if "`idtype'" != "str" {
		local label : value label `id'
		if "`label'" != "" {
			qui decode `id' if `touse', gen(`ID')
			local idtype label
			local id1 `ID'
		}
		else {
			local fmt: format `id'
			cap assert `id'==round(`id') if `touse'
			if _rc == 0 {
				local idtype int
				qui gen `ID' = string(`id',"`fmt'") if `touse'
				local id1 `ID'
			}
			else {
				local idtype float
				tempvar id1
				qui gen `id1' = string(`id',"`fmt'") if `touse'
			}
		}	
	}
	Duplicates `touse' `id1'
	local duplicates = (_rc > 0)
	if "`idtype'" != "int" {
		mata : CleanLabels("`id1'", "`ID'", "`touse'")
	}
	/* only continue if original vector did not have duplicates 	*/
	if `duplicates'==0  & "`idtype'"!="int" {
		/* make sure CleanLabels has not created duplicates	*/
		EnsureUnique `ID' `touse'
		mata : PasteLabels("`id1'", "`touse'", "labels", "mxlen")
		if `"`labels'"' != "" {
			return local labels `"`labels'"'
			return local mxlen = `mxlen' 
		}
		else {
			local duplicates = 1
			di as txt "exceeded maximum macro length to store id labels"
		}
	}
	return local duplicates = `duplicates'
	return local idtype `idtype'
end


program Duplicates, sortpreserve
	args touse ID

	// check for duplicates
	capture bys `touse' `ID' : assert _N==1 if `touse'
	if _rc {
		dis as txt "(id() has duplicate values)"
	}
end


program EnsureUnique, sortpreserve
	args id touse

	tempvar j tmp
	gen int `j' = _n

	sort `touse' `id', stable
	cap by `touse' `id' : assert _N==1 if `touse'
	if (_rc == 0) exit 0

	gen `tmp' = `id'
	
	// tag #_n on duplicates
	by `touse' `id' : replace `id' = cond(_N>1,`id'+"#"+string(`j'),`id') if `touse'

	cap bys `touse' `id' : assert _N==1
	if (_rc == 0) exit 0

	// tag #_n on all
	replace `id' = `tmp'+"#"+string(`j') if `touse'
end

mata:

function CleanLabels(string scalar sid, string scalar sID, 
		string scalar stouse)
{
	real scalar i, n, mxl, li
	string colvector vID

	vID = strtrim(st_sdata(., sid, stouse))
	n = rows(vID)
	if (n == 0) return

	while (sum(strpos(vID,"  "))!=0) {
		vID = subinstr(vID,"  "," ")
	}
	while (sum(strpos(vID,".."))!=0) {
		vID = subinstr(vID,"..",".")
	}
	vID = subinstr(vID,". ","_")
	vID = subinstr(vID," .","_")
	vID = subinstr(vID," ","_")
	vID = subinstr(vID,".","_")

	mxl = 0
	for (i=1; i<=n; i++) {
		li = strlen(vID[i])
		if (li > mxl) mxl = li
	}
	if (sid != sID)	i = _st_addvar("str"+strofreal(mxl), sID)
	st_sstore(., sID, stouse, vID)
}

function PasteLabels(string scalar sid, string scalar stouse, 
	string scalar smac, string scalar smxlen)
{
	real scalar i, n, nmax, l, li, mxl 
	string scalar svars
	string colvector vid

	vid = st_sdata(., sid, stouse)
	n = rows(vid)
	if (n == 0) return

	nmax = st_numscalar("c(max_macrolen)")
	strs = "`"+char(34)+vid[1]+char(34)+char(39)
	mxl = strlen(vid[1])
	l = mxl+4
	for (i=2; i<=n; i++) {
		strs = strs+char(32)+"`"+char(34)+vid[i]+char(34)+char(39)
		li = strlen(vid[i])
		if (li > mxl) mxl = li
		l = l + li + 5
		if (l > nmax) exit(0)
	}
	st_local(smac, strs)
	st_local(smxlen, strofreal(mxl))
}

end

exit