'#Reference {C9E2900E-3D45-11D4-9FF4-00C04FA0D540}#1.0#0#C:\IV6\STA_NON.DLL#STATISTICA 6.0 Nonparametrics Library
'This program performs nonparametric multiple comparisons.
'It uses the output from Friedman ANOVA by Ranks, either testing the
'Average Rank (in Column 1) or the Sum of Ranks (in Column 2).
'The test compares the absolute value of the differences for all pairs
'with a critical value which is determined using a normal approximation
'with suitable adjustment of alpha to take the multiple comparisons
'into account.

Option Explicit
Option Base 1

Const ERR_OUTOFBOUNDS = 10023

Sub Main

	Dim s As Spreadsheet

	'Get the spreadsheet to be reviewed
	Dim Choosen As Long
	Choosen = DisplaySpreadsheetsCollection()

	'no spreadsheets open or user pressed cancel button
	If Choosen = 0 Then Exit Sub

	Dim RankType As Byte
	Dim RetVal
	Dim Friedman As Spreadsheet

	On Error GoTo NoSpreadsheet'if output is in a workbook

	'get a pointer to the output spreadsheet
	Set Friedman = Spreadsheets.Item(Choosen)


	If Friedman.InputSpreadsheet Then
		MsgBox Friedman.Name + " is not an output spreadsheet"
		Exit Sub
	End If


	RetVal = MsgBox("This program runs on the Friedman ANOVA by Ranks results." _
		& vbCrLf & "This must be the top, individual spreadsheet on the screen." & vbCrLf & _
		"If the target spreadsheet is in a workbook, then please extract it.",vbOkCancel Or vbInformation,"Nonparametric Multiple Comparisons")
	'Nevermind, please exit
	If RetVal = vbCancel Then Exit Sub


	'Get the type of rank
	Begin Dialog UserDialog 280,70,"Type of Test" ' %GRID:10,7,1,1
		OptionGroup .Group
			OptionButton 20,7,160,28,"Average rank",.Averagerank
			OptionButton 20,35,140,21,"Sum of ranks",.Sumofranks
		PushButton 190,7,80,21,"OK",.OKBUTTON
	End Dialog
	Dim dlg As UserDialog
	Dialog dlg

	Select Case dlg.group
		Case 0
			RankType = 0 'Average Rank
		Case 1
			RankType = 1 'Sum of Ranks
	End Select
	'got type of rank


	Dim Alpha As Double
	Alpha = .05


	RetVal = "" 'null string

	'get the overall signifigance
	Do
	RetVal = InputBox("Please enter the overall significance level","Significance Level",Str(Alpha))
		'either blank entry or cancel was pressed
		If RetVal = "" Then
			Dim YesOrNo As Byte
			YesOrNo = MsgBox("Do you wish to exit",vbQuestion Or vbYesNo)
			If YesOrNo = vbYes Then Exit Sub
		End If
	Loop Until RetVal <> "" And IsNumeric(RetVal)

	Alpha = CDbl(RetVal)

	If Alpha > 1 Or Alpha < 0 Then
		MsgBox ("The signifigance level specified is out of the preferable" + vbCrLf + _
		"boundary range. Your results may be invalid.")
	End If


	'get number of observations from the output spreadsheet
	Dim Observations As Integer
	Dim TempString As String
	Dim StringIndex As Integer
	Dim FullString As String
	Dim FullStringLen As Integer


	FullString = Friedman.Header.Value

	StringIndex = InStr(1,FullString,"N = ")

	If StringIndex <> 0 Then

		FullStringLen = Len(FullString)

		FullStringLen = FullStringLen - (StringIndex + 3)
		'chop off everything on the left
		TempString = Right(FullString,FullStringLen)
		FullString = TempString

		'find the comma
		StringIndex = InStr(1,FullString,",")
		'N=0
		If StringIndex = 0 Then
			MsgBox("Invalid number of observations.")
			Exit Sub
		End If
		'trim off the comma and everything afer it
		TempString = Left(FullString,StringIndex - 1)'get rid of the comma
		Observations = CInt(TempString)
	Else

		RetVal = InputBox("The observation number could not be found from the output spreadsheet." + _
		"Please enter the observation number:","Invalid Observations","10")
		If CInt(RetVal) <= 0 Then
			MsgBox("Invalid number of observations")
			Exit Sub
		End If
		Observations = CInt(RetVal)
	End If


	'got Observations

	'get the number of groups of the output file
	Dim NumOfGroups As Integer
	NumOfGroups = Friedman.Cases.Count

	Dim Diff() As Double
	ReDim Diff(NumOfGroups,NumOfGroups)

	'calculate the Z-Score
	Dim ZScore As Double

	ZScore = Abs(VNormal(1-(Alpha/(NumOfGroups*(NumOfGroups-1))), 0, 1))

	'calculate the correct critical value for the chosen test
	Dim Critical As Double

	If RankType = 0 Then
		Critical = ZScore*Sqr((NumOfGroups*(NumOfGroups+1))/(6*Observations))
	ElseIf RankType = 1 Then
		Critical = ZScore*Sqr((Observations*NumOfGroups*(NumOfGroups+1))/6)
	End If

	'loop through the comparisons
	Dim Val1 As Double,Val2 As Double
	Dim i As Integer, j As Integer
	For i = 1 To (NumOfGroups-1)
		For j = (i+1) To NumOfGroups
			'ScrollsheetGetValue(CLng(Friedman),i,(RankType + 1),Val1)
			Val1 = Friedman.Cells(i,(RankType + 1)).Value
			'ScrollsheetGetValue(CLng(Friedman), j,(RankType + 1), Val2)
			Val2 = Friedman.Cells(j,(RankType + 1)).Value
			Diff(i,j) = Abs(Val1-Val2)
			Diff(j,i) = Diff(i,j)
		Next j
	Next i

	'get the titles for the outputspreadsheet
	Dim TempName$,FullNames$

	For i= 1 To NumOfGroups
		'ScrollsheetGetRowName (CLng(Friedman), i, TempName$)
		TempName$ = Friedman.Case(i).RowName
		FullNames$ = FullNames$ + TempName$
		If i < NumOfGroups Then FullNames$ = FullNames$ + "|"
	Next i

	'create new title
	Dim TitleOfNew$

	If RankType = 0 Then
		TitleOfNew$ = "Absolute Differences between Average Rank" + _
			"Approx. significant if > " + Str(Critical) + _
			"|at " + Str(Alpha) + " significance level"
	ElseIf RankType = 1 Then
		TitleOfNew$ = "Absolute Differences between Sum of Ranks" + _
			"|Approx. significant if > " + Str(Critical) + _
			"|at " + Str(Alpha) + " significance level"
	End If


	'create the spreadsheet
	Dim Results As Spreadsheet
	Set Results = 	NewSpreadsheet(NumOfGroups, NumOfGroups, Diff(), _
				TitleOfNew$, FullNames$, FullNames$)

	'highlight the values above the critical value
	For i = 1 To NumOfGroups
		For j = 1 To NumOfGroups
			If Diff(i,j) > Critical Then Call SpreadsheetSetHilite(Results, i, j, 1)
			If i = j Then Results.Cells(i, j) = "---"
		Next j
	Next i

	'probably in a workbook
	Exit Sub
	NoSpreadsheet:
	MsgBox Err.Description

End Sub

Function DisplaySpreadsheetsCollection() As Long 'returns number of spreadsheets open

	Dim i As Integer
	Dim SpreadsheetsString As String

	If Spreadsheets.Count Then
		For i = 1 To Spreadsheets.Count
					SpreadsheetsString = SpreadsheetsString & "|" & Spreadsheets.Item(i).Name
		Next i
	Else
		SpreadsheetsString = "No spreadsheets are open"
	End If

	'get rid of the "|" at the beginning of the string
	SpreadsheetsString = Mid(SpreadsheetsString,2,Len(SpreadsheetsString))

	DisplaySpreadsheetsCollection = _
				DisplayListBox("Spreadsheet For Post Hoc For Friedman",SpreadsheetsString,1)

End Function

Function GetSum(Vector() As Double) As Double

	Dim TotalVal As Double
	Dim i As Integer
	For i = LBound(Vector()) To UBound(Vector())
			TotalVal = TotalVal + Vector(i)
	Next i

	GetSum = TotalVal

End Function

Function NewSpreadsheet(ByVal NRows As Long, ByVal NCols As Long, ByRef A() As Double, _
						ByVal STitle As String, ByVal RowNames As String, _
						ByVal ColNames As String) As Spreadsheet

	Dim i As Long
	Dim j As Long

	Dim s As New Spreadsheet
	If NCols <= 0 Then
		NCols = ArrGetNCols (A)
	End If
	If NRows <= 0 Then
		NRows = ArrGetNRows (A)
	End If

	s.SetSize NRows, NCols
	s.InputSpreadsheet = False

	Dim sss As String
	If ColNames <> "" Then
		For i=1 To NCols
			Call GetDelimitedString (ColNames, i, sss)
			If sss <> "" Then
				s.VariableName (i) = sss
			End If
		Next i
	End If
	If RowNames <> "" Then
		For i=1 To NRows
			Call GetDelimitedString (RowNames, i, sss)
			If sss <> "" Then
				s.CaseName (i) = sss
			End If
		Next i
	End If

	If IsArr1Dim (A) Then


		For j=1 To NCols
			s.Value (1,j) = A(LBound(A)+j-1)
		Next j
	Else
		For i=1 To NRows
			For j=1 To NCols
				s.Value (i,j) = A(LBound(A,1)+i-1,LBound(A,2)+j-1)
			Next j
		Next i
	End If

	If STitle <> "" Then
		Dim sFirst As String
		Dim sRest  As String
		Call GetDelimitedString (STitle, 1, sFirst)
		sRest = sFirst
		For i=2 To 5
			Call GetDelimitedString (STitle, i, sss)
			If sss <> "" Then
				If (sRest <> "") Then
					sRest = sRest + vbCrLf
				End If
				sRest = sRest + sss
			End If
		Next i
	End If

	s.Header.Value = sRest
	s.EntireRange.AutoFit
	s.AutoFitCase
	s.Visible = True
	s.Saved = True
	Set NewSpreadsheet = s

End Function

Sub GetDelimitedString (ByVal Param1 As String, ByVal Param2 As Integer, ByRef Param3 As String)
							   'Param1 is input string
							   'Param2 is the number of item to get
							   'Param3 is the string to store the extracted string


	Dim Pos As Long	'The position of the delimiting char
	Dim StartPos As Long 	'the start of the string to be extracted
	Dim StrLength As Long
	Dim i As Long
	Dim LoopPos As Long
	Dim endPos As Long
	Dim NumOfZero As Long
	Const DelimChar As String = "|"

	LoopPos = 1
	StartPos = 1
	StrLength= Len(Param1)

	For i = 1 To Param2
		Pos = InStr(LoopPos, Param1, DelimChar)
			endPos = Pos -1
			StartPos = LoopPos
			LoopPos = Pos +1
			If Pos = 0 Then NumOfZero = NumOfZero + 1

			If Pos = 0 And (i > 1 And i < Param2)   Then 'for string with less items than called for

				Param3 = ""
				Exit Sub

			End If

	Next i

	If (Pos = 0 And StartPos = 1) Then		'for string without a delimited charactor
		If NumOfZero > 1  Then
			Param3 = ""
		Else

			Param3 = Param1
		End If

	ElseIf (Pos = 0 And StartPos > 1) Then		'for the end of the string

		Param3 = Mid( Param1, StartPos , StrLength - (StartPos-1) )

	Else

		Param3 = Mid(Param1, StartPos, (Pos)-StartPos)

	End If

End Sub

Sub SpreadsheetSetHilite(	spr As Spreadsheet, ByVal row As Long, ByVal col As Long, _
							ByVal State As Integer)
	Dim r As Range
	Set r = spr.Cells(row,col)
	If State = 1 Then
		r.AddToMarked
		spr.DisplayAttribute(scDisplayMarkedCells) = True
	Else
		r.RemoveFromMarked
	End If

End Sub

Function IsArr1Dim (ByRef m() As Double) As Boolean

	Dim d As Long

	On Error GoTo ONEDIM
	d = UBound(m,2)
	IsArr1Dim = False
	Exit Function
ONEDIM:
	If Err.Number = ERR_OUTOFBOUNDS Then
		IsArr1Dim = True
	Else	'some other error - let VB handle it:
		Err.Raise Err.Number
	End If
End Function

Function ArrGetNRows (ByRef m() As Double) As Long
	If IsArr1Dim (m) Then
		ArrGetNRows = UBound(m,1) - LBound(m,1) + 1
	Else
		ArrGetNRows = UBound(m,1) - LBound(m,1) + 1
	End If
End Function

Function ArrGetNCols (ByRef m() As Double) As Long
	If IsArr1Dim (m) Then
		ArrGetNCols = 1
	Else
		ArrGetNCols = UBound(m,2) - LBound(m,2) + 1
	End If
End Function

'STATISTICA MACRO FILE VERSION 4
'BEGINPROPERTIES
'NAME=Post Hoc For Friedman
'DESCRIPTION=
'LANGUAGE=0
'ENDPROPERTIES