mdslong.ado

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

*! version 1.0.1  09may2005
program mdslong, byable(onecall)
	version 8

	if replay() {
		if _by() {
			error 190
		}
		if "`e(cmd)'" != "mdslong" {
			dis as err "mdslong 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 max=1)
		[if] [in] [aw fw],
		id(varlist min=2 max=2)
	[
	// data options
		SIMilarity		// not to be documented
		s2d(passthru)
		FORCE
	// model options
		METhod(str)		// undocumented (only 1 method)
		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)'

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

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

// do actual MDS

	tempname D X

	if "`method'" == "classical" {

		if `"`weight'"' != "" {
			dis as err "weights not allowed with classical scaling"
			exit 101
		}

		// classical scaling implemented via a matrix

		qui Long2mat `varlist' if `touse', id(`id') ///
		    `similarity' `s2d' `force'

		matrix `D'   = r(D)
		local  dtype  `r(dtype)'
		local  s2d    `r(s2d)'

		_mds_classical `D', `dim' `addconstant'
	}
	else {
		dis "method `method' not available"
		exit 198
	}

// save results in e()

	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 = colsof(`D')
	ereturn matrix D = `D'

	ereturn local  depvar      `varlist'
	ereturn local  id          `id'
	ereturn local  dtype       `dtype'
	ereturn local  s2d         `s2d'

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

	ereturn local  cmd         mdslong

// output

	Display , `display_options'
end


program Display
	syntax [, *]

	_mds_display, `options'
end


program Long2mat, sortpreserve rclass
	version 8

	#del ;
	syntax  varname if, id(varlist)
	[
		SIMilarity
		s2d(str)
		MISsing(numlist min=1 max=1)
		FORCE
	] ;
	#del cr

	marksample touse

	local lstd = length("`stddev'")

	if "`s2d'" != "" {
		_mds_parse_s2d `s2d'
		local s2d `s(s2d)'
		local dtype similarity
	}
	else if "`similarity'" != "" {
		local dtype similarity
		local s2d standard
	}
	else local dtype dissimilarity

// comparison identifiers id() /////////////////////////////////////////////////

	tempname D
	tempvar j1 j2 j12 y diff

	local jj1 : word 1 of `id'
	local jj2 : word 2 of `id'

	if "`jj1'" == "`jj2'" {
		dis as err "different id variables expected"
		exit 198
	}
	if "`:type `jj1''" != "`:type `jj2''" {
		dis as err "types of id variables differ"
		exit 198
	}
	if "`:value label `jj1''" != "`:value label `jj2''" {
		dis as err "value labels of id variables differ"
		exit 198
	}

	Long2mat_UnitCodes `j1' `j2' = `jj1' `jj2' `touse'
	local n = r(n)
	local codes `r(codes)'

// check/normalize proximity information //////////////////////////////////////

	gen `y' = `varlist'
	compress `y'

	capture assert `y'>=0 if `touse'
	if _rc {
		dis as err "proximity information should be nonnegative"
		if "`force'" != "" {
			dis as err ///
			    "option force does not apply to this problem"
		}
		exit 198
	}

	if "`dtype'" == "dissimilarity" {
		capture assert `y'==0 if `j1'==`j2' & `touse'
		if _rc {
			if "`force'" == "" {
				dis as err "objects should have zero " ///
					   "dissimilarity to themselves"
				exit 198
			}
			replace `y'=0 if `j1'==`j2' & `touse'
		}
	}

	if "`dtype'" == "similarity" {
		capture assert `y'==1 if `j1'==`j2' & `touse'
		if _rc {
			if "`force'" == "" {
				dis as err "objects should have unit " ///
					   "similarity to themselves"
				exit 198
			}
			replace `y'=1 if `j1'==`j2' & `touse'
		}

		capture assert `y'<=1 if `touse'
		if _rc {
			dis as err "similarity data should take values " ///
				   "in the unit interval [0,1]"
			if "`force'" != "" {
				dis as err "option force does not apply " ///
					   "to this problem"
			}
			exit 198
		}
	}

// deal with duplicates within (j1,j2) ////////////////////////////////////////

	capture bys `touse' `j1' `j2' : assert _N==1 if `touse'
	if _rc {
		if "`force'" == "" {
			dis as err "duplicate observations found"
			exit 198
		}
		// take mean within (j1,j2)
		bys `touse' `j1' `j2' : replace `y'=sum(`y') if `touse' & _N>1
		bys `touse' `j1' `j2' : replace `y'= ///
					cond(_n<_N,.,`y'/_N) if `touse' & _N>1
		markout `touse' `y'
	}

// (j1,j2) are unordered pairs, coded 1..n ////////////////////////////////////

	gen `j12' = cond(`j1'<`j2', (`j1'-1)*`n'+`j2', (`j2'-1)*`n'+`j1')
	bys `touse' `j12' : assert _N <= 2 if `touse'
	bys `touse' `j12' : gen `diff' = `y'!=`y'[_N] if `touse'
	count if `diff' & `touse'
	if r(N)>0 {
		if "`force'" == "" {
			dis as err "proximity information is asymmetric"
			exit 198
		}
		// make symmetric
		bys `touse' `j12' : replace `y' = ///
		    cond(_n==1, (`y'[1]+`y'[2])/2, .) if _N==2 & `touse'
		markout `touse' `y'
	}

// initialize matrix /////////////////////////////////////////////////////////

	if "`missing'" == "" {
		local missing .
	}
	matrix `D' = J(`n',`n',`missing')
	forvalues i = 1/`n' {
		matrix `D'[`i',`i'] = ("`dtype'"  == "similarity")
	}
	matrix colnames `D' = `codes'
	matrix rownames `D' = `codes'

// store variables into matrix ///////////////////////////////////////////////

	sort `touse'
	count if `touse' == 0
	local ij = r(N)+1
	while `ij' <= c(N) {
		matrix `D'[`j1'[`ij'],`j2'[`ij']] = `y'[`ij']
		matrix `D'[`j2'[`ij'],`j1'[`ij']] = `y'[`ij']
		local ++ij
	}

// convert to dissimilarities ////////////////////////////////////////////////

	if "`dtype'" == "similarity" {
		_mds_s2d `D' , `s2d'
	}

 // return stuff /////////////////////////////////////////////////////////////

	return matrix D  =  `D'
	return local dtype  `dtype'
	return local s2d    `s2d'
end


// produces codes nj1 nj2 that are integer coded 1..n
program Long2mat_UnitCodes, rclass
	args  nj1 nj2  equal  j1 j2 touse

	assert "`equal'" == "="
	confirm variable `j1' `j2'
	confirm new variable `nj1' `nj2'

	quietly {

	// produce coding file

		tempvar jj jcodes merge // ensure unique varnames
		tempfile fjj

		preserve

		keep if `touse'
		keep `j1'
		bys `j1' : keep if _n==1
		rename `j1' `jj'
		save `"`fjj'"'

		restore, preserve

		keep if `touse'
		keep `j2'
		bys `j2' : keep if _n==1
		rename `j2' `jj'
		append using `"`fjj'"'
		bys `jj' : keep if _n==1
		sort `jj'
		gen `jcodes' = _n

		local n = c(N)
		forvalues i = 1/`n' {
			local codes `codes' `=`jj'[`i']'
		}
		compress
		save `"`fjj'"', replace

		restore

	// merge coding	file

		gen `jj' = `j1'
		sort `jj'
		merge `jj' using `"`fjj'"', nokeep _merge (`merge') uniqusing
		drop `merge'
		rename `jcodes' `nj1'
		replace `jj' = `j2'
		sort `jj'
		merge `jj' using `"`fjj'"' , nokeep _merge (`merge') uniqusing
		drop `merge'
		rename `jcodes' `nj2'
	}

	return local n `n'
	return local codes `codes'
end
exit