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