Ao mindranker.mmbas

'mindranker 24Feb08  http://creativecommons.org/licenses/by-sa/2.5/    http://www.activityowner.com ' 'changes 'try to find inconsistent answer ' ' Loop through the subtopics of the selected topic and weight/sort their importance using pairwise comparisons ' 'References ' Winston, Operations Research and Applications, 2nd Ed. 1991, "Decision Making with Multiple Objectives: Analytical Hierarchy Process", page 755 ' http://www.boku.ac.at/mi/ahp/ahptutorial.pdf ' http://en.wikipedia.org/wiki/Analytic_Hierarchy_Process ' Option Explicit Sub Main Const choicemax =10 Dim choices(choicemax) As String Dim rawchoicematrix(choicemax,choicemax) As Double Dim normchoicematrix(choicemax,choicemax) As Double Dim reporttopic As Topic Dim awt(choicemax) As Double Dim wt(choicemax) As Double Dim ri(choicemax) As Double Dim wmax(choicemax) As Double Dim diff(choicemax) As Double Dim ci As Double Dim swap As Double Dim answers As Integer Dim anscount As Integer Dim swapstring As String Dim parent As Topic Dim report As String Dim ChoiceCount As Integer Dim reverse As Boolean Dim maxdiff As Double Dim seconddiff As Double Dim maxdiffi As Integer Dim seconddiffi As Integer Dim amore As Boolean Dim more As String Dim less As String Dim i As Integer Dim j As Integer Dim sanswer As String Dim answer As Integer Dim total As Double

Set parent = ActiveDocument.Selection.PrimaryTopic If parent Is Nothing Then MsgBox("You must select a topic") Exit Sub End If	ChoiceCount=parent.AllSubTopics.Count If ChoiceCount > choicemax Then MsgBox("Maximum options exceeded-- You don't want to have to answer more than " & (ChoiceCount*ChoiceCount-ChoiceCount)/2 & "questions do you!") Exit Sub End If	If ChoiceCount<2 Then MsgBox("need more than 1 subtopic of selected topic in order to do comparisons") Exit Sub End If	For i=1 To ChoiceCount choices(i)=parent.AllSubTopics.Item(i).Text Next answers=(ChoiceCount*ChoiceCount-ChoiceCount)/2 If MsgBox("You will now answer " & answers & " questions comparing your " & ChoiceCount & " factors to each other",vbOkCancel, "Pairwise Comparison Tool")=vbCancel Then Exit Sub

anscount=0 For i=1 To ChoiceCount For j=i To ChoiceCount If i=j Then rawchoicematrix(i,j)=1 Else anscount=anscount+1 amore=MsgBox("Is [" & choices(i) & "] more important than [" & choices(j) &"]?",vbYesNo,"Answer Yes for Same (" & anscount & "/" & answers)=vbYes				If amore Then					more = choices(i)					less = choices(j)				Else					more = choices(j)					less = choices(i)				End If				sanswer=InputBox("1: equal " & vbCrLf & _ "3: weakly more " & vbCrLf & _ "5:strongly more" & vbCrLf & _ "7: very strongly" & vbCrLf & _ "9 absolutely more","How important is " & more & " than " & less &"?")				If sanswer="" Then					Exit Sub				End If				answer=Val(sanswer)				If amore Then					rawchoicematrix(i,j)=answer					rawchoicematrix(j,i)=1/answer				Else					rawchoicematrix(i,j)=1/answer					rawchoicematrix(j,i)=answer				End If			End If		Next	Next

For j = 1 To ChoiceCount total=0 For i = 1 To ChoiceCount total = rawchoicematrix(i,j)+total Next For i = 1 To ChoiceCount normchoicematrix(i,j)=rawchoicematrix(i,j)/total Next Next For i=1 To ChoiceCount wmax(i)=0 For j=1 To ChoiceCount wmax(i)=normchoicematrix(i,j)+wmax(i) Next wmax(i)=wmax(i)/ChoiceCount Next

Debug.Clear 'check consistency here some day sum i Aw^t / w^t ci=0 For i =1 To ChoiceCount awt(i)=0 For j = 1 To ChoiceCount awt(i) = rawchoicematrix(i,j)*wmax(j)+awt(i) Next ci=ci+awt(i)/wmax(i)/ChoiceCount diff(i)=Abs(awt(i)-wmax(i)*ChoiceCount) Debug.Print "Aw^t = " & Round(awt(i),3) & " : n*w(t) =" & Round(wmax(i)*ChoiceCount,3) & " : diff " & Round(diff(i),3) Next maxdiff=0 For i=1 To ChoiceCount If diff(i)>maxdiff Then maxdiff=diff(i) maxdiffi = i		End If	Next seconddiff=maxdiff For i=1 To ChoiceCount If diff(i)2 Then If ci/ri(ChoiceCount)<0.1 Then report=report & vbCrLf & "Your answers seem consistent" Else report=report & vbCrLf & "Your answers seem inconsistent."

If ChoiceCount>3 Then answers = rawchoicematrix(maxdiffi,seconddiffi) If answers <1 Then reverse=True answers=1/answers Else reverse = False End If 				If answers=1 Then sanswer="equally" If answers=3 Then sanswer="weakly more" If answers=5 Then sanswer="strongly more" If answers=7 Then sanswer="very strongly more" If answers=9 Then sanswer="absolutely more" If Not reverse Then report = report & vbCrLf & "Are you sure that [" & choices(maxdiffi) & " is " & sanswer & " important than [" & choices(seconddiffi) & "]?" Else report = report & vbCrLf & "Are you sure that [" & choices(seconddiffi) & "] is " & sanswer & " important than [" & choices(maxdiffi) & "]?" End If	 		End If	 	End If	 End If

'sort responses For i=1 To ChoiceCount-1 'sort rows For j=i+1 To ChoiceCount If wmax(i)<wmax(j) Then swap=wmax(i) swapstring=choices(i) wmax(i)=wmax(j) choices(i)=choices(j) wmax(j)=swap choices(j)=swapstring End If     Next Next If parent.AllCalloutTopics.Count=0 Then Set reporttopic=parent.AllCalloutTopics.Add Else Set reporttopic= parent.AllCalloutTopics.Item(1) End If	reporttopic.Text=report '	'Clean up	Set reporttopic=Nothing Set parent=Nothing End Sub