1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228 | 'Begin Description
'Назначение: В назначенном окне результатов скрипт ищет мобильную таблицу "Coordinates of the Curve" (координаты кривых)
' (результат ROC-анализа). В случае нахождения - создаёт новую таблицу, называет её
' "Coordinates (with test)", копирует туда содержимое найденной таблицы и дополняет
' новую таблицу столбцом со статистикой Sensitivity + (1-(1-Specificity)).
'Условия: нужные таблицы находятся в назначенном окне результатов.
'End Description
'Автор: Raynald Levesque, rlevesque@videotron.ca, 21.10.2000.
'Размещение: http://www.spsstools.ru/Scripts/PivotTables/CreatePivotTable-ROCsbs.txt (.sbs).
'Перевод: А. Балабанов, 11.01.2009.
'Проверено: SPSS 15.0.0.
'Константы уровня скрипта
Option Explicit
Const cNEWTABLE As String = "Coordinates (with test)"
'********************************************
Sub main()
' Поиск всех таблиц с названием "Coordinates of the Curve"
' Вызов процедуры InsertROCTable для каждой найденной таблицы.
Dim objOutputDoc As ISpssOutputDoc
Dim objOutputItems As ISpssItems
Dim objOutputItem As ISpssItem
Dim objPivotTable As PivotTable
On Error GoTo errHand
'Продолжаем выполнение программы только если есть окно результатов
If objSpssApp.Documents.OutputDocCount > 0 Then
'Установление ссылки на коллекцию объектов из назначенного (designated) окна результатов
Set objOutputItems = objSpssApp.GetDesignatedOutputDoc.Items
Else
MsgBox "Не найдено окно результатов!"
Exit Sub
End If
Dim intItemType As Integer 'тип объекта (см. свойство SpssType)
Dim strLabel As String 'метка объекта
Dim intIndex As Integer 'индекс (порядковый номер) объекта
Dim intMax As Integer 'число объектов в окне результатов (Output Window)
' Пробежка по всем объектам
' Вызов процедуры InsertROCTable, если тип объекта - PivotTable, а метка - "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 "В процедуре Main: вызов InsertROCTable";intIndex;strLabel;intMax
Call InsertROCTable(objPivotTable,intIndex)
objOutputItem.Deactivate
intMax = intMax + 1 '(после отработки процедуры в окне стало на 1 объект больше)
intIndex = intIndex + 1 'пропуск только что созданной таблицы
End If
' Debug.Print "В процедуре Main: ";intIndex;strLabel;intMax
intIndex = intIndex + 1
Loop While intIndex < intMax
Exit Sub
errHand:
MsgBox( "Ошибка: " &Err.Number &" Описание: "&Err.Description,1,"Ошибка в скрипте CreatePivotTable(ROC)")
Stop
End Sub
'*****************************************************
Sub InsertROCTable(objPivotTable0 As PivotTable,intIndex As Integer)
' Процедура создаёт новую таблицу сразу после таблицы "Coordinates of the Curve".
' Новая таблица имеет размер найденной таблицы, увеличенный на 1 колонку.
Dim objOutputDoc As ISpssOutputDoc
Dim objItems As ISpssItems
Dim objItem As ISpssItem
Dim objPivotTable As PivotTable 'Новая таблица
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 ' Счётчик цикла
Dim intC As Integer ' Счётчик цикла
Dim intL As Integer ' Счётчик цикла
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)
' Поиск размерности строк с меткой "Test Result Variable(s)", и поворот размерности в
' размерность первого слоя. Наверняка этой операции можно избежать, но я не нашёл, как :-(
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
'Определение размеров исходной таблицы
intLay = objLayerDim0.NumCategories
intRow = objDataCells0.NumRows
intCol = objDataCells0.NumColumns
' Debug.Print intRow;intCol;intLay
' Вставляем пустую таблицу с требуемым количеством строк, столбцов, слоев
' Дополнительная колонка - для информации о тесте
lngIndex = objOutputDoc.InsertTable( cNEWTABLE, intRow, intCol+1,intLay)
Set objItems = objOutputDoc.Items
' установление ссылки и активация новой таблицы
Set objItem = objItems.GetItem(intIndex + 1)
Set objPivotTable = objItem.Activate
objPivotTable.UpdateScreen = False
objPivotTable.TitleText = objPivotTable0.TitleText
'получение информации, которая должна быть скопирована в новую таблицу (objPivotTable)
Set objColumnLabels0 = objPivotTable0.ColumnLabelArray()
' Установка меток столбцов
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
' Добавление метки к последнему столбцу
objColumnLabels.ValueAt(1,intCol) = "Sensitivity + (1-(1-Spec.))"
' Установка метки размерности слоев
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()
' Установка меток для отдельных слоев
objLayerLabels.ValueAt(0,2)=objLayerLabels0.ValueAt(0,2)
'Получение ссылки на пустые ячейки данных в новой таблице
Set objDataCells = objPivotTable.DataCellArray
Set objDataCells0 = objPivotTable0.DataCellArray
'Заполнение данными новой таблицы
For intC = 0 To intCol
For intR = 0 To intRow - 1
If intC < intCol Then
'Копируем данные из исходной таблицы
objDataCells.ValueAt(intR,intC) = Format(.ValueAt(intR,intC),"#.000")
Else
'Вычисление новой колонки с тестом
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
'установка формата отображения с 3 знаками после запятой
'### Текстовый формат в оригинальном коде ("3") исправлен на числовой (3) - А.Б.
objPivotTable.NumericFormat("#,###.##",3)
' Поиск размерности слоёв с меткой "Test Result Variable(s)" и поворот её
' в первую размерность строк:
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
'Обновление (перерисовка с автоподгонкой) обеих таблиц
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.Number & " Описание: " & Err.Description,1,"Ошибка в скрипте CreatePivotTable(ROC)")
Stop
End Sub
|