Sub Main
'I assume you call your dependent variable as "depend" (no quotation marks)
'I assume you independent vars named as "var00001 ... var00010 ... " (default for SPSS)
Const Nvar = 6 ' enter the number of independent variables (1-13 for the exemplar dataset), entering Nvars >22 is prohibitive because of the large number of combinations, e. g., 2^ Nvars -1 (this number may be slightly reduced if SubSetMin and SubSetMax are modified)
Const DepRange ="1 2" 'Only for CVA: if you have 2 groups coded as 1 and 2 then write "1 2"
Dim CountOff()
Dim MaxOff()
Dim Ar()
Dim CombString As Variant
Dim SepChar As String, a As String, d As String, ds1 As String, ds2 As String
Dim NewComb As String, NewComb1 As String, Comp1 As String, LR As Boolean, LNTr As Boolean, ExternValid As Boolean, DoSizeCorrection As Boolean, SelectSet As String, Prt As Boolean, z As Integer
Dim NumOfComb As Long
Dim Dummy
Dim SubSet As Long
Dim SubSetMax As Long, SubSetMin As Long
Dim NumOfElements As Long
Dim Counter1 As Long
Dim Counter2 As Long
Dim Counter3 As Long, StartRange As Long, EndRange As Long, rng As String
Dim R As Variant
'modify this array accordingly to include more variables
R = Array("", "01", "02", "03", "04", "05", "06", "07", "08", "09", 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)
NumOfElements = Nvar
CombString = R
'****Define variables
LR=False ' enter False if you are running CVA, if logistic regression then True
SubSetMin = 1 'min number of variables in subsets (from 1 to Nvar)
SubSetMax = 6 'max number of variables in subsets (less or equal to Nvar)
LNTr = False ' do logarithmic (LN) transformation?
DoSizeCorrection = False 'enter True if you want Darroch and Mosimann (1985) size correction (MORPHOMETRIC DATA ONLY!), otherwise enter False
'*****Partitioning large samples
StartRange=1 '( from 1 to n) starts with specified number of samples (Work-around of large analyses SPSS problem)
EndRange=9000 'ends after specified number (Work-around of large analyses SPSS problem)
Prt=False ' true/false, enter true if you want to deploy the above two variables
Counter3=0
rng= SubSetMin & "-" & SubSetMax
If SubSetMin = SubSetMax Then rng = "" & SubSetMin
If Prt Then rng=rng & "_" & StartRange & "-" & EndRange
'*****Partitioning large samples end
'*** External validation
ExternValid=True 'True If you do external validation
SelectSet=vbCrLf & "/SELECT=val(0)" 'code for the analysis (CVA) subset (here 0); a variable (here val) defining the internal and external dataset must be created in your datamatrix
If LR Then SelectSet=vbCrLf & "/SELECT = val EQ 0" 'code for the analysis (LR) subset (here 0); a variable (here val) defining the internal and external dataset must be created in your datamatrix
If ExternValid=False Then SelectSet=""
'*** end External validation
ds1 = "DISCRIMINANT" & vbCrLf & "/GROUPS=depend(" & DepRange & ")" & vbCrLf & "/VARIABLES="
ds2 = SelectSet & vbCrLf & "/ANALYSIS All" & vbCrLf & "/PRIORS EQUAL" & vbCrLf & "/STATISTICS=CROSSVALID" & vbCrLf & "/CLASSIFY=NONMISSING POOLED ." & vbCrLf & "EXECUTE." & vbCrLf
oms = "OMSLOG FILE='log.txt' /FORMAT=TEXT." & vbCrLf & "oms" & vbCrLf & "/desination VIEWER = NO /TAG='suppressall'." & vbCrLf & "OMS /select tables" & vbCrLf & "/IF COMMANDS = ['Discriminant']" & vbCrLf & "SUBTYPES = ['Classification Results' 'Notes']" & vbCrLf & "/desination format = tabtext outfile = 'subsets" & rng & ".txt'."
SepChar = ","
If LR Then
ds1 = "LOGISTIC REGRESSION depend" & SelectSet & vbCrLf & "/METHOD = ENTER "
ds2 = vbCrLf & "/CLASSPLOT" & vbCrLf & "/PRINT = SUMMARY" & vbCrLf & "/CRITERIA = PIN(.05) POUT(.10) ITERATE(20) CUT(.5) ." & vbCrLf & "Execute." & vbCrLf
oms = "OMSLOG FILE='log.txt' /FORMAT=TEXT." & vbCrLf & "oms" & vbCrLf & "/desination VIEWER = NO /TAG='suppressall'." & vbCrLf & "OMS /select tables" & vbCrLf & "/IF COMMANDS = ['Logistic Regression']" & vbCrLf & "SUBTYPES = ['Classification Table' 'Notes']" & vbCrLf & "/desination format = tabtext outfile = 'LR_subsets" & rng & ".txt'."
SepChar = ","
End If
'*****************' write to syntax window
''Dim objSyntaxDoc As ISpssSyntaxDoc
''Dim strSynCmd As String
''Set objSyntaxDoc=objSpssApp.GetDesignatedSyntaxDoc
'****************
''objSyntaxDoc.Text = oms
objSpssApp.ExecuteCommands oms, True
'Debug.Print oms
'Stop
For i = SubSetMin To SubSetMax 'prints all subsets of given range of length
SubSet = i
NumOfComb = Comb(NumOfElements, SubSet)
ReDim CountOff(SubSet)
ReDim MaxOff(SubSet)
For Counter1 = 1 To SubSet
CountOff(Counter1) = Counter1
MaxOff(Counter1) = NumOfElements - SubSet + Counter1
Next Counter1
For Counter1 = 1 To NumOfComb
NewComb = "": NewComb1=""
ReDim Ar(SubSet)
For Counter2 = 1 To SubSet
s1=CombString(CountOff(Counter2)): NewComb = NewComb & s1 & SepChar: NewComb1= NewComb1 & "var000" & s1 & " * "
Ar(Counter2)= s1
Next Counter2
Counter3=Counter3+1
If Prt =False Or (Prt = True And Counter3>=StartRange And Counter3 <=EndRange) Then
Debug.Print Counter3
NewComb1=Left(NewComb1, Len(NewComb1) - 3) & nc1(SubSet,LNTr)
'Debug.Print "NewComb1: " & NewComb1
a="": d=""
lnt="":lnt2="."
If LNTr Then
lnt="LN(": lnt2=")."
End If
For z=1 To SubSet
If DoSizeCorrection=True Then a=a & vbCrLf & nc1a(SubSet,Ar(z),LNTr) & NewComb1
If DoSizeCorrection=False Then a = a & vbCrLf & "COMPUTE v" & Ar(z) & " = " & lnt & "var000" & Ar(z) & lnt2
d=d+ "v" & Ar(z) & " "
Next z
a= a & vbCrLf & "EXECUTE." & vbCrLf
a= a & ds1 & d & ds2
'Debug.Clear
'Debug.Print a
'Stop
''objSyntaxDoc.Text = objSyntaxDoc.Text & a
objSpssApp.ExecuteCommands a, True
End If
CountOff(SubSet) = CountOff(SubSet) + 1
Dummy = SubSet
While Dummy > 1
If CountOff(Dummy) > MaxOff(Dummy) Then
CountOff(Dummy - 1) = CountOff(Dummy - 1) + 1
For Counter2 = Dummy To SubSet
CountOff(Counter2) = CountOff(Counter2 - 1) + 1
Next Counter2
End If
Dummy = Dummy - 1
Wend
Next Counter1
Next i ' end prints all subsets of given length
objSpssApp.ExecuteCommands vbCrLf & "omsend.",True
''objSyntaxDoc.Text = objSyntaxDoc.Text & vbCrLf & "omsend."
If Prt Then
Dim EndRangeReal As Long, dn As String
If Counter3 > EndRange Then EndRangeReal = EndRange: dn = "Next suggested StartRange is " & EndRangeReal+1
If Counter3 <= EndRange Then EndRangeReal = Counter3: dn = "Current subset is done"
MsgBox "Output includes samples: " & StartRange & "-" & EndRangeReal & vbCrLf & dn
End If
Beep
End Sub
Sub test
MsgBox Comb(5, 2)
'MsgBox FactorialCalc(1)
End Sub
Function Comb(N, k)
'N must be >=1, k must be <=1 and <= N
If N = k Then
Comb = 1
Else
Comb = FactorialCalc(N) / (FactorialCalc(k) * FactorialCalc(N - k))
End If
End Function
Function FactorialCalc(N)
Factorial = 1
For i = 1 To N
Factorial = Factorial * i
Next i
FactorialCalc = Factorial
End Function
Function nc1(SubSet,LNTr)
lnt=""
If LNTr Then
lnt=")"
End If
If SubSet > 1 Then
nc1 = ") ** (1/" & SubSet & "))" & lnt & "."
Else
nc1 = lnt & "."
End If
'Debug.Print "nc1:" & nc1
End Function
Function nc1a(SubSet,v,LNTr)
lnt=""
If LNTr Then
lnt="LN("
End If
If SubSet > 1 Then
nc1a = "COMPUTE v" & v & " = " & lnt & "var000" & v & "/(("
Else
nc1a="COMPUTE v" & v & " = " & lnt
End If
'Debug.Print "nc1a:" & nc1a
End Function