'Begin Description
'This script computes forecast statistics
'They are rmsError and Theil's U, Um, Us, and Uc
'End Description

Option Explicit
'Module(file)level constants
Const cNEWTABLE As String = "Forecast Statistics"
Public strAssignVarArray() As String
Public strYaSelected As String
Public strYsSelected As String
Public objDocuments As ISpssDocuments
Public objDataDoc As ISpssDataDoc
Public objOutputDoc As ISpssOutputDoc
Public objSpssInfo As ISpssInfo
Public objOptions As ISpssOptions
Public objItems As ISpssItems
Public objItem As ISpssItem

Sub Main

	Dim ingNumber As Integer
	Dim retcode As Integer
	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

	Call DisplayYaDialog (strSpssVars)

	Call DisplayYsDialog (strSpssVars)

	Call Get_Rho()

End Sub
Sub Get_Rho()

	Dim i As Integer
	Dim j As Integer
	Dim k As Integer
    Dim Index As Long
    Dim objPivotTable As PivotTable
    Dim objLabels As ISpssLabels
    Dim objDataCells As ISpssDataCells

	' 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 strDat() As String
	ReDim strDat(lngNCases, 2)
	Dim ValidCase()
	ReDim ValidCase(lngNCases)
	Dim dYs() As Double
	Dim strTextDat As Variant
	Dim dYa() As Double
	Dim nValidCases As Long
	Dim nCases As Long
	Dim YaBar As Double
	Dim YsBar As Double
	Dim SumYaSq As Double
	Dim SumYsSq As Double
	Dim SumYaYs As Double
	Dim ResSq As Double


	'Get the variable of actual data

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

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

	'Get the variable of predicted values

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

	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 dYs(nValidCases)
	ReDim dYa(nValidCases)

	nCases = lngNCases
	lngNCases = nValidCases

	k = 0
	For i = 0 To nCases-1
		If ValidCase(i) = 1 Then
			dYa(k) = CDbl(strDat(i,0))
			dYs(k) = CDbl(strDat(i,1))
			k = k + 1
		End If
	Next i

	Dim T As Double
	T = CDbl(nValidCases)

	Dim Rho As Double

	YaBar = 0.0
	YsBar = 0.0
	SumYaSq = 0.0
	SumYsSq = 0.0
	ResSq = 0.0
	SumYaYs = 0.0

	For i = 0 To lngNCases
		YaBar = YaBar + dYa(i)
		YsBar = YsBar + dYs(i)
		SumYaSq = SumYaSq + dYa(i)*dYa(i)
		SumYsSq = SumYsSq + dYs(i)*dYs(i)
		ResSq = ResSq + (dYs(i) - dYa(i))*(dYs(i) - dYa(i))
		SumYaYs = SumYaYs + dYa(i)*dYs(i)
	Next i

	Dim SigmaYa As Double
	Dim SigmaYs As Double
	YaBar = YaBar/T
	YsBar = YsBar/T
	SigmaYa = Sqr((SumYaSq - T*YaBar*YaBar)/(T-1))
	SigmaYs = Sqr((SumYsSq - T*YsBar*YsBar)/(T-1))
	Rho = ((SumYaYs - YaBar*YsBar)/(T-1))/(SigmaYa*SigmaYs)
	Dim RMSError As Double
	Dim U As Double
	Dim Um As Double
	Dim Us As Double
	Dim Uc As Double
	RMSError = Sqr(ResSq/T)
	U = RMSError/(Sqr(SumYaSq/T)+Sqr(SumYsSq/T))
	Um = ((YaBar - YsBar)*(YaBar - YsBar))/(ResSq/T)
	Us = ((SigmaYa - SigmaYs)*(SigmaYa - SigmaYs))/(ResSq/T)
	Uc = 1.0 - Um - Us

	'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, 5, 1, 0)

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

    objPivotTable.TitleText = "Forecast Evaluation Statistics"
    objPivotTable.ShowTitle

    Set objLabels = objPivotTable.ColumnLabelArray
    objLabels.ValueAt(1,0) = "  "

    'Set the row labels
    Set objLabels = objPivotTable.RowLabelArray
    objLabels.ValueAt(0,1) = "rms Error"
    objLabels.ValueAt(1,1) = "Theil's U"
    objLabels.ValueAt(2,1) = "Theil's Um"
    objLabels.ValueAt(3,1) = "Theil's Us"
    objLabels.ValueAt(4,1) = "Theil's Uc"

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

	objDataCells.SelectCellAt (0, 0)
	objPivotTable.NumericFormat (strFormat, 6)
	objDataCells.ValueAt(0, 0) = CStr(RMSError)
	objPivotTable.ClearSelection
	objDataCells.SelectCellAt (1, 0)
	objPivotTable.NumericFormat (strFormat, 6)
	objDataCells.ValueAt(1, 0) = CStr(U)
	objPivotTable.ClearSelection
	objDataCells.SelectCellAt (2, 0)
	objPivotTable.NumericFormat (strFormat, 6)
	objDataCells.ValueAt(2, 0) = CStr(Um)
	objPivotTable.ClearSelection
	objDataCells.SelectCellAt (3, 0)
	objPivotTable.NumericFormat (strFormat, 6)
	objDataCells.ValueAt(3, 0) = CStr(Us)
	objPivotTable.ClearSelection
	objDataCells.SelectCellAt (4, 0)
	objPivotTable.NumericFormat (strFormat, 6)
	objDataCells.ValueAt(4, 0) = CStr(Uc)
	objPivotTable.ClearSelection

	Dim intWidth As Integer
	intWidth = 144

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

    objPivotTable.UpdateScreen=True
	objItem.Deactivate


End Sub
Sub DisplayYaDialog(strSpssVars() As String)

	Begin Dialog UserDialog 400,203,"Select Variable of Actual Values", .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"
			strYaSelected = 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
Sub DisplayYsDialog(strSpssVars() As String)

	Begin Dialog UserDialog 400,203,"Select Variable of Fitted Values", .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"
			strYsSelected = 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