'Begin Description 'Создание случайных переменных. 'Этот скрипт порождает переменные из случайных чисел нормального или равномерного распределений 'и либо добавляет их к существующему рабочему файлу данных, либо создает новый рабочий файл данных. 'Опционально, переменные могут быть созданы взаимокоррелирующими, скошенными, с пропущенными данными, и т.д. ' '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 268,384,"Create Random Variables",.dlgfunc ' %GRID:10,3,0,1 Text 10,12,140,15,"Число переменных:",.Text1 Text 10,318,110,27,"Стартовое имя: (прист.+индекс)",.Text7 Text 10,30,140,15,"Число наблюдений:",.Text2 TextBox 160,9,60,18,.nvars TextBox 130,321,90,18,.firstnam TextBox 160,27,60,18,.ncases OKButton 11,357,82,21,.ok GroupBox 10,72,250,126,"Распределение",.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,110,15,"Нормальное",.OptionButton1 OptionButton 40,138,120,15,"Равномерное",.OptionButton2 Text 90,102,60,15,"Средняя:",.Text3 GroupBox 10,201,250,108,"Видоизменения",.GroupBox2 TextBox 160,279,60,18,.exmax Text 90,153,50,15,"Мин:",.Text5 Text 90,171,50,15,"Макс:",.Text6 TextBox 160,261,60,18,.exmin Text 90,282,50,15,"Макс:",.Text9 Text 90,264,50,15,"Мин:",.Text8 Text 90,120,60,15,"Ст откл:",.Text4 CheckBox 160,231,80,15,"Целые",.integers CheckBox 10,48,220,15,"Заменить раб. файл данных",.newfile CancelButton 92,357,82,21 CheckBox 20,216,130,15,"Коррелир-ные",.corr PushButton 174,357,82,21,"Справка",.help CheckBox 160,216,90,15,"Пропуски",.missval CheckBox 20,231,120,15,"Скошенные",.skew CheckBox 20,246,140,15,"Точно диапазон",.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= "Также, их наблюдаемые Мин и Макс значения могут иногда выходить за заданные пределы." End If If dlg.corr And dlg.distrib=1 Then If MsgBox("Поскольку выбрано 'Коррелированные', некоторые переменные могут не следовать равномерному распределению. " & bounds & " OK пуск?",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= "Переменные (если несколько) будут поименованы приставка+индекс, начиная со 'Стартовое имя'. Например, если стартовое имя VAR00, скрипт создаст переменные VAR00, VAR01, VAR02, и т.д. Если не-отметить 'Заменить рабочий файл данных', то порождаемые имена должны не совпадать с именами уже существующих в файле переменных." & vbCrLf & vbCrLf & "Выберите тип распределения с его параметрами и опции видоизменения переменных, если надо:" helptxt= helptxt & vbCrLf & vbCrLf & "Коррелированные - переменные будут взаимокоррелированы (некоторой случайной величины корреляции), нежели почти некоррелированы. Корреляции для 1-й переменной имеют тенденцию быть выше." & vbCrLf & vbCrLf & "Скошенные - случайной степени ассиметрия будет наложена вторично на распределения переменных. Это требует SPSS 13 или выше." & vbCrLf & vbCrLf & "Пропуски - хаотично вставить пропущенные значения (около 20/число_переменных % наблюдений на переменную)." & vbCrLf & vbCrLf & "Точно диапазон - перешкалировать значения к этому диапазону. Если отметить это, тогда неважно какие значения вы укажете для параметров в 'Распределение'. Это требует SPSS 13 или выше." & vbCrLf & vbCrLf & "Целые - созданные данные затем округляются до целых." & vbCrLf & vbCrLf & "Для контроля зерна случайных чисел используйте SPSS-меню Random Number." helptxt= helptxt & vbCrLf & vbCrLf & "Совет: Если вы создаете целые числа в точном диапазоне, как то ответы людей на шкалу типа Лайкерта, скажем, от 1 до 5, - тогда установка 'Точно диапазон' на 0.50 до 5.49 вместо 1 до 5 даст более усеченные (от выбросов) и несмещенные данные." 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 "При создании нескольких переменных 'Стартовое имя' должно оканчиваться цифрой", "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 "Вы оставили некоторые текстовые поля пустыми", "Error" dlgfunc= True ElseIf Val(DlgText("nvars"))<1 And DlgText("nvars")<>"" Then MsgBox "Неверное число переменных", "Error" dlgfunc= True ElseIf DlgText("nvars")="1" And DlgValue("corr") Then MsgBox "Если выбрано 'Коррелированные', переменных должно быть больше одной", "Error" dlgfunc= True ElseIf DlgValue("newfile")=False Then Set objDocuments= objSpssApp.Documents Set objDataDoc= objDocuments.GetDataDoc (0) If objDataDoc.GetNumberOfCases=0 Then MsgBox "В файле сейчас нет наблюдений, чтобы добавлять переменные. Выберите 'Заменить рабочий файл данных'", "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 "Переменная " & DlgText("firstnam") & " уже есть в файле. Выберите другое 'Стартовое имя'", "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