Public strAssignVarArray() As String
Public strYSelected As String
Public strXSelected As String
Public strStartRho As String
Public strStopRho As String
Public objDataDoc As ISpssDataDoc
Public objOutputDoc As ISpssOutputDoc
Sub Main

	Dim objDocuments As ISpssDocuments
	Dim ingNumber As Integer
	Dim objSpssInfo As ISpssInfo
	Dim retcode As Integer
	Dim objOptions As ISpssOptions

	Set objDocuments = objSpssApp.Documents
	Set objDataDoc = objDocuments.GetDataDoc(0)
		
	Set objSpssInfo = objSpssApp.SpssInfo
	ingNumber=objSpssInfo.NumVariables
	If ingNumber < 1 Then
		retcode =MsgBox( "No variables defined", 0 ,"Cluster Assignments")
		End
	End If

	'we'll call a function which returns variables selected
	'by the user in an array of strings we pass it.
	Dim strVarsSelected() As String
	Dim strXList() As String
	Dim i As Integer
	Dim j As Integer
	Dim lngNumber As Long
	Dim strSpssVars() As String
	Dim strTemp As String

	lngNumber = objSpssInfo.NumVariables
	ReDim strSpssVars (lngNumber)
	For i = 0 To lngNumber - 1
		strSpssVars(i) = objSpssInfo.VariableAt(i)
	Next i

	'Get Range of candidate correlations

	Dim InputStopRhoOK As Boolean
	Dim InputStartRhoOK As Boolean
	Dim InputOrderOK As Boolean
	InputStartRhoOK = False
	InputStopRhoOK = False
	InputOrderOK = False

	While (InputStartRhoOK = False) Or (InputStopRhoOK = False) Or (InputOrderOK = False)
		InputStartRhoOK = False
		InputStopRhoOK = False
		InputOrderOK = False

		Call RhoDialog

		If IsRho(strStartRho) = False Then
			MsgBox("Starting Rho must be a number between -1 and 1",0,"Error")
		Else
			InputStartRhoOK = True
		End If
		If IsRho(strStopRho) = False Then
			MsgBox("Ending Rho must be a number between -1 and 1",0,"Error")
		Else
			InputStopRhoOK = True
		End If
		If (CDbl(strStopRho) < CDbl(strStartRho)) And (IsRho(strStartRho) And IsRho(strStopRho)) Then
			MsgBox("Ending Rho must be larger than Starting Rho",0,"Error")
		Else
			InputOrderOK = True
		End If
	Wend

	Dim StartRho As Double
	Dim StopRho As Double
	StartRho = CDbl(strStartRho)
	StopRho = CDbl(strStopRho)
	Call DisplayYDialog (strSpssVars)
	Call DisplayXDialog (strSpssVars)
	Call Compute(StartRho, StopRho)


End Sub
Sub Compute(StartRho As Double, StopRho As Double)

	Dim i As Integer
	Dim j As Integer
	Dim k As Integer

	' Get the number of cases in the file:
	Dim strNCases As String
	strNCases = CStr(objDataDoc.GetNumberOfCases)
	Dim lngNCases As Long
	lngNCases = CLng(strNCases)

	'Get the data
	Dim strTextDat As Variant
	Dim strDat() As String
	ReDim strDat(lngNCases, 2)
	Dim ValidCase()
	ReDim ValidCase(lngNCases)
	Dim dX() As Double
	Dim dY() As Double
	Dim nValidCases As Long
	Dim nCases As Long
	Dim Residual() As Double
	ReDim Residual(lngNCases)

	'Get the dependent variable

	strTextDat = objDataDoc.GetTextData(strYSelected,strYSelected,1,lngNCases)

	For i = 0 To lngNCases-1
		strDat(i,0) = strTextDat(0,i)
	Next i

	'Now get the independent variable

	'Get string data and remove cases with missing values

	strTextDat = objDataDoc.GetTextData(strXSelected,strXSelected,1,lngNCases)
	For i = 0 To lngNCases-1
		strDat(i,1) = strTextDat(0,i)
	Next i

	For i = 0 To lngNCases-1
		ValidCase(i) = 1
		For j = 0 To 1
			If IsNumeric(strDat(i,j)) = False Then
				ValidCase(i) = 0
			End If
		Next j
	Next i

	nValidCases = 0
	For i = 0 To lngNCases-1
		nValidCases = nValidCases + ValidCase(i)
	Next i

	ReDim dY(nValidCases)
	ReDim dX(nValidCases)
	ReDim Residual(nValidCases)

	k = 0
	For i = 0 To lngNCases-1
		If ValidCase(i) = 1 Then
			dY(k) = CDbl(strDat(i,0))
			dX(k) = CDbl(strDat(i,1))
			k = k + 1
		End If
	Next i

	nCases = lngNCases
	lngNCases = nValidCases

	Dim N As Double
	N = CDbl(lngNCases)

	Dim Rho(11)As Double
	Dim b0 As Double
	Dim b1 As Double
	Dim YStar() As Double
	ReDim YStar(lngNCases)
	Dim XStar() As Double
	ReDim XStar(lngNCases)
	Dim ESS(11) As Double
	Dim XBar As Double
	Dim YBar As Double

	For i = 0 To 9
		Rho(i) = StartRho + CDbl(i)*(StopRho - StartRho)/10
	Next i
	Rho(10) = CDbl(strStopRho)

	For i = 0 To 10

		Call MakeStar(dY, Rho(i), lngNCases, YStar)
		Call MakeStar(dX, Rho(i), lngNCases, XStar)
		Call Simple_Regression(XStar, YStar, lngNCases, b1)

		XBar = 0.0
		YBar = 0.0
		For j = 0 To lngNCases-1
			XBar = XBar + XStar(j)
			YBar = YBar + YStar(j)
		Next j
		XBar = XBar/N
		YBar = YBar/N

		If Rho(i) = 1.0 Then
			b0 = 0.0
		Else
			b0 = YBar - b1*XBar
		End If

		Call MakeResidual(XStar, YStar, b0, b1, lngNCases, Residual)

		ESS(i) = 0.0
		For j = 0 To lngNCases-1
			ESS(i) = ESS(i) + Residual(j)*Residual(j)
		Next j

	Next i

	'Now output the results
	Dim Count As Integer
	Set objDocuments = objSpssApp.Documents
	Count = objDocuments.OutputDocCount

	If Count > 0 Then
		Set objOutputDoc = objDocuments.GetOutputDoc(0)
		objOutputDoc.Visible = True
	Else
		' Open a new output document:
		Set objOutputDoc = objSpssApp.NewOutputDoc
		' Make the document visible:
		objOutputDoc.Visible = True
	End If

	Set objItems = objOutputDoc.Items
	Set objItem = objItems.GetItem(objItems.Count-1)
	objItem.Current = True

	index = objOutputDoc.InsertTable (cNEWTABLE, 11,2,1)

	Set objItems = objOutputDoc.Items
	Set objItem = objItems.GetItem(objItems.Count-1)
	Set objPivotTable = objItem.Activate
	objPivotTable.UpdateScreen = False

	Set objLayerLabels = objPivotTable.LayerLabelArray
	Set objPivMgr = objPivotTable.PivotManager
	Set objLayerDim = objPivMgr.LayerDimension(0)
	intLay = objLayerDim.NumCategories

	objLayerLabels.ValueAt(0,2) = "Hildreth-Lu Procedure"

	'Set the column labels
	Set objLabels = objPivotTable.ColumnLabelArray

	objLabels.ValueAt (1, 0) = "Rho"
	objLabels.ValueAt (1, 1) = "ESS"

	' Insert values in the pivot table
	Dim strFormat As Variant
	strFormat = "#.#"
	objLayerDim.CurrentCategory = 0
	Set objDataCells = objPivotTable.DataCellArray

	For i = 0 To 10
		objDataCells.SelectCellAt (i, 0)
		objPivotTable.NumericFormat (strFormat, 4)
		objDataCells.ValueAt (i, 0) = CStr(Rho(i))
		objPivotTable.ClearSelection
	Next i

	For i = 0 To 10
		objDataCells.SelectCellAt (i, 1)
		objPivotTable.NumericFormat (strFormat, 8)
		objDataCells.ValueAt(i, 1) = CStr(ESS(i))
		objPivotTable.ClearSelection
	Next i

	Dim intWidth As Integer
	intWidth = 144

	' Reset the width for the columns:
	'objDataCells.ReSizeColumn (0, intWidth)
	objDataCells.ReSizeColumn (1, intWidth)

	objItem.Deactivate


End Sub
Sub DisplayYDialog(strSpssVars() As String)

	Begin Dialog UserDialog 400,203,"Select Dependent Variable", .DlgFreq ' %GRID:10,7,1,1
		ListBox 80,21,90,133,strSpssVars(),.ListBox1
		OKButton 280,42,90,21, .cmdOK
		CancelButton 290,98,70,21, .cmdCancel
	End Dialog
	Dim dlg As UserDialog
	Dialog dlg

End Sub
Function DlgFreq%(DlgItem$, Action%, SuppValue%)

	Select Case Action%
	Case 1 ' Dialog box initialization

	Case 2 ' Value changing or button pressed

		Select Case DlgItem$
		Case "cmdOK"
			strYSelected = DlgText("ListBox1")
			Exit Function
		Case "cmdCancel"
			Exit Function
		End Select

	Case 3 ' TextBox or ComboBox text changed

	Case 4 ' Focus changed

	Case 5 ' Idle

	End Select

End Function
Function IsRho(strX) As Boolean

	IsRho = False
	If IsNumeric(strX) = True Then
		Dim sngX As Single
		sngX = CSng(strX)
		If (sngX >=-1) And (sngX <=1) Then
			IsRho = True
		End If
	End If

End Function
Sub RhoDialog
	Begin Dialog UserDialog 400,203,"Enter Correlation Range",.DlgRho ' %GRID:10,7,1,1
		Text 70,49,90,14,"Starting Rho",.Text1
		Text 70,91,90,14,"Ending Rho",.Text2
		TextBox 220,49,90,21,.TextBox1
		TextBox 220,91,90,21,.TextBox2
		OKButton 70,147,90,21, .cmdOK
		CancelButton 220,147,90,21, .cmdCancel
	End Dialog
	Dim dlg As UserDialog
	Dialog dlg

End Sub
Function DlgRho%(DlgItems$, Action%, SuppValue%)
	Select Case DlgItems$
	Case "cmdOK"
		strStartRho = DlgText("TextBox1")
		strStopRho = DlgText("TextBox2")
		Exit Function
	Case "cmdCancel"
		Exit All
	End Select
End Function
Sub MakeStar(x() As Double, Rho As Double, N As Long, ByRef Star() As Double)

	Dim i As Integer

	Star(0) = x(0)*Sqr(1-Rho*Rho)
	For i = 1 To N-1
		Star(i) = x(i) - Rho*x(i-1)
	Next i

End Sub
Sub MakeResidual(x() As Double, y() As Double, b0 As Double, b1 As Double, N As Long, ByRef e() As Double)

	Dim i As Integer

	For i = 0 To N-1
		e(i) = y(i) - b0 - b1*x(i)
	Next i

End Sub
Sub Simple_Regression(x() As Double, y() As Double, N As Long, ByRef b1 As Double)

	Dim i As Integer

	Dim SXY As Double
	Dim SX As Double
	Dim SY As Double
	Dim SXX As Double

	SXY = 0.0
	SX = 0.0
	SY = 0.0
	SXX = 0.0
	For i = 0 To N-1
		SXY = SXY + x(i)*y(i)
		SX = SX + x(i)
		SY = SY + y(i)
		SXX = SXX + x(i)*x(i)
	Next i
	b1 = (N*SXY - SX*SY)/(N*SXX - SX*SX)

End Sub
Sub DisplayXDialog(strSpssVars() As String)

	Begin Dialog UserDialog 400,203,"Select Independent Variable", .DlgXFreq ' %GRID:10,7,1,1
		ListBox 80,21,90,133,strSpssVars(),.ListBox1
		OKButton 280,42,90,21, .cmdOK
		CancelButton 290,98,70,21, .cmdCancel
	End Dialog
	Dim dlg As UserDialog
	Dialog dlg

End Sub
Function DlgXFreq%(DlgItem$, Action%, SuppValue%)

	Select Case Action%
	Case 1 ' Dialog box initialization

	Case 2 ' Value changing or button pressed

		Select Case DlgItem$
		Case "cmdOK"
			strXSelected = DlgText("ListBox1")
			Exit Function
		Case "cmdCancel"
			Exit Function
		End Select

	Case 3 ' TextBox or ComboBox text changed

	Case 4 ' Focus changed

	Case 5 ' Idle

	End Select

End Function