'Begin Description 'Create random variables. 'This script generates random number variables out of normal or uniform distributions 'and either adds them to the existing working file or creates a new file. 'Optionally can produce variables correlated, skewed, with missing values, etc. ' 'SPSS script by Kirill Orlov 'Version 1, Jan 2006 'kior@comtv.ru; orlovk@ri-vita.ru 'http://ri-vita.ru/consulting/stats/ 'End Description Option Explicit Public objDocuments As ISpssDocuments Public objDataDoc As ISpssDataDoc Sub Main Begin Dialog UserDialog 260,384,"Create Random Variables",.dlgfunc ' %GRID:10,3,0,1 Text 10,12,140,15,"Number of Variables:",.Text1 Text 10,318,90,27,"Start Name: (prefix+index)",.Text7 Text 10,30,120,15,"Number of Cases:",.Text2 TextBox 160,9,60,18,.nvars TextBox 120,321,100,18,.firstnam TextBox 160,27,60,18,.ncases OKButton 10,357,80,21,.ok GroupBox 10,72,240,126,"Distribution",.GroupBox1 TextBox 160,99,60,18,.mean TextBox 160,150,60,18,.min TextBox 160,168,60,18,.max TextBox 160,117,60,18,.stdev OptionGroup .distrib OptionButton 40,87,90,15,"Normal",.OptionButton1 OptionButton 40,138,90,15,"Uniform",.OptionButton2 Text 90,102,50,15,"Mean:",.Text3 GroupBox 10,201,240,108,"Alterations",.GroupBox2 TextBox 160,279,60,18,.exmax Text 90,153,50,15,"Min:",.Text5 Text 90,171,50,15,"Max:",.Text6 TextBox 160,261,60,18,.exmin Text 90,282,50,15,"Max:",.Text9 Text 90,264,50,15,"Min:",.Text8 Text 90,120,60,15,"Std Dev:",.Text4 CheckBox 160,231,80,15,"Integers",.integers CheckBox 10,48,210,15,"Replace the working data file",.newfile CancelButton 90,357,80,21 CheckBox 20,216,90,15,"Correlated",.corr PushButton 170,357,80,21,"Help",.help CheckBox 160,216,80,15,"Missing",.missval CheckBox 20,231,90,15,"Skewed",.skew CheckBox 20,246,120,15,"Exact Range",.exrange End Dialog Dim dlg As UserDialog Dim NCASES As String Dim prefix As String,firstind As String,LASTNAM As String Dim strRnd As String,strRnd1 As String,FRMT As String Dim strInputProg As String,strLoopCase As String,strEndCase As String,strEndLoop As String,strEndFile As String,strEndInputProg As String Dim INIDISTR As String,EDISTR As String,SDE As String,SDNEED As String,SDNEED1 As String,MEANNEED As String Dim DISTR As String,bounds As String Dim strM As String,strLoopMiss As String,strMissRand As String,strMissMiss As String,strEndLoopMiss As String Dim strCommand As String Dim i As Long dlg.nvars= "10" dlg.ncases= "100" dlg.mean= "0" dlg.stdev= "1" dlg.min= "0" dlg.max= "1" dlg.exmin= "1" dlg.exmax= "5" dlg.firstnam= "V1" dlg.newfile= True If Dialog(dlg)=0 Then Exit Sub End If NCASES= dlg.ncases If dlg.exrange=0 Then bounds= "Also, their observed Min and Max values may occasionally be outside the bounds specified." End If If dlg.corr And dlg.distrib=1 Then If MsgBox("Because 'Correlated' was chosen, some of the variables may be not following Uniform distribution. " & bounds & " OK to run?",vbOkCancel,"Warning")=vbCancel Then Exit Sub End If End If If dlg.nvars="1" Then LASTNAM= dlg.firstnam Else For i= Len(dlg.firstnam) To 1 Step -1 If InStr("123456789",Mid(dlg.firstnam,i,1))=0 Then prefix= Left(dlg.firstnam,i) firstind= Right(dlg.firstnam,Len(dlg.firstnam)-i) If firstind="" Then prefix= Left(prefix,i-1) firstind= "0" End If LASTNAM= prefix & CStr(Val(firstind)+Val(dlg.nvars)-1) Exit For End If Next End If If dlg.integers Then strRnd= "comp v(#i)= rnd(v(#i))." strRnd1= "comp v(1)= rnd(v(1))." FRMT= " (f8)" End If If dlg.missval Then strM= " /#m " & "(" & dlg.nvars & ")" strLoopMiss= "loop #i= 1 to " & dlg.nvars & "." strMissRand= "comp #m(#i)= uniform(" & NCASES & ")." strMissMiss= "if #m(#i)<=" & CStr(.2*Val(NCASES)/Val(dlg.nvars)) & " v(#i)= $sysmis." strEndLoopMiss= "end loop." End If If dlg.newfile Then strInputProg= "input prog." strLoopCase= "loop #case= 1 to " & NCASES & "." strEndCase= "end case." strEndLoop= "end loop." strEndFile= "end file." strEndInputProg= "end input prog." ElseIf dlg.missval Then NCASES= CStr(objDataDoc.GetNumberOfCases) strMissRand= "comp #m(#i)= uniform(" & NCASES & ")." strMissMiss= "if #m(#i)<=" & CStr(.2*Val(NCASES)/Val(dlg.nvars)) & " v(#i)= $sysmis." End If If dlg.skew Or dlg.exrange Then Dim minv As String,maxv As String,minvv As String,maxvv As String,vlist As String,strBreak As String,strAggreg1 As String Dim omin As String,omax As String,tmin As String,tmax As String,appendRep As String,strAggreg2 As String Dim strDoRepRange As String,strEndRepRange As String,strRange1 As String,strRange2 As String,strRange3 As String,strDelete As String,strRnd_ As String Dim strSkew As String,strDoRepSkew As String,strEndRepSkew As String,strDoIfSkew As String,strSign1 As String,strSign2 As String,strPower As String,strEndIfSkew As String Dim sv As String, pv As String If dlg.nvars="1" Then minv= "min#" & dlg.firstnam maxv= "max#" & dlg.firstnam minvv= "min##" & dlg.firstnam maxvv= "max##" & dlg.firstnam vlist= dlg.firstnam sv= "#s" & dlg.firstnam pv= "#p" & dlg.firstnam Else minv= "min#" & dlg.firstnam & " to " & "min#" & LASTNAM maxv= "max#" & dlg.firstnam & " to " & "max#" & LASTNAM minvv= "min##" & dlg.firstnam & " to " & "min##" & LASTNAM maxvv= "max##" & dlg.firstnam & " to " & "max##" & LASTNAM vlist= dlg.firstnam & " to " & LASTNAM sv= "#s" & dlg.firstnam & " to " & "#s" & LASTNAM pv= "#p" & dlg.firstnam & " to " & "#p" & LASTNAM End If strBreak= "comp break###= 1." strAggreg1= "AGGREG /OUTFILE= * MODE= ADDVARI /BREAK= break### /" & minv & " = min(" & vlist & ") /" & maxv & " = max(" & vlist & ")." If dlg.skew Then strDoRepSkew= "do rep v= " & vlist & " /#s= " & sv & " /#p= " & pv & "." strDoIfSkew= "do if $casenum=1." strSign1= "comp #s= rv.uniform(-1,1)." strSign2= "comp #s= (#s<0)-(#s>=0)." strPower= "comp #p= rv.uniform(1,5)." strEndIfSkew= "end if." strSkew= "comp v= #s*v**#p." strEndRepSkew= "end rep." If dlg.exrange=0 Then strAggreg2= "AGGREG /OUTFILE= * MODE= ADDVARI /BREAK= break### /" & minvv & " = min(" & vlist & ") /" & maxvv & " = max(" & vlist & ")." omin= minvv omax= maxvv tmin= "tmin" tmax= "tmax" appendRep= " /tmin= " & minv & " /tmax= " & maxv End If End If If dlg.exrange Then omin= minv omax= maxv tmin= dlg.exmin tmax= dlg.exmax minvv="" maxvv="" End If strDoRepRange= "do rep v= " & vlist & " /omin= " & omin & " /omax= " & omax & appendRep & "." strRange1= "comp #rprop= (" & tmax & "-" & tmin & ")/(omax-omin)." strRange2= "comp v= v*#rprop." strRange3= "comp v= v+" & tmin & "-omin*#rprop." strEndRepRange= "end rep." strDelete= "delete vari break### " & " " & minv & " " & maxv & " " & minvv & " " & maxvv & "." If dlg.integers Then strRnd_= "comp v= rnd(v)." strRnd= "" strRnd1= "" End If End If If dlg.corr Then If dlg.distrib=0 Then INIDISTR= "normal(1)" SDE= "sqrt(1-#r(#i)**2)" EDISTR= "normal(#sde(#i))" SDNEED= dlg.stdev SDNEED1= SDNEED MEANNEED= dlg.mean Else INIDISTR= "rv.uniform(-sqrt(3),sqrt(3))" SDE= "sqrt(3*(1-#r(#i)**2))" EDISTR= "rv.uniform(-#sde(#i),#sde(#i))" SDNEED1= CStr(Sqr((Val(dlg.max)-Val(dlg.min))^2/12)) SDNEED= CStr(Sqr((Val(dlg.max)-Val(dlg.min))^2/12)/1.3) MEANNEED= CStr((Val(dlg.max)+Val(dlg.min))/2) End If strCommand= strCommand & strInputProg & vbCrLf strCommand= strCommand & "numer " & dlg.firstnam & " to " & LASTNAM & FRMT & "." & vbCrLf strCommand= strCommand & "vector v= " & dlg.firstnam & " to " & LASTNAM & " /#r #sde " & "(" & dlg.nvars & ")" & strM & "." & vbCrLf strCommand= strCommand & strLoopCase & vbCrLf strCommand= strCommand & "do if $casenum=1." & vbCrLf strCommand= strCommand & "loop #i= 2 to " & dlg.nvars & "." & vbCrLf strCommand= strCommand & "comp #r(#i)= rv.uniform(-.8,.8)." & vbCrLf strCommand= strCommand & "comp #sde(#i)= " & SDE & "." & vbCrLf strCommand= strCommand & "end loop." & vbCrLf strCommand= strCommand & "end if." & vbCrLf strCommand= strCommand & "comp v(1)= " & INIDISTR & "." & vbCrLf strCommand= strCommand & "loop #i= 2 to " & dlg.nvars & "." & vbCrLf strCommand= strCommand & "comp v(#i)= #r(#i)*v(1)+" & EDISTR & "." & vbCrLf strCommand= strCommand & "end loop." & vbCrLf strCommand= strCommand & "comp v(1)= v(1)*" & SDNEED1 & "+" & MEANNEED & "." & vbCrLf strCommand= strCommand & strRnd1 & vbCrLf strCommand= strCommand & "loop #i= 2 to " & dlg.nvars & "." & vbCrLf strCommand= strCommand & "comp v(#i)= v(#i)*" & SDNEED & "+" & MEANNEED & "." & vbCrLf strCommand= strCommand & strRnd & vbCrLf strCommand= strCommand & "end loop." & vbCrLf strCommand= strCommand & strLoopMiss & vbCrLf strCommand= strCommand & strMissRand & vbCrLf strCommand= strCommand & strMissMiss & vbCrLf strCommand= strCommand & strEndLoopMiss & vbCrLf strCommand= strCommand & strEndCase & vbCrLf strCommand= strCommand & strEndLoop & vbCrLf strCommand= strCommand & strEndFile & vbCrLf strCommand= strCommand & strEndInputProg & vbCrLf strCommand= strCommand & strBreak & vbCrLf If dlg.exrange Then If dlg.skew Then strCommand= strCommand & strDoRepSkew & vbCrLf strCommand= strCommand & strDoIfSkew & vbCrLf strCommand= strCommand & strSign1 & vbCrLf strCommand= strCommand & strSign2 & vbCrLf strCommand= strCommand & strPower & vbCrLf strCommand= strCommand & strEndIfSkew & vbCrLf strCommand= strCommand & "comp v= (v-" & MEANNEED & ")/" & SDNEED1 & "+10." & vbCrLf strCommand= strCommand & strSkew & vbCrLf strCommand= strCommand & strEndRepSkew & vbCrLf End If strCommand= strCommand & strAggreg1 & vbCrLf Else strCommand= strCommand & strAggreg1 & vbCrLf If dlg.skew Then strCommand= strCommand & strDoRepSkew & vbCrLf strCommand= strCommand & strDoIfSkew & vbCrLf strCommand= strCommand & strSign1 & vbCrLf strCommand= strCommand & strSign2 & vbCrLf strCommand= strCommand & strPower & vbCrLf strCommand= strCommand & strEndIfSkew & vbCrLf strCommand= strCommand & "comp v= (v-" & MEANNEED & ")/" & SDNEED1 & "+10." & vbCrLf strCommand= strCommand & strSkew & vbCrLf strCommand= strCommand & strEndRepSkew & vbCrLf End If strCommand= strCommand & strAggreg2 & vbCrLf End If strCommand= strCommand & strDoRepRange & vbCrLf strCommand= strCommand & strRange1 & vbCrLf strCommand= strCommand & strRange2 & vbCrLf strCommand= strCommand & strRange3 & vbCrLf strCommand= strCommand & strRnd_ & vbCrLf strCommand= strCommand & strEndRepRange & vbCrLf strCommand= strCommand & "exec." & vbCrLf strCommand= strCommand & strDelete & vbCrLf Else If dlg.distrib=0 Then DISTR= "rv.normal(" & CStr(Val(dlg.mean)) & "," & CStr(Val(dlg.stdev)) & ")" SDNEED1= dlg.stdev MEANNEED= dlg.mean Else DISTR= "rv.uniform(" & CStr(Val(dlg.min)) & "," & CStr(Val(dlg.max)) & ")" SDNEED1= CStr(Sqr((Val(dlg.max)-Val(dlg.min))^2/12)) MEANNEED= CStr((Val(dlg.max)+Val(dlg.min))/2) End If strCommand= strCommand & strInputProg & vbCrLf If dlg.firstnam=LASTNAM Then strCommand= strCommand & "numer " & dlg.firstnam & FRMT & "." & vbCrLf Else strCommand= strCommand & "numer " & dlg.firstnam & " to " & LASTNAM & FRMT & "." & vbCrLf End If strCommand= strCommand & "vector v= " & dlg.firstnam & " to " & LASTNAM & strM & "." & vbCrLf strCommand= strCommand & strLoopCase & vbCrLf strCommand= strCommand & "loop #i= 1 to " & dlg.nvars & "." & vbCrLf strCommand= strCommand & "comp v(#i)= " & DISTR & "." & vbCrLf strCommand= strCommand & strRnd & vbCrLf strCommand= strCommand & "end loop." & vbCrLf strCommand= strCommand & strLoopMiss & vbCrLf strCommand= strCommand & strMissRand & vbCrLf strCommand= strCommand & strMissMiss & vbCrLf strCommand= strCommand & strEndLoopMiss & vbCrLf strCommand= strCommand & strEndCase & vbCrLf strCommand= strCommand & strEndLoop & vbCrLf strCommand= strCommand & strEndFile & vbCrLf strCommand= strCommand & strEndInputProg & vbCrLf strCommand= strCommand & strBreak & vbCrLf If dlg.exrange Then If dlg.skew Then strCommand= strCommand & strDoRepSkew & vbCrLf strCommand= strCommand & strDoIfSkew & vbCrLf strCommand= strCommand & strSign1 & vbCrLf strCommand= strCommand & strSign2 & vbCrLf strCommand= strCommand & strPower & vbCrLf strCommand= strCommand & strEndIfSkew & vbCrLf strCommand= strCommand & "comp v= (v-" & MEANNEED & ")/" & SDNEED1 & "+10." & vbCrLf strCommand= strCommand & strSkew & vbCrLf strCommand= strCommand & strEndRepSkew & vbCrLf End If strCommand= strCommand & strAggreg1 & vbCrLf Else strCommand= strCommand & strAggreg1 & vbCrLf If dlg.skew Then strCommand= strCommand & strDoRepSkew & vbCrLf strCommand= strCommand & strDoIfSkew & vbCrLf strCommand= strCommand & strSign1 & vbCrLf strCommand= strCommand & strSign2 & vbCrLf strCommand= strCommand & strPower & vbCrLf strCommand= strCommand & strEndIfSkew & vbCrLf strCommand= strCommand & "comp v= (v-" & MEANNEED & ")/" & SDNEED1 & "+10." & vbCrLf strCommand= strCommand & strSkew & vbCrLf strCommand= strCommand & strEndRepSkew & vbCrLf End If strCommand= strCommand & strAggreg2 & vbCrLf End If strCommand= strCommand & strDoRepRange & vbCrLf strCommand= strCommand & strRange1 & vbCrLf strCommand= strCommand & strRange2 & vbCrLf strCommand= strCommand & strRange3 & vbCrLf strCommand= strCommand & strRnd_ & vbCrLf strCommand= strCommand & strEndRepRange & vbCrLf strCommand= strCommand & "exec." & vbCrLf strCommand= strCommand & strDelete & vbCrLf End If objSpssApp.ExecuteCommands strCommand, True End Sub Function dlgfunc(DlgItem$, Action%, SuppValue%) As Boolean Select Case Action% Case 1 DlgEnable "min", False DlgEnable "max", False DlgEnable "exmin", False DlgEnable "exmax", False Case 2 If DlgItem$="distrib" Then If SuppValue%=1 Then DlgEnable "min", True DlgEnable "max", True DlgEnable "mean", False DlgEnable "stdev", False Else DlgEnable "min", False DlgEnable "max", False DlgEnable "mean", True DlgEnable "stdev", True End If ElseIf DlgItem$="exrange" Then If SuppValue%=False Then DlgEnable "exmin", False DlgEnable "exmax", False Else 'À åñëè åñòü ãàëî÷êà DlgEnable "exmin", True DlgEnable "exmax", True End If ElseIf DlgItem$="newfile" Then If SuppValue%=False Then DlgEnable "ncases", False Else DlgEnable "ncases", True End If ElseIf DlgItem$="help" Then Dim helptxt As String helptxt= "The variables (if multiple) will be named prefix+index, beginning from the 'Start Name'. For example, if the start name is VAR00 the script creates variables VAR00, VAR01, VAR02, etc. If you deselect 'Replace the working data file' then the variable names generated must not coincide with the names already existing in the file." & vbCrLf & vbCrLf & "Choose type of distribution with its parameters, and options to alter variables, if needed:" helptxt= helptxt & vbCrLf & vbCrLf & "Correlated - variables will be intercorrelated with some random amount of correlation rather than almost uncorrelated. Correlations for the 1st variable will tend to be higher." & vbCrLf & vbCrLf & "Skewed - random amount of assymetry will be secondarily imposed on the variables' distribution. This needs SPSS 13 or higher." & vbCrLf & vbCrLf & "Missing values - randomly embed missing values (about 20/number-of-vars % of cases per variable)." & vbCrLf & vbCrLf & "Exact Range - rescale values to this range. If you choose this then it doesn't matter what values you enter for parameters in the Distribution area. This needs SPSS 13 or higher." & vbCrLf & vbCrLf & "Round to integers - after the data were created it is rounded to integers." & vbCrLf & vbCrLf & "To control random numder seed, use the SPSS's Random Number menu." helptxt= helptxt & vbCrLf & vbCrLf & "Tip: If you are creating integers within an exact range, such as people's responses to a Likert-type scale, say, 1 through 5, - then setting 'Exact Range' to 0.50 through 5.49 instead of 1 through 5 will produce more trimmed and unbiased data." MsgBox helptxt, vbInformation, "Help" dlgfunc= True ElseIf DlgItem$="ok" Then Dim lastchar As String lastchar= Right(DlgText("firstnam"),1) If Val(DlgText("nvars"))>1 And InStr("0123456789",lastchar)=0 Then MsgBox "With multiple variables to be created, 'Start Name' must end with a digit", "Error" dlgfunc= True DlgFocus "firstnam" ElseIf DlgText("nvars")="" Or (DlgText("ncases")="" And DlgEnable("ncases")) Or (DlgValue("distrib")=0 And (DlgText("mean")="" Or DlgText("stdev")="")) Or (DlgValue("distrib")=1 And (DlgText("min")="" Or DlgText("max")="")) Or DlgText("firstnam")="" Or (DlgValue("exrange") And (DlgText("exmin")="" Or DlgText("exmax")="")) Then MsgBox "You left some text-fields empty", "Error" dlgfunc= True ElseIf Val(DlgText("nvars"))<1 And DlgText("nvars")<>"" Then MsgBox "Wrong number of variables", "Error" dlgfunc= True ElseIf DlgText("nvars")="1" And DlgValue("corr") Then MsgBox "When 'Correlated' is selected, there must be more than 1 variable", "Error" dlgfunc= True ElseIf DlgValue("newfile")=False Then Set objDocuments= objSpssApp.Documents Set objDataDoc= objDocuments.GetDataDoc (0) If objDataDoc.GetNumberOfCases=0 Then MsgBox "There is no cases currently in the file, to add variables. So, choose 'Replace the working data file'", "Error" dlgfunc= True Else Dim filevars As Variant filevars= objDataDoc.GetVariables (False) Dim i As Long For i= LBound(filevars) To UBound(filevars) If UCase(filevars(i))=UCase(DlgText("firstnam")) Then MsgBox "Variable " & DlgText("firstnam") & " already exists in the file. Choose another 'Start Name'", "Error" dlgfunc= True DlgFocus "firstnam" Exit For End If Next End If End If End If Case 3 Case 4 Case 5 End Select End Function