Create pivot table-ROC

'Begin Description
'Purpose: 	Finds "Coordinates of the Curve" Pivot Table in the Desiganted Output
'			Copy the table To a table named "Coordinates (with test)"
'			Add a column to the new table, that table contains the numbers
'			Sensitivity + (1-(1-Specificity))			
'Assumptions: A designated output exists.
'End Description
'Raynald Levesque rlevesque@videotron.ca 2000/10/21
'Script level constant
Option Explicit
Const cNEWTABLE As String = "Coordinates (with test)"

'********************************************
Sub main()
' Locates all tables named "Coordinates of the Curve" 
' Call InsertROCTable after each find.

Dim objOutputDoc As ISpssOutputDoc
Dim objOutputItems As ISpssItems
Dim objOutputItem As ISpssItem
Dim objPivotTable As PivotTable
On Error GoTo errHand

'Continue only if an output document exists.
If objSpssApp.Documents.OutputDocCount > 0 Then
'Get the currently designated output document items collection.
	Set objOutputItems = objSpssApp.GetDesignatedOutputDoc.Items
	Else
	MsgBox "There are no Output window!"
    Exit Sub
End If

Dim intItemType 	As Integer  	    'type of item (see SpssType property)
Dim strLabel 		As String 	        'Item label
Dim intIndex 		As Integer			'index of current item 
Dim intMax 			As Integer			'Number of itme in Output Window

' Iterate through output items
' Call InsertROCTable if Type=PivotTable and Label="Coordinates of the Curve" 
	intIndex = 0	
	intMax = objOutputItems.Count()

	Do 
		Set objOutputItem = objOutputItems.GetItem(intIndex)
		intItemType = objOutputItem.SPSSType()
		strLabel = objOutputItem.Label

		If (intItemType = SPSSPivot) * (strLabel="Coordinates of the Curve") Then
			Set objPivotTable = objOutputItem.Activate()
		Debug.Print "In Sub Main: Call InsertROCTable";intIndex;strLabel;intMax

			Call InsertROCTable(objPivotTable,intIndex)
			objOutputItem.Deactivate
			intMax = intMax + 1			'There is now one more itme in the output window
			intIndex = intIndex + 1		'Skip the table which was just created
		End If
'		Debug.Print "In Sub Main: ";intIndex;strLabel;intMax
		intIndex = intIndex + 1
	Loop While intIndex < intMax

Exit Sub
errHand:
	MsgBox( "err= " &Err.Number &" Description= "&Err.Description,1,"MsgBox")
	Stop
End Sub


'*****************************************************
Sub InsertROCTable(objPivotTable0 As PivotTable,intIndex As Integer)
' This sub creates a new pivot table immediately after the table "Coordinates of the Curve"
' The new table has same dimensions as original PT but with 1 more column.

    Dim objOutputDoc 	As ISpssOutputDoc
    Dim objItems 		As ISpssItems
    Dim objItem 		As ISpssItem
    Dim objPivotTable 	As PivotTable				'The new table
    Dim objDataCells 	As ISpssDataCells		
    Dim objDataCells0 	As ISpssDataCells
    Dim objColumnLabels0 As ISpssLabels
    Dim objColumnLabels As ISpssLabels
    Dim objRowLabels0 	As ISpssLabels
    Dim objRowLabels	As ISpssLabels
    Dim objLayerLabels0 As ISpssLayerLabels
    Dim objLayerLabels 	As ISpssLayerLabels

    Dim objPivMgr 		As ISpssPivotMgr
    Dim objPivMgr0 		As ISpssPivotMgr
	Dim objLayerDim 	As ISpssDimension
	Dim objLayerDim0 	As ISpssDimension
	Dim objRowDim0 		As ISpssDimension

    Dim lngIndex	As Long					
    Dim intRow 		As Integer
    Dim intCol 		As Integer
    Dim intLay		As Integer
    Dim intR 		As Integer                      ' Loop Counter
    Dim intC 		As Integer                      ' Loop Counter
    Dim intL 		As Integer                      ' Loop Counter
    Dim nItems 		As Integer

	On Error GoTo errHandler
    Set objOutputDoc = objSpssApp.GetDesignatedOutputDoc

	Set objDataCells0 = objPivotTable0.DataCellArray
 	Set objPivMgr0 = objPivotTable0.PivotManager
	Set objLayerDim0 = objPivMgr0.LayerDimension(0)

	' Search for the Row dimension named "Test Result Variable(s)" and pivot it 
	' To the first layer dimension. There is certainly a way to avoid this
	' but I have not found it  :-(
	intRow = objPivMgr0.NumRowDimensions
	For intR = 0 To intRow -1 
		Set objRowDim0 = objPivMgr0.RowDimension(intR)
		If objRowDim0.DimensionName  = "Test Result Variable(s)" Then
			objRowDim0.MoveToLayer(0)
			Exit For
		End If
	Next

	'Get dimensions of original table
 	intLay = objLayerDim0.NumCategories
    intRow = objDataCells0.NumRows
    intCol = objDataCells0.NumColumns
	'	Debug.Print intRow;intCol;intLay	
    
    ' Insert a blank table with the required nb of rows, columns and layers
    ' The extra column is for the test column
 
    lngIndex = objOutputDoc.InsertTable( cNEWTABLE, intRow, intCol+1,intLay)
    Set objItems = objOutputDoc.Items
    ' Get and activate the new table
    Set objItem = objItems.GetItem(intIndex + 1)
    Set objPivotTable = objItem.Activate

    objPivotTable.UpdateScreen = False
	objPivotTable.TitleText = objPivotTable0.TitleText

	'Get info which is to be copied into the new objPivotTable
	Set ObjColumnLabels0 	= objPivotTable0.ColumnLabelArray() 

    ' Set column labels
    Set objColumnLabels = objPivotTable.ColumnLabelArray()
	objColumnLabels.ValueAt(0,0) = objColumnLabels0.ValueAt(0,0)
    For intC = 0 To intCol - 1
        objColumnLabels.ValueAt(1,intC) = objColumnLabels0.ValueAt(1,intC)
    Next
    ' Add label for the test column
    objColumnLabels.ValueAt(1,intCol) = "Sensitivity + (1-(1-Spec.))"

    ' Set layer dimension name
	 Set objPivMgr = objPivotTable.PivotManager
	 Set objLayerDim = objPivMgr.LayerDimension(0)
     objLayerDim.DimensionName = "Test Result Variable(s)"

With objDataCells0
	For intL = intLay -1 To 0 Step -1
	   	objLayerDim0.CurrentCategory = intL
	   	objLayerDim.CurrentCategory = intL
	    Set ObjLayerLabels0 	= objPivotTable0.LayerLabelArray() 
   		Set ObjLayerLabels 		= objPivotTable.LayerLabelArray() 

	    ' Set layer labels 
		objLayerLabels.ValueAt(0,2)=objLayerLabels0.ValueAt(0,2)
		'Get empty data cells of the layer of the new PivotTable
	    Set objDataCells = objPivotTable.DataCellArray
	    Set objDataCells0 = objPivotTable0.DataCellArray

		'Populate the new PivotTable
	    For intC = 0 To intCol
    	    For intR = 0 To intRow - 1
				If intC < intCol Then
				'Copy data from original table
          		objDataCells.ValueAt(intR,intC) = Format(.ValueAt(intR,intC),"#.000")
     		Else
     			'Calculate the new test column
 				objDataCells.ValueAt(intR,intC) = Format(.ValueAt(intR,intC-2)+1-.ValueAt(intR,intC-1),"#.000") 
				End If		
				objDataCells.SelectCellAt(intR, intC)
        	Next intR
      	Next intC
	Next intL
End With

    'set display format of selected cells to 3 decimal places
	objPivotTable.NumericFormat("#,###.##","3")

	' Search for the Layer dimension named "Test Result Variable(s)" and pivot it 
	' To the first row dimension:
	intLay = objPivMgr.NumLayerDimensions
	For intL = 0 To intLay -1 
		Set objLayerDim = objPivMgr.LayerDimension(intL)
		If objLayerDim.DimensionName  = "Test Result Variable(s)" Then
			objLayerDim.MoveToRow(0)
			Exit For
		End If
	Next

	For intL = 0 To intLay -1 
		Set objLayerDim0 = objPivMgr0.LayerDimension(intL)
		If objLayerDim0.DimensionName  = "Test Result Variable(s)" Then
			objLayerDim0.MoveToRow(0)
			Exit For
		End If
	Next
	
	'Refresh the 2 pivot table
    Set objItem = objItems.GetItem(intIndex)
    Set objPivotTable = objItem.Activate
 	objPivotTable.Autofit
    objPivotTable.UpdateScreen=True

    Set objItem = objItems.GetItem(intIndex+1)
    Set objPivotTable = objItem.Activate
 	objPivotTable.Autofit
    objPivotTable.UpdateScreen=True
    objItem.Deactivate

Exit Sub

errHandler:
	MsgBox ("err= " & Err.Number & " Description= " & Err.Description,1,"Error in CreatePivotTable(ROC)")
	Stop
End Sub