'Begin Description 'promax.SBS 03/ 3/29 Sat Ver 1.0 khori '因子分析。主因子法により因子を抽出し、promax 法で斜交回転する。 'spss でもpromax 解を求めることができる。 '参考軸等、出力するようにしている。 '変数選択.sbs ''変数指定はその変数をクリックすると移動する。また,「10 >>」ボタンは前に指定した変数の次の変数から10変数を移動させる。(前の指定がなければ最初から10変数) '堀 啓造@香川大学経済学部 'End Description 'require variables to be dimensioned before use Option Explicit Global strVarsSelected() As String Global allvars() As String Global numvar As Integer '選択した変数の数 Global na As Integer '総カテゴリ数 Global strmacro As String Global draft As Boolean Global selold As Integer Global strSPSSPath As String,strFilepath As String Global datamodified As Boolean Global stitle As String Global inifile As String Global macroexec As String 'demonstrates use of the MultipleVariableSelectionDialog function Rem 追加変数 Global strmacro2 As String Global vnum() As String, vnumf() As String, vnumfh() As String Global nfactors As String Global totalvar As Integer Global Tolerances() As String, repts() As String, promaxks() As String, patterns() As String Sub Main Rem ファイルの設定 stitle="因子分析(promax rotation)" 'ここに処理タイトルを入れる。 inifile="promax.ini" 'ここに変数名保存のファイル名を入れる。 *.ini 形式がよい macroexec="promax var=" 'macriexec が単純なら前で指定するだけでいい(ex. "normtest var=" 'spsswin.exe のあるパスを得る 最後に \ つき strSPSSPath = objSpssApp.GetSPSSPath ' MsgBox strSPSSPath 'the function result is True if one or more variables are selected 'False if the user presses cancel If MultipleVariableSelectionDialog(strVarsSelected()) Then numvar=UBound(strVarsSelected) Call execcommand Else MsgBox "Operation Cancelled.", vbExclamation, _ "No Variables Selected" End If End Sub 'we'll put the selected variable names in the array passed as a parameter 'we'll return False as the function result if the user cancels, 'True if the user pressed OK - which we only allow after at least one 'variable is selected. Function MultipleVariableSelectionDialog(strVarsSelected() As String) As Boolean Rem 多変数選択ダイアログ 'we'll pass string arrays to the dialog's listboxes 'actually, the dialog function will initialize the arrays 'but we have to pass it a string array or there will be a type mismatch. Dim strVariables() As String ReDim strVariables(0) 're-initialize the Selected array, to make sure it isn't empty. ReDim strVarsSelected(0) 'we'll make things nice by displaying the name of the data file ' Dim strFilePath As String 'the path to the file strFilepath = objSpssApp.Documents.GetDataDoc(0).GetDocumentPath ' MsgBox strFilePath ' End 'データに修正があったか? datamodified=objSpssApp.Documents.GetDataDoc(0).Modified 'MsgBox strFilePath 'if the file hasn't been saved If strFilepath = "" Then strFilepath = "(Untitled)" End If 'MsgBox strFilePath ' End Rem ダイアログボックス使用リストの再定義 (global 変数) Call InitVariables(vnum()) ' Dim totalvar As Integer totalvar=UBound(vnum()) totalvar=totalvar-3 ReDim vnum(totalvar) As String Dim i As Integer For i=0 To totalvar vnum(i)=Right(" "+Str(i),5) Next i totalvar=totalvar+3 '最大因子数 Lederman Int((nv - 1) / 2) totalvar=totalvar/2-1 ReDim vnumf(totalvar) As String For i=0 To totalvar vnumf(i)=vnum(i+1) Next i ReDim Tolerances(2) As String, repts(5) As String, promaxks(4) As String Tolerances(0)=" 0.001 " Tolerances(1)=" 0.0001 " Tolerances(2)=" 0.00001" repts(0)= " 1" repts(1)= " 3" repts(2)= " 30" repts(3)= " 100" repts(4)= " 200" repts(5)= " 300" promaxks(0)=" 1" promaxks(1)=" 2" promaxks(2)=" 3" promaxks(3)=" 4" promaxks(4)=" 5" 'Define and put up the dialog. Rem ダイアログボックス定義 'To edit the dialog: position the cursor between Begin Dialog and 'End Dialog, then activate the Dialog Editor. 'Note that the dialog editor created a template with ListArray() 'as the ListBox parameter; it's been replaced by strVariables. 'Right-click on an item to edit its properties, or use the toolbar button. 'Use the << and >> arrows to cycle through items. 'Add a function name to the UserDialog's Dialog Function property, 'and when you save the dialog it will offer to generate the skeleton 'of the dialog monitor function. See VarListDialogMonitor function, below. Begin Dialog UserDialog 510,329,stitle + strFilepath,.VarListDialogFunc ' %GRID:10,7,1,1 GroupBox 10,7,470,189,strFilepath,.GroupBox1 PushButton 470,203,10,7,"",.no PushButton 210,35,80,21," All >> ",.PushButtonAdd PushButton 210,119,80,21," << All ",.PushButtonRemove ListBox 20,21,180,168,strVariables(),.ListBoxVars ListBox 300,21,160,133,strVarsSelected(),.ListBoxVarsSelected PushButton 210,63,80,21," 10 >>",.PushButtonAdd10 PushButton 300,161,80,21,"OK",.OK PushButton 210,161,80,21,"Cancel",.Cancel ListBox 20,224,60,98,vnumf(),.nfacts '17 GroupBox 100,266,200,56,"",.GroupBox4 CheckBox 110,280,180,14,"ドラフトビュー出力",.draft CheckBox 110,301,130,14,"ビュー出力",.view Text 220,231,60,14,"反復数",.Text2 Text 140,203,130,14,"promax 累乗係数",.Text3 Text 180,252,100,14,"許容限界(ε)",.Text4 DropListBox 290,203,60,91,promaxks(),.promaxk DropListBox 290,231,80,70,repts(),.rept DropListBox 290,252,90,70,Tolerances(),.tolerance Text 20,203,90,14,"因子数",.Text1 End Dialog 'the Cancel button will cause an error when pressed, 'so we need to set up error handling before putting up the dialog. On Error GoTo UserCancel Dim dlg As UserDialog dlg.draft=0 dlg.view=0 dlg.tolerance=2 dlg.rept=2 dlg.promaxk=2 'this actually puts up the dialog. Dialog dlg On Error GoTo UserCancel Rem ダイアログボックス初期値定義↓ dlg.draft=0 dlg.view=0 Rem ダイアログボックス初期値定義 ↑ 'we used a utility function called from the dialog monitor 'to store the variables. Request them now. strVarsSelected() = SelectedVariableArray("", False) 'return true since user hit OK MultipleVariableSelectionDialog = True Exit Function 'here's the error handler UserCancel: 'in other circumstances, we might put up a message box. 'Here, we'll return an empty string. It's up to the caller 'of the function to respond appropriately. Debug.Print "Error" & Err & vbCrLf & Err.Description ReDim strVarsSelected(0) MultipleVariableSelectionDialog = False End Function Rem See DialogFunc help topic for more information. 'the Dialog Monitor is called repeatedly while the dialog is displayed. 'when it returns False, the dialog will close. Function VarListDialogFunc(DlgItem$, Action%, SuppValue%) As Boolean 'static variables retain their values between function invocations 'we'll use these to track which variables are selected Static strVars() As String Static strVarsSelected() As String Static selnum As Integer Static selold As Integer 'loop control variable Dim i As Integer 'the item selected Dim intDlgItem As Integer Dim strfilepath2 As String Select Case Action% Rem dialog box 初期化 Case 1 ' Dialog box 初期化 Call InitVariables(strVars) If Dir$( strSPSSPath & inifile)<>"" Then Rem '既定値の読み込み ----------------------------------------------- Dim aru As Boolean,a As String ,j As Integer, k As Integer,nb As Integer ReDim strVarsSelected(0) Open strSPSSPath & inifile For Input As #1 Rem 前の初期値のリスト(データが違っていても使用する)↓ Input #1,i DlgValue "tolerance",i Input #1,i DlgValue "rept",i Input #1,i DlgValue "promaxk",i Rem 前の初期値のリスト↑ Input #1,nb Dim ustrvars As Integer If nb<=UBound(strVars()) Then For i=0 To nb Line Input #1,a aru=False ustrvars=UBound(strVars()) For j=0 To ustrvars If strVars(j)= a Then aru=True ' Debug.Print ustrvars ' Debug.Print strVars(ustrvars) For k=j To (ustrvars-1) strVars(k)=strVars(k+1) Next k If ustrvars>=1 Then ReDim Preserve strVars(ustrvars - 1) Else ReDim strVars(0) End If If strVarsSelected(0)="" Then strVarsSelected(0)=a Else ustrvars=UBound(strVarsSelected())+1 ReDim Preserve strVarsSelected(ustrvars) strVarsSelected(ustrvars)=a End If Exit For End If Next j If aru=False Then Exit For Next i Rem データが違うと無効な初期値のリスト↓ Input #1,i DlgValue "nfacts" ,i Rem データが違うと無効な初期値のリスト↑ Else aru=False End If Close #1 If aru=False Then ReDim strVarsSelected(0) ReDim strVars(0) Call InitVariables(strVars()) End If DlgListBoxArray "ListBoxVarsSelected", strVarsSelected() DlgListBoxArray "ListBoxVars", strVars() Rem '既定値読み込み終了--------------------------------------------- Else ReDim strVarsSelected(0) End If ' ReDim strVarsSelected(0) DlgListBoxArray "ListBoxVars", strVars() DlgListBoxArray "ListBoxVarsSelected", strVarsSelected() DlgEnable "OK", (UBound(strVarsSelected())>1) DlgEnable "no", False DlgEnable "PushButtonAdd", (strVars(0) <> "") DlgEnable "PushButtonAdd10", (strVars(0) <> "") DlgEnable "PushButtonRemove", (strVarsSelected(0) <> "") Dim objSPSSOptions As ISpssOptions Set objSPSSOptions = objSpssApp.Options If objSPSSOptions.CurrentOutputType =SpssObjectOutput Then DlgEnable "view",False DlgEnable "draft",True Else DlgEnable "view",True DlgEnable "draft",False End If selold=-1 'while initializing, return True to close the dialog 'VarListDialogFunc = False Rem 値が変更された、ボタンが押された時 Case 2 ' Value changing or button pressed If (DlgValue("ListBoxVars") >= 0) Then selnum=DlgValue("ListBoxVars") selold=selnum DlgEnable "OK", False DlgEnable "ListBoxVars", False Call MoveItem(DlgValue("ListBoxVars"), strVars(), strVarsSelected()) DlgListBoxArray "ListBoxVars", strVars() ' MsgBox CStr(VarType(UBound(strVars()))) DlgValue "ListBoxVars",selnum+5 If selnum > CInt(UBound(strVars())) Then selnum=selnum-1 Else If selnum+5< UBound(strVars()) Then DlgValue "ListBoxVars",selnum+5 Else DlgValue "ListBoxVars",UBound(strVars()) End If End If DlgValue "ListBoxVars",selnum DlgValue "ListBoxVars",-1 DlgListBoxArray "ListBoxVarsSelected", strVarsSelected() DlgValue "ListBoxVarsSelected",UBound(strVarsSelected()) DlgValue "ListBoxVarsSelected",-1 DlgEnable "OK",(UBound(strVarsSelected())>1) ' MsgBox CStr(UBound(strVarsSelected())) VarListDialogFunc = True ' Prevent button press from closing the dialog box ElseIf (DlgValue("ListBoxVarsSelected") >= 0) Then selnum=DlgValue("ListBoxVarsSelected") Call MoveItem(DlgValue("ListBoxVarsSelected"), strVarsSelected(), strVars()) DlgListBoxArray "ListBoxVars", strVars() DlgListBoxArray "ListBoxVarsSelected", strVarsSelected() DlgValue "ListBoxVarsSelected",selnum+5 If selnum > CInt(UBound(strVarsSelected())) Then selnum=selnum-1 Else If selnum+5< UBound(strVarsSelected()) Then DlgValue "ListBoxVarsSelected",selnum+5 Else DlgValue "ListBoxVarsSelected",UBound(strVarsSelected()) End If End If DlgValue "ListBoxVarsSelected",selnum DlgValue "ListBoxVarsSelected",-1 DlgValue "ListBoxVars",UBound(strVars()) DlgValue "ListBoxVars",-1 DlgEnable "OK", (UBound(strVarsSelected()) > 1) VarListDialogFunc = True ' Prevent button press from closing the dialog box ElseIf DlgItem$="PushButtonAdd10" Then DlgEnable "PushButtonAdd10", False selnum=selold If selnum<0 Then selnum=0 Call MoveItem10(selnum, strVars(), strVarsSelected()) DlgListBoxArray "ListBoxVars", strVars() ' MsgBox CStr(VarType(UBound(strVars()))) DlgValue "ListBoxVars",selnum+5 If selnum > CInt(UBound(strVars())) Then selnum=selnum-1 Else If selnum+5< UBound(strVars()) Then DlgValue "ListBoxVars",selnum+5 Else DlgValue "ListBoxVars",UBound(strVars()) End If End If DlgValue "ListBoxVars",selnum DlgValue "ListBoxVars",-1 DlgListBoxArray "ListBoxVarsSelected", strVarsSelected() DlgValue "ListBoxVarsSelected",UBound(strVarsSelected()) DlgValue "ListBoxVarsSelected",-1 DlgEnable "PushButtonAdd10", (strVars(0) <> "") DlgEnable "OK", (strVars(0) <> "") VarListDialogFunc = True ' Prevent button press from closing the dialog box ElseIf DlgItem$ = "PushButtonRemove" Then Call moveall(strVarsSelected(), strVars()) DlgListBoxArray "ListBoxVars", strVars() DlgListBoxArray "ListBoxVarsSelected", strVarsSelected() selnum=-1 DlgEnable "OK", False VarListDialogFunc = True ' Prevent button press from closing the dialog box ElseIf (DlgItem$ = "PushButtonAdd") Then Call Moveall( strVars(), strVarsSelected()) DlgListBoxArray "ListBoxVars", strVars() DlgListBoxArray "ListBoxVarsSelected", strVarsSelected() selnum=-1 DlgEnable "OK", (strVarsSelected(0) <> "") VarListDialogFunc = True ' Prevent button press from closing the dialog box ElseIf DlgItem$ = "OK" Then 'store the array, ignore the function result If DlgValue("draft")=1 Then Call setdraft(1) End If If DlgValue("view")=1 Then Call setdraft(0) End If Rem 処理開始 既定値等書き込み strmacro = "promaxx var= " &vbCrLf 'Dim i As Integer numvar=UBound(strVarsSelected()) For i=0 To numvar strmacro = strmacro + strVarsSelected(i) &vbCrLf Next i strmacro=strmacro+" / nfact="+vnumf(DlgValue("nfacts")) &vbCrLf strmacro=strmacro+" / iterate="+repts(DlgValue("rept")) &vbCrLf strmacro=strmacro+" / tol="+Tolerances(DlgValue("tolerance")) &vbCrLf strmacro=strmacro+" / k= "+promaxks(DlgValue("promaxk")) &vbCrLf strmacro = strmacro + "." &vbCrLf Open strSPSSPath & inifile For Output As #1 Rem  初期値リスト書き込み↓ Print #1, DlgValue("tolerance") Print #1, DlgValue("rept") Print #1, DlgValue("promaxk") Rem  初期値リスト書き込み↑ Rem  使用変数書き込み Print #1,UBound(strVarsSelected()) For i=1 To UBound(strVarsSelected())+1 Print #1,strVarsSelected(i-1) Next i Rem  ファイルが違うとき無効の初期値のリスト↓ Print #1,DlgValue("nfacts") Rem  ファイルが違うとき無効の初期値のリスト↑ Close #1 ' 書き込み終了 ' MsgBox strFilepath Call SelectedVariableArray(strVarsSelected(), True) ElseIf DlgItem$ = "no" Then MsgBox "クリックの間隔が速すぎます。ダブルクリックはしないようにね" VarListDialogFunc = True ' Prevent button press from closing the dialog box ' End If ElseIf DlgItem$ = "Cancel" Then End End If Rem VarListDialogFunc = True ' Prevent button press from closing the dialog box Rem テクストボックス・コンボボックスのテキスト変更 Case 3 ' TextBox or ComboBox text changed Rem Focus 変更 Case 4 ' Focus changed Rem アイドル Case 5 ' Idle DlgEnable "ListBoxVars", (strVars(0) <> "") DlgEnable "PushButtonAdd", (strVars(0) <> "") DlgEnable "PushButtonAdd10",(strVars(0) <> "") DlgEnable "PushButtonRemove", (strVarsSelected(0) <> "") DlgEnable "OK",(UBound(strVarsSelected())>1) VarListDialogFunc = True ' Continue getting idle actions End Select End Function Sub InitVariables(strVars() As String) 'As Variant 'the variable list is a property of the Info object. Dim objInfo As ISpssInfo 'we'll return the array of strings in a variant 'Dim strVars() As String 'loop control variable Dim i As Integer 'we'll need to know how many variables there are Dim intNumVariables As Integer Set objInfo = objSpssApp.SpssInfo 'the variables are indexed by 0 to .NumVariables - 1 intNumVariables = objInfo.NumVariables If intNumVariables > 0 Then 'set aside enough storage for the array ReDim strVars(intNumVariables - 1) ReDim allVars(intNumVariables-1) 'read in the variable names For i = 0 To intNumVariables - 1 'if we preferred, we could work with labels instead, or both strVars(i) = objInfo.VariableAt(i) 'strVars(i) = objInfo.VariableLabelAt(i) 'strVars(i) = objInfo.VariableAt(i) & ": " & objInfo.VariableLabelAt(i) allVars(i) = objInfo.VariableAt(i) Next Else 'array with one empty string ReDim strVars(0) ReDim allVars(0) End If 'InitVariables = strVars End Sub Sub moveall( strFrom() As String, strTo() As String) Dim i As Integer Dim intUpper As Integer intUpper=UBound(allvars) Debug.Print intUpper; allVars(intUpper) ReDim Preserve strTo(intUpper ) For i=0 To intUpper strTo(i)=allVars(i) Next i ReDim strFrom(0) End Sub 'utility procedure for moving an item, omits checks - because it's only 'called from the dialog function, intItem will be valid Sub MoveItem(intItem As Integer, strFrom() As String, strTo() As String) Dim i As Integer Dim intUpper As Integer '*** add the item to the destination array *** intUpper = UBound(strTo) Debug.Print intUpper; intItem; strTo(intUpper) If strTo(intUpper) = "" Then strTo(intUpper) = strFrom(intItem) Else 'make the array larger, but keep the current contents ReDim Preserve strTo(intUpper + 1) strTo(intUpper + 1) = strFrom(intItem) End If '*** remove the item from the source array *** intUpper = UBound(strFrom) 'copy the items above the removed item down one position For i = intItem To intUpper - 1 strFrom(i) = strFrom(i + 1) Next If intUpper > 0 Then 'keep all but the last element ReDim Preserve strFrom(intUpper - 1) Else 'this will re-initialize the array to contain one empty string ReDim strFrom(0) End If End Sub Sub MoveItem10(intItem As Integer, strFrom() As String, strTo() As String) Dim i As Integer Dim intUpper As Integer Dim imove As Integer, k As Integer '*** add the item to the destination array *** imove=10 If UBound(strFrom) < 10 Then imove=UBound(strFrom) For k=0 To imove-1 intUpper = UBound(strTo) ' Debug.Print intUpper; intItem; strTo(intUpper) If strTo(intUpper) = "" Then strTo(intUpper) = strFrom(intItem) Else 'make the array larger, but keep the current contents ReDim Preserve strTo(intUpper + 1) strTo(intUpper + 1) = strFrom(intItem+k) End If Next k '*** remove the item from the source array *** intUpper = UBound(strFrom) 'copy the items above the removed item down one position If (intupper >= intitem+imove) Then For i = intItem To intUpper - imove strFrom(i) = strFrom(i + imove) Next End If If intUpper-imove > 0 Then 'keep all but the last element ReDim Preserve strFrom(intUpper - imove) Else 'this will re-initialize the array to contain one empty string ReDim strFrom(0) End If End Sub 'this is a cheap dodge which lets us avoid using a global variable 'to pass the array out of the dialog monitor. This function stores 'its parameter when called with blnStore = True, and returns whatever 'was stored previously as the function result. This makes it easier 'to encapsulate code, since when copying the code for re-use, we 'don't need to create and follow instructions to add a global variable 'to the project in order for the code to work. Function SelectedVariableArray(vntStore As Variant, blnStore As Boolean) As Variant Static vntStored As Variant SelectedVariableArray = vntStored 'we refuse to store anything but an array of strings If blnStore Then If IsArray(vntStore) Then If VarType(vntStore(0)) = vbString Then vntStored = vntStore End If End If End If End Function Sub execcommand 'マクロ命令記述部 ********************************************. Dim strCommand As String Call macrocompile() strCommand = strCommand + strmacro &vbCrLf 'macroexec が単純なら前で指定するだけでいい objSpssApp.ExecuteCommands strCommand , False End Sub '**************************************************************. Sub macrocompile() Dim strCommand As String '上の execcommand 参照 'シンタックス部挿入部分 ↓ *******************************************************. strCommand = strCommand + "* promax.sps------------------------------------------------------------." &vbCrLf strCommand = strCommand + "* 因子分析(主因子解→プロマックス回転)マクロ for spss. by k.hori(hori@ec.kagawa-u.ac.)" &vbCrLf strCommand = strCommand + "* 03/ 3/26 Wed." &vbCrLf strCommand = strCommand + "* var=変数リスト(必須)/nfact=因子数(既定値3)/k=プロマックス累乗係数(既定値3)" &vbCrLf strCommand = strCommand + "* /iterate=最大反復数(既定値30)/tol=精度(既定値0.0001)." &vbCrLf strCommand = strCommand + "*-------------------------------------------------------------." &vbCrLf strCommand = strCommand + "define promaxx (var=!charend('/') " &vbCrLf strCommand = strCommand + "/nfact=!default(3)!charend('/')" &vbCrLf strCommand = strCommand + "/k=!default(3)!charend('/')" &vbCrLf strCommand = strCommand + "/iterate=!default(30)!charend('/')" &vbCrLf strCommand = strCommand + "/tol=!default(0.0001)!charend('/')" &vbCrLf strCommand = strCommand + ")." &vbCrLf strCommand = strCommand + "preserve." &vbCrLf strCommand = strCommand + "set length=none printback = off mxloops = 90000. " &vbCrLf strCommand = strCommand + "matrix." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "*因子数." &vbCrLf strCommand = strCommand + "compute nfactors=!nfact." &vbCrLf strCommand = strCommand + "*promax k." &vbCrLf strCommand = strCommand + "compute ppower=!k." &vbCrLf strCommand = strCommand + "*反復数." &vbCrLf strCommand = strCommand + "compute itercfa=!iterate." &vbCrLf strCommand = strCommand + "*精度." &vbCrLf strCommand = strCommand + "compute tolprn=!tol." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "print {nfactors,ppower,itercfa} /title = '因子分析(主因子解→promax 回転)'" &vbCrLf strCommand = strCommand + " /clabels='因子数','k','最大反復数'/format=f5.0." &vbCrLf strCommand = strCommand + "get data / file=* /missing=omit/ name=varnames /variables = !var." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "compute cases = nrow(data). " &vbCrLf strCommand = strCommand + "compute nvars = ncol(data)." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "*主因子解." &vbCrLf strCommand = strCommand + "compute extract=1." &vbCrLf strCommand = strCommand + "*プロマックス回転." &vbCrLf strCommand = strCommand + "compute rotate=1." &vbCrLf strCommand = strCommand + "compute core=nvars." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "compute num2={' 1',' 2',' 3',' 4',' 5',' 6',' 7',' 8',' 9'," &vbCrLf strCommand = strCommand + "'10','11','12','13','14','15','16','17','18','19'," &vbCrLf strCommand = strCommand + "'20','21','22','23','24','25','26','27','28','29'," &vbCrLf strCommand = strCommand + "'30','31','32','33','34','35','36','37','38','39'," &vbCrLf strCommand = strCommand + "'40','41','42','43','44','45','46','47','48','49'," &vbCrLf strCommand = strCommand + "'50','51','52','53','54','55','56','57','58','59'," &vbCrLf strCommand = strCommand + "'60','61','62','63','64','65','66','67','68','69'," &vbCrLf strCommand = strCommand + "'70','71','72','73','74','75','76','77','78','79'," &vbCrLf strCommand = strCommand + "'80','81','82','83','84','85','86','87','88','89'," &vbCrLf strCommand = strCommand + "'90','91','92','93','94','95','96','97','98','99','100'" &vbCrLf strCommand = strCommand + "}." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "* 相関行列." &vbCrLf strCommand = strCommand + "* correlation matrix." &vbCrLf strCommand = strCommand + "compute zscores = make(nrow(data), ncol(data), -999)." &vbCrLf strCommand = strCommand + "compute n = nrow(data)." &vbCrLf strCommand = strCommand + "compute nm1 = n - 1." &vbCrLf strCommand = strCommand + "loop #a = 1 to ncol(data)." &vbCrLf strCommand = strCommand + "compute mean = csum(data(:,#a)) / n." &vbCrLf strCommand = strCommand + "compute sd = sqrt ( cssq((data(:,#a)- mean)) / nm1 )." &vbCrLf strCommand = strCommand + "compute zscores(:,#a) = (data(:,#a) - mean) / sd." &vbCrLf strCommand = strCommand + "end loop." &vbCrLf strCommand = strCommand + "compute rdata = (1 / (nrow(data)-1) ) * ( t(zscores) * zscores ) ." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "compute rcore = rdata(1:core,1:core) ." &vbCrLf strCommand = strCommand + "compute r = rcore." &vbCrLf strCommand = strCommand + "compute evals1 = eval(r)." &vbCrLf strCommand = strCommand + "print t(evals1)/title='対角1の相関行列の固有値'/format=f8.4." &vbCrLf strCommand = strCommand + "* Factor Extraction >>>>>>." &vbCrLf strCommand = strCommand + "* 主因子解 extract=1; 最大反復数 itercfa; 相関行列 r; =>負荷量 lding." &vbCrLf strCommand = strCommand + "* CFA / PAF -- from Bernstein p 189 -- smc = from Bernstein p 104." &vbCrLf strCommand = strCommand + "do if ( extract = 1)." &vbCrLf strCommand = strCommand + "compute rcfa = r." &vbCrLf strCommand = strCommand + "compute smc = 1 - (1 &/ diag(inv(rcfa)) )." &vbCrLf strCommand = strCommand + "loop #a = 1 to itercfa." &vbCrLf strCommand = strCommand + "call setdiag(rcfa,smc)." &vbCrLf strCommand = strCommand + "call eigen(rcfa,eigvect,eigval)." &vbCrLf strCommand = strCommand + "compute eigval = mdiag(eigval)." &vbCrLf strCommand = strCommand + "compute lding=eigvect(:,1:nfactors)*sqrt(eigval(1:nfactors,1:nfactors))." &vbCrLf strCommand = strCommand + "compute communal = rssq(lding)." &vbCrLf strCommand = strCommand + "do if ( mmax(abs(communal-smc))< tolprn )." &vbCrLf strCommand = strCommand + "break." &vbCrLf strCommand = strCommand + "else." &vbCrLf strCommand = strCommand + "compute smc=communal." &vbCrLf strCommand = strCommand + "end if." &vbCrLf strCommand = strCommand + "end loop." &vbCrLf strCommand = strCommand + "end if." &vbCrLf strCommand = strCommand + "do if #a< itercfa." &vbCrLf strCommand = strCommand + " print #a/title='反復数'." &vbCrLf strCommand = strCommand + "else." &vbCrLf strCommand = strCommand + " print #a/title='収束しませんでした:反復数'." &vbCrLf strCommand = strCommand + "end if. " &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "** 固有ベクトルの正負の入れ替え." &vbCrLf strCommand = strCommand + "compute fugo=csum(lding)." &vbCrLf strCommand = strCommand + "compute fugo=(fugo>=0)+((fugo<0)*(-1))." &vbCrLf strCommand = strCommand + "loop #b = 1 to nfactors." &vbCrLf strCommand = strCommand + "compute lding(:,#b)=lding(:,#b)*fugo(#b)." &vbCrLf strCommand = strCommand + "end loop." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "compute names=num2." &vbCrLf strCommand = strCommand + "compute names((nfactors+1))='共通性'." &vbCrLf strCommand = strCommand + "print {lding,smc}/rnames=varnames/title= '回転前解'/format= f8.3/cnames=names." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "* 主成分分析終了." &vbCrLf strCommand = strCommand + "* バリマックス回転→プロマックス回転 rotate=1;." &vbCrLf strCommand = strCommand + "* Promax rotation -- Marcus, 1993." &vbCrLf strCommand = strCommand + "do if ( rotate = 1 and nfactors>1)." &vbCrLf strCommand = strCommand + "* varimax rotation -- Marcus, 1993, in Reyment & Joreskog, " &vbCrLf strCommand = strCommand + " Applied Factor Analysis in the Natural Sciences, CUP." &vbCrLf strCommand = strCommand + "compute b=lding." &vbCrLf strCommand = strCommand + "compute n = nrow(lding)." &vbCrLf strCommand = strCommand + "compute nf = ncol(lding)." &vbCrLf strCommand = strCommand + "compute hjsq=diag(lding*t(lding)) ." &vbCrLf strCommand = strCommand + "compute hj=sqrt(hjsq)." &vbCrLf strCommand = strCommand + "compute bh=lding &/ (hj*(make(1,nf,1))) ." &vbCrLf strCommand = strCommand + "compute Vtemp=n*rsum(csum(bh&**4))-rsum(csum(bh&**2)&**2) ." &vbCrLf strCommand = strCommand + "compute V0=Vtemp." &vbCrLf strCommand = strCommand + "loop #it=1 to 20 . " &vbCrLf strCommand = strCommand + " loop #i =1 to nf-1 ." &vbCrLf strCommand = strCommand + " compute jl=#i+1 ." &vbCrLf strCommand = strCommand + " loop #j=jl to nf." &vbCrLf strCommand = strCommand + " compute xj=lding(:,#i) &/ hj. " &vbCrLf strCommand = strCommand + " compute yj=lding(:,#j) &/ hj. " &vbCrLf strCommand = strCommand + " compute uj=xj &* xj-yj &* yj." &vbCrLf strCommand = strCommand + " compute vj=2*xj &* yj." &vbCrLf strCommand = strCommand + " compute A=csum(uj)." &vbCrLf strCommand = strCommand + " compute bigB=csum(vj)." &vbCrLf strCommand = strCommand + " compute C=t(uj) * uj - t(vj) * vj." &vbCrLf strCommand = strCommand + " compute D=2 * t(uj) * vj." &vbCrLf strCommand = strCommand + " compute num=D-2*A*bigB/n." &vbCrLf strCommand = strCommand + " compute den=C-(A**2-bigB**2)/n." &vbCrLf strCommand = strCommand + " compute tan4p=num/den." &vbCrLf strCommand = strCommand + " compute tan4p = num / den ." &vbCrLf strCommand = strCommand + " compute artanp = ( artan(abs(tan4p)) ) / 4." &vbCrLf strCommand = strCommand + " do if (num>0 and den>0)." &vbCrLf strCommand = strCommand + " compute phi = artanp." &vbCrLf strCommand = strCommand + " else if (num<0 and den<0)." &vbCrLf strCommand = strCommand + " compute phi = -1 * (.7854 - artanp) ." &vbCrLf strCommand = strCommand + " else if (num<0 and den>0)." &vbCrLf strCommand = strCommand + " compute phi = -1 * artanp." &vbCrLf strCommand = strCommand + " else if (num>0 and den<0)." &vbCrLf strCommand = strCommand + " compute phi = .7854 - artanp ." &vbCrLf strCommand = strCommand + " end if." &vbCrLf strCommand = strCommand + " compute angle = phi * 180 / 3.1415926 ." &vbCrLf strCommand = strCommand + " * do if ( abs(phi)>.00001 )." &vbCrLf strCommand = strCommand + " do if ( abs(phi)>tolprn )." &vbCrLf strCommand = strCommand + " compute bigXj=cos(phi)*xj+sin(phi)*yj." &vbCrLf strCommand = strCommand + " compute bigYj=-sin(phi)*xj+cos(phi)*yj." &vbCrLf strCommand = strCommand + " compute bj1=bigXj &* hj." &vbCrLf strCommand = strCommand + " compute bj2=bigYj &* hj." &vbCrLf strCommand = strCommand + " compute b(:,#i)=bj1." &vbCrLf strCommand = strCommand + " compute b(:,#j)=bj2." &vbCrLf strCommand = strCommand + " compute lding(:,#i)=b(:,#i)." &vbCrLf strCommand = strCommand + " compute lding(:,#j)=b(:,#j)." &vbCrLf strCommand = strCommand + " end if." &vbCrLf strCommand = strCommand + " end loop." &vbCrLf strCommand = strCommand + " end loop." &vbCrLf strCommand = strCommand + " compute lding=b." &vbCrLf strCommand = strCommand + " compute bh=lding &/ (hj*(make(1,nf,1))) ." &vbCrLf strCommand = strCommand + " compute Vtemp=n*rsum(csum(bh&**4))-rssq(cssq(bh)) ." &vbCrLf strCommand = strCommand + " compute V=Vtemp." &vbCrLf strCommand = strCommand + " do if ( abs(V-V0)< tolprn )." &vbCrLf strCommand = strCommand + " break." &vbCrLf strCommand = strCommand + " else." &vbCrLf strCommand = strCommand + " compute V0=V." &vbCrLf strCommand = strCommand + " end if." &vbCrLf strCommand = strCommand + "end loop." &vbCrLf strCommand = strCommand + "print lding/rnames=varnames/title= 'バリマックス回転 因子負荷量'/format= f8.3/cnames=num2." &vbCrLf strCommand = strCommand + "* プロマックス回転 rotate=1; ppower 累乗." &vbCrLf strCommand = strCommand + "compute B = lding." &vbCrLf strCommand = strCommand + "*目標行列がおかしいようなので修正する、." &vbCrLf strCommand = strCommand + "compute bstar=make(n,nf,0)." &vbCrLf strCommand = strCommand + "*共通性." &vbCrLf strCommand = strCommand + "compute comm=rssq(B)." &vbCrLf strCommand = strCommand + "compute comm=sqrt(comm)." &vbCrLf strCommand = strCommand + "loop #i=1 to n." &vbCrLf strCommand = strCommand + " compute bstar(#i,:)=B(#i,:)&/comm(#i)." &vbCrLf strCommand = strCommand + "end loop. " &vbCrLf strCommand = strCommand + "compute w=cmax(abs(bstar))." &vbCrLf strCommand = strCommand + "loop #i =1 to n." &vbCrLf strCommand = strCommand + " compute ww=Bstar(#i,:)&/w." &vbCrLf strCommand = strCommand + " compute sgn=((ww>0)-(ww<0))." &vbCrLf strCommand = strCommand + " compute bstar(#i,:)=(abs(ww)&**ppower)&*sgn." &vbCrLf strCommand = strCommand + "end loop." &vbCrLf strCommand = strCommand + "print Bstar/rnames=varnames/title= '目標行列'/format= f8.3/cnames=num2." &vbCrLf strCommand = strCommand + "compute Tr=inv(t(B) *B)*t(B)*Bstar." &vbCrLf strCommand = strCommand + "print tr/title=""プロクラステス変換行列""/format=f8.3." &vbCrLf strCommand = strCommand + "compute Tr=Tr*sqrt(inv(mdiag(diag(t(Tr)*Tr))))." &vbCrLf strCommand = strCommand + "compute Tpp=inv(Tr)." &vbCrLf strCommand = strCommand + "compute Tpp=inv(sqrt(mdiag(diag(Tpp*t(Tpp)))))*Tpp." &vbCrLf strCommand = strCommand + "*参考構造." &vbCrLf strCommand = strCommand + "compute Sr=B*Tr." &vbCrLf strCommand = strCommand + "print Sr/rnames=varnames/cnames=num2/title='参考構造'/format= f8.3." &vbCrLf strCommand = strCommand + "*因子間相関." &vbCrLf strCommand = strCommand + "compute Phip=Tpp*t(Tpp)." &vbCrLf strCommand = strCommand + "print Phip/rnames=num2/cnames=num2/title='因子間相関'/format= f8.3." &vbCrLf strCommand = strCommand + "*因子構造行列." &vbCrLf strCommand = strCommand + "compute Sp=B*t(Tpp)." &vbCrLf strCommand = strCommand + "print Sp/rnames=varnames/cnames=num2/title='因子構造行列'/format= f8.3." &vbCrLf strCommand = strCommand + "*因子パタン行列." &vbCrLf strCommand = strCommand + "compute Pp=B*inv(Tpp)." &vbCrLf strCommand = strCommand + "print Pp/rnames=varnames/cnames=num2/title='因子パタン行列'/format= f8.3." &vbCrLf strCommand = strCommand + "*参考パタン行列." &vbCrLf strCommand = strCommand + "compute Pr=B*inv(t(Tr))." &vbCrLf strCommand = strCommand + "print Pr/rnames=varnames/cnames=num2/title='参考パタン行列'/format= f8.3." &vbCrLf strCommand = strCommand + "*参考軸間相関." &vbCrLf strCommand = strCommand + "compute Phir= t(Tr)*Tr." &vbCrLf strCommand = strCommand + "print Phir/rnames=num2/cnames=num2/title='参考軸間相関'/format= f8.3." &vbCrLf strCommand = strCommand + "*高次因子分析のための相関行列." &vbCrLf strCommand = strCommand + "* プロマックス回転終了." &vbCrLf strCommand = strCommand + "end if." &vbCrLf strCommand = strCommand + "end matrix." &vbCrLf strCommand = strCommand + "restore." &vbCrLf strCommand = strCommand + "!enddefine." &vbCrLf 'シンタックス部挿入部分 ↑ *******************************************************. objSpssApp.ExecuteCommands strCommand , False End Sub Sub setdraft(i As Integer) ' i=0 view i=1 draft Dim objSPSSOptions As ISpssOptions Set objSPSSOptions = objSpssApp.Options Dim objDocuments As ISpssDocuments Dim Count As Integer Set objDocuments = objSpssApp.Documents If i=1 Then Dim objDraftDoc As ISpssDraftDoc Count = objDocuments.DraftDocCount If count>0 Then Set objDraftDoc = objDocuments.GetDraftDoc(count-1) objDraftDoc.Designated = True Else objSPSSOptions.CurrentOutputType =SpssDraftOutput End If ElseIf i=0 Then Dim objOutputDoc As ISpssOutputDoc Count = objDocuments.OutputDocCount If count>0 Then Set objOutputDoc = objDocuments.GetOutputDoc(count-1) objOutputDoc.Designated = True objOutputDoc.Visible = True Else objSPSSOptions.CurrentOutputType =SpssObjectOutput End If End If End Sub