Ao mindranker.mmbas

From ActivityOwnerWiki
Jump to: navigation, search
'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)<seconddiff And Not i=maxdiffi Then
			seconddiffi=i
			seconddiff=diff(i)
		End If
	Next
	ci = (ci-ChoiceCount)/(ChoiceCount-1)

	'perfect consistency : ci=0
	ri(2)=0
	ri(3)=0.58
	ri(4)=0.90
	ri(5)=1.12
	ri(6)=1.24
	ri(7)=1.32
	ri(8)=1.41
	ri(9)=1.45
	ri(10)=1.51



	report= "Relative Ratings of Importance"
	For i=1 To ChoiceCount
		report=report & vbCrLf & Round(wmax(i),2) & " : " & choices(i)
	Next
	If ChoiceCount>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