'Begin Description '数量化3類スクリプト by khori ver 2003/3/10 fisrt version.2000/06/21. '2003/3/10の修正 Basic の int()の仕様変更に対応 '2000/9/13の修正 match file でファイルを解放しないため 個体数量の保存ができず前のファイルを呼び出していた場合があったのに対応。 '2000/9/6 の修正 move all, move 10 で最後の1項目が落ちる,全変数を hayasi.ini から読み込むとき落ちるのを修正. '注意:変数選択のときにクリックの間隔を開けるようにする。 '(つまり,ダブルクリックは無効) '変数指定はその変数をクリックすると移動する。また,「10 >>」ボタンは前に指定した変数の次の変数から10変数を移動させる。(前の指定がなければ最初から10変数) '(1)数量化3類の指標のほかにhomals,対応分析の指標も出力 '(2)そのほかにカテゴリごとの相関係数出力 '(3)プロット:カテゴリ数量,カテゴリごとの相関係数,個体数量 'カテゴリ数量,相関係数はアイテム名とカテゴリ番号を入れる '(4)一つ前の分析の指定を保存,既定値とする '(5)一つ前の分析の変数を保存,使用変数が今回の変数に全て含まれる場合,既定値とする '(6)ドラフト出力,ビュー出力の切り替えができる。 '(7)カテゴリ数量には3つのタイプをサポート(駒澤型,SPSS型,homals型) '(8)個体数量はデータファイルに併合もできる。あとでゆっくり分析してください '(9)数量化3類は基本的には1軸のみ有効。2軸以降は順序性を反映したものか要チェック '(10)既定値で出力しない対応分析の指標は数量化3類ではあまり意味がないようだ。 '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 coeftype$() Global numwrkmemory$() Global strmacro As String Global zuscore As Boolean, zucoef As Boolean, ascore As Boolean, zucorr As Boolean, draft As Boolean Global selold As Integer Global strSPSSPath As String,strFilepath As String Global coeffile As String, corrfile As String, scorefile As String, notitle As String Global datamodified As Boolean, locked As Boolean Global nerrors as Integer 'demonstrates use of the MultipleVariableSelectionDialog function Sub Main 'spsswin.exe のあるパスを得る 最後に \ つき strSPSSPath = objSpssApp.GetSPSSPath ' MsgBox strSPSSPath '各種係数得点保存ファイル名 coeffile = strSPSSPath & "h3_coef.sav" corrfile = strSPSSPath & "h3_corr.sav" scorefile = strSPSSPath & "h3_score.sav" notitle= "(untitled)" strFilepath = objSpssApp.Documents.GetDataDoc(0).GetDocumentPath 'if the file hasn't been saved If strFilepath = "" Then strFilepath = notitle End If nerrors=0 '一時的保存ファイル 一度保存するとそのセッションでは2度目の保存ができない locked = False On Error GoTo usedfile Open scorefile For Output As #2 Close #2 GoTo tugiin usedfile: locked = True Resume tugiin ' End If tugiin: '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 'データに修正があったか? 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 ReDim coeftype$(3) ReDim numwrkMemory$(5) coeftype$(1)="駒澤型" coeftype$(2)="SPSS型 正規化" coeftype$(3)="HOMALS型 正準正規化" numwrkMemory$(0)=" 1000" numwrkMemory$(1)=" 2000" numwrkmemory$(2)=" 3000" numwrkmemory$(3)=" 5000" numwrkmemory$(4)="10000" numwrkmemory$(5)="13000" '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 870,203,"数量化3類 変数選択とオプション指定 "+ strFilepath,.VarListDialogFunc GroupBox 10,7,470,189,strFilepath,.GroupBox1 PushButton 860,196,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 GroupBox 490,7,180,98,"プロット",.GroupBox2 CheckBox 510,28,130,14,"カテゴリ数量",.zucoef CheckBox 510,84,130,14,"個体数量",.zuscore CheckBox 510,140,200,14,"個体数量をデータに併合",.ascore CheckBox 510,161,210,14,"対応分析関係指標も出力",.coor CheckBox 510,119,160,14,"個体数量印刷",.pscore ComboBox 680,21,180,56,Coeftype(),.sdtype 'カテゴリ数量のタイプ Text 690,7,170,14,"カテゴリ数量のタイプ",.Text1 PushButton 210,63,80,21," 10 >>",.PushButtonAdd10 CheckBox 510,56,150,14,"カテゴリ相関係数",.zucorr CheckBox 510,182,180,14,"ドラフトビュー出力",.draft CheckBox 690,182,130,14,"ビュー出力",.view PushButton 320,161,80,21,"OK",.OK PushButton 220,161,80,21,"Cancel",.Cancel DropListBox 760,105,90,91,numwrkMemory(),.wrkmemory Text 730,84,120,14,"set workspace",.Text2 'ワークスペースの設定 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.coor = 0 dlg.zuscore = 0 dlg.zucoef = 1 dlg.ascore = 0 dlg.pscore = 0 dlg.sdtype = "HOMALS型 正準正規化" dlg.wrkmemory = 2 dlg.draft=0 dlg.zucorr=0 dlg.draft=0 dlg.view=0 'this actually puts up the dialog. Dialog dlg On Error GoTo UserCancel '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 '********** Debug.Print "Error" & Err & vbCrLf & Err.Description 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  ダイアログボックスの初期化 Case 1 ' Dialog box initialization Call InitVariables(strVars) If Dir$( strSPSSPath & "hayashi.ini")<>"" Then Rem '既定値の読み込み ----------------------------------------------- Dim aru As Boolean,a As String ,j As Integer, k As Integer,nb As Integer ReDim strVarsSelected(0) Open strSPSSPath & "hayashi.ini" For Input As #1 Rem 前の初期値のリスト(データが違っていても使用する)↓ Line Input #1,strFilePath2 Line Input #1,a DlgText "sdtype",a Input #1,i DlgValue "coor",i Input #1,i DlgValue "zuscore", i Input #1,i DlgValue "zucoef", i Input #1,i DlgValue "ascore",i Input #1,i DlgValue "pscore",i Input #1,i DlgValue "zucorr",i Input #1,i DlgValue "wrkmemory",i DlgValue "draft",0 '必ず0 DlgValue "view",0 Rem 前の初期値のリスト↑ Rem 前に使用した変数リストの読み込み Input #1,nb Dim ustrvars As Integer 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>0 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 データが違うと無効な初期値のリスト↓ Rem データが違うと無効な初期値のリスト↑ 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 Rem ダイアログボックス各値初期化(既定値がない場合) ReDim strVarsSelected(0) End If 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 Rem ok ボタン ElseIf dlgItem$ = "OK" Then 'store the array, ignore the function result Select Case DlgText("sdtype") Case coeftype$(1) '="駒澤型" strmacro="/sdtype=1" Case coeftype$(2) '="SPSS型 正規化" strmacro="/sdtype=2" Case coeftype$(3) '="HOMALS型 正準正規化" strmacro="/sdtype=3" End Select If DlgValue("coor")=1 Then strmacro=strmacro+"/coor=1" If DlgValue("zuscore")=1 Then strmacro=strmacro+"/zuscore=1" zuscore=True Else zuscore=False End If If DlgValue("zucoef")=0 Then strmacro=strmacro+"/zucoef=0" zucoef=False Else zucoef=True End If If DlgValue("ascore")=1 Then strmacro=strmacro+"/ascore=YES" ascore=True Else ascore=False End If If DlgValue("pscore")=1 Then strmacro=strmacro+"/pscore=YES" If DlgValue("zucorr")=1 Then strmacro=strmacro+"/zucorr=1" zucorr=True Else zucorr=False End If Rem 処理開始 既定値等書き込み ' strmacro=strmacro+"/wrkmemory="+numwrkmemory$(DlgValue("wrkmemory")) If DlgValue("draft")=1 Then Call setdraft(1) End If If DlgValue("view")=1 Then Call setdraft(0) End If strmacro=strmacro+"." Open strSPSSPath & "hayashi.ini" For Output As #1 Rem 初期値リスト書き込み↓ Print #1,strFilepath Print #1,DlgText("sdtype") Print #1,DlgValue("coor") Print #1,DlgValue("zuscore") Print #1,DlgValue("zucoef") Print #1,DlgValue("ascore") Print #1,DlgValue("pscore") Print #1,DlgValue("zucorr") Print #1,DlgValue("wrkmemory") Rem 初期値リスト書き込み↑ Rem  使用変数書き込み Print #1,UBound(strVarsSelected()) For i=1 To UBound(strVarsSelected())+1 Print #1,strVarsSelected(i-1) Next i Close #1 '(Untitled) Rem データが違うとき無効の初期値のリスト↓ Rem データが違うとき無効の初期値のリスト↑ Rem   書き込み終了 ' MsgBox strFilepath Dim strcommand As String If strFilepath<> notitle Then If (datamodified And (ascore Or zucorr Or zuscore Or zucoef)) Or (locked And ascore )Then If MsgBox("データを上書き保存します。" &vbCrLf&"上書きしたくないときは,キャンセル ボタンを押してください。",vbOkCancel) = vbCancel Then End End If If locked And (ascore And Not( zuscore)) Then strCommand = "save outfile='"+ strFilePath+"'." &vbCrLf strCommand = strCommand + "exec." &vbCrLf objSpssApp.ExecuteCommands strCommand , True End If End If ElseIf (ascore Or zucorr Or zuscore Or zucoef) Then strFilepath=strSPSSPath & "h3_temp.sav" If locked And (ascore And Not( zuscore)) Then strCommand = "save outfile='"+ strFilepath+"'." &vbCrLf strCommand = strCommand + "exec." &vbCrLf objSpssApp.ExecuteCommands strCommand , True End If End If ' MsgBox strMacro ' End 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)+1 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 + "hayasi3 ivar= " &vbCrLf Dim i As Integer For i=0 To numvar strCommand = strCommand + strVarsSelected(i) &vbCrLf Next i strCommand = strCommand + strmacro &vbCrLf objSpssApp.ExecuteCommands strCommand , True If zucoef Then Call plotcoef() If zucorr Then Call plotcorr() If zuscore Then Call plotscore() If zuscore Or zucoef Or zucorr Then Call recall_original_data() If ascore Then Call addscore() strCommand = "restore" &vbCrLf objSpssApp.ExecuteCommands strCommand , True End Sub Sub macrocompile() Dim strCommand As String strCommand = strCommand + "preserve." &vbCrLf strCommand = strCommand + "set printback=off." &vbCrLf strCommand = strCommand + "*-------------------------------------------------------------." &vbCrLf strCommand = strCommand + "* 数量化3類マクロ for spss. by k.hori(hori@ec.kagawa-u.ac.)" &vbCrLf strCommand = strCommand + "* 1996-03-18. rev.1.0 2000-06-20" &vbCrLf strCommand = strCommand + "*-------------------------------------------------------------." &vbCrLf strCommand = strCommand + "define hayasi3 (ivar=!charend('/') " &vbCrLf strCommand = strCommand + "/maxis=!default(5)!charend('/') /* 許容最大軸数 */" &vbCrLf strCommand = strCommand + "/pscore=!default(NO)!charend('/') /* 個体数量の印刷 */" &vbCrLf strCommand = strCommand + "/ascore=!default(NO)!charend('/') /* 個体数量を現データエディタに追加 */" &vbCrLf strCommand = strCommand + "/missing=!default(NO)!charend('/') /* 欠損値処理現在(意味無し) */" &vbCrLf strCommand = strCommand + "/sdtype=!default(3)!charend('/') /* sdtype 1:駒澤型, 2:正規化 3:正準正規化(Homals,対応分析,主軸,主座標型). */" &vbCrLf strCommand = strCommand + "/coor=!default(0)!charend('/') /* 対応分析関係出力 1:出力 1以外:なし */" &vbCrLf strCommand = strCommand + "/zucoef=!default(1)!charend('/') /*1:カテゴリ数量の図出力(既定値) , 1以外:なし*/" &vbCrLf strCommand = strCommand + "/zuscore=!default(0)!charend('/') /*1:個体数量の図出力, 1以外:なし(既定値) */" &vbCrLf strCommand = strCommand + "/zucorr=!default(0)!charend('/') /*1:相関の図出力, 1以外:なし(既定値) */" &vbCrLf strCommand = strCommand + "/wrkmemo=!default(3000)!charend('/') /* 作業記憶の大きさの設定 */" &vbCrLf strCommand = strCommand + ")." &vbCrLf strCommand = strCommand + "" &vbCrLf 'strCommand = strCommand + "set printback=listing." &vbCrLf strCommand = strCommand + "set mxloop=400000." &vbCrLf 'strCommand = strCommand + "Set workspace !wrkmemo. " &vbCrLf strCommand = strCommand + "exec." &vbCrLf strCommand = strCommand + "show workspace mxloop." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "*---------------------------------------------------------------------------" &vbCrLf strCommand = strCommand + "* 欠損値データの処理." &vbCrLf strCommand = strCommand + "*---------------------------------------------------------------------------." &vbCrLf strCommand = strCommand + "!let !nvs1=''." &vbCrLf strCommand = strCommand + "!let !nvar=!length(!nvs1)." &vbCrLf strCommand = strCommand + "!let !ascore2=!upcase(!ascore)." &vbCrLf strCommand = strCommand + "!if (!ascore2='') !then ." &vbCrLf strCommand = strCommand + "!let !ascore2 = 'NO'." &vbCrLf strCommand = strCommand + "!ifend." &vbCrLf strCommand = strCommand + "!if (!ascore2<>'NO') !then ." &vbCrLf strCommand = strCommand + " compute case_id=$casenum." &vbCrLf strCommand = strCommand + " execute." &vbCrLf strCommand = strCommand + "!ifend." &vbCrLf strCommand = strCommand + "!if ((!zucoef='1') !or (!zuscore='1')) !then." &vbCrLf strCommand = strCommand + "*元のデータを保存." &vbCrLf strCommand = strCommand + "save outfile='"+strFilepath+ "'." &vbCrLf 'h3_tmp1.sav'." &vbCrLf strCommand = strCommand + "!ifend" &vbCrLf strCommand = strCommand + "*****************************************************************." &vbCrLf strCommand = strCommand + "matrix." &vbCrLf strCommand = strCommand + "compute colname={"" "",""****** "",""数量化3"",""類"",""******"","" v.1.0""}." &vbCrLf strCommand = strCommand + "print colname/format=a10." &vbCrLf strCommand = strCommand + "compute nprint=8." &vbCrLf strCommand = strCommand + "*design の出力を1,2,3...とするため num." &vbCrLf strCommand = strCommand + "compute num={1,2,3,4,5,6,7,8,9,10,11,12,13,14,15}." &vbCrLf strCommand = strCommand + "compute num=t(num)." &vbCrLf strCommand = strCommand + "compute num2={'1','2','3','4','5','6','7','8','9','10','11','12','13','14','15'}." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "!if (!ascore2<>'NO') !then." &vbCrLf strCommand = strCommand + "* case_id が必要なとき(得点を現データに併合する または書き出す)." &vbCrLf strCommand = strCommand + "get x /file=* /var=!ivar case_id /missing=omit/names=nx." &vbCrLf strCommand = strCommand + "compute #nvar=ncol(nx)." &vbCrLf strCommand = strCommand + "compute id=x(:,#nvar)." &vbCrLf strCommand = strCommand + "compute #nvar=#nvar-1." &vbCrLf strCommand = strCommand + "compute nx=nx(:,1:#nvar)." &vbCrLf strCommand = strCommand + "compute x=x(:,1:#nvar)." &vbCrLf strCommand = strCommand + "*case_id が必要なとき終了." &vbCrLf strCommand = strCommand + "!else." &vbCrLf strCommand = strCommand + "get x /file=* /var=!ivar /missing=omit/names=nx." &vbCrLf strCommand = strCommand + "!ifend." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "compute nsample=nrow(x)." &vbCrLf strCommand = strCommand + "." &vbCrLf strCommand = strCommand + "*変数数 #nvar." &vbCrLf strCommand = strCommand + "compute #nvar=ncol(nx)." &vbCrLf strCommand = strCommand + "!let !varname=''." &vbCrLf strCommand = strCommand + "* cmaxs 各itemの最大カテゴリー数." &vbCrLf strCommand = strCommand + "compute cmaxs=cmax(x)." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "print nsample." &vbCrLf strCommand = strCommand + "*カテゴリの1,0展開 結果を z に." &vbCrLf strCommand = strCommand + "compute z=x(:,1)." &vbCrLf strCommand = strCommand + "loop i=1 to #nvar." &vbCrLf strCommand = strCommand + "compute x1=x(:,i)." &vbCrLf strCommand = strCommand + "compute x1={num(1:cmaxs(1,i),1);x1}." &vbCrLf strCommand = strCommand + "compute d=design(x1)." &vbCrLf strCommand = strCommand + "compute #row1=nsample+cmaxs(i)." &vbCrLf strCommand = strCommand + "compute d=d((cmaxs(i)+1):#row1,1:cmaxs(i))." &vbCrLf strCommand = strCommand + "compute z={z,d}." &vbCrLf strCommand = strCommand + "end loop." &vbCrLf strCommand = strCommand + "*カテゴリ総数 ctotal." &vbCrLf strCommand = strCommand + "compute ctotal=ncol(z)-1." &vbCrLf strCommand = strCommand + "compute x=z(:,2:(ctotal+1))." &vbCrLf strCommand = strCommand + "*各カテゴリの反応数." &vbCrLf strCommand = strCommand + "compute ncat=csum(x)." &vbCrLf strCommand = strCommand + "compute tres=msum(x)." &vbCrLf strCommand = strCommand + "compute ntotal=msum(ncat)." &vbCrLf strCommand = strCommand + "release z,x1,d." &vbCrLf strCommand = strCommand + "*---------------------------------------------------." &vbCrLf strCommand = strCommand + "* Compute the pooled within groups SSCP matrix." &vbCrLf strCommand = strCommand + "* Compute the beteen gropus SSCP matrix." &vbCrLf strCommand = strCommand + "*---------------------------------------------------." &vbCrLf strCommand = strCommand + "compute sumr=sqrt(rsum(x))." &vbCrLf strCommand = strCommand + "compute x2=x." &vbCrLf strCommand = strCommand + "loop i=1 to ctotal." &vbCrLf strCommand = strCommand + "compute x2(:,i)=x2(:,i)/sumr." &vbCrLf strCommand = strCommand + "end loop." &vbCrLf strCommand = strCommand + "compute spt=sscp(x2)." &vbCrLf strCommand = strCommand + "compute sumr=rsum(x)." &vbCrLf strCommand = strCommand + "release x2." &vbCrLf strCommand = strCommand + "*--------------------------------." &vbCrLf strCommand = strCommand + "* 特異値分解." &vbCrLf strCommand = strCommand + "*--------------------------------." &vbCrLf strCommand = strCommand + "compute d=mdiag(ncat)." &vbCrLf strCommand = strCommand + "compute dr_inv=inv(sqrt(d))." &vbCrLf strCommand = strCommand + "compute w=dr_inv*spt*dr_inv." &vbCrLf strCommand = strCommand + "compute label={'total',num2}." &vbCrLf strCommand = strCommand + "call svd(w,evc,evl,v)." &vbCrLf strCommand = strCommand + "compute evc=dr_inv*evc." &vbCrLf strCommand = strCommand + "compute evl=diag(evl)." &vbCrLf strCommand = strCommand + "compute evl=evl(2:nrow(evl),1)." &vbCrLf strCommand = strCommand + "*----------------------------------." &vbCrLf strCommand = strCommand + "*各種寄与率." &vbCrLf strCommand = strCommand + "*----------------------------------." &vbCrLf strCommand = strCommand + "compute maxis=!maxis." &vbCrLf strCommand = strCommand + "compute j=1." &vbCrLf strCommand = strCommand + "compute evl2=evl." &vbCrLf strCommand = strCommand + "compute evl3=evl." &vbCrLf strCommand = strCommand + "compute q=#nvar/(#nvar-1)." &vbCrLf strCommand = strCommand + "print t(evl)/title ""固有値""." &vbCrLf strCommand = strCommand + "loop if (evl(j,1)>(1/#nvar))." &vbCrLf strCommand = strCommand + "compute evl2(j,1)=(q*(evl(j,1)-1/#nvar))**2." &vbCrLf strCommand = strCommand + "compute evl3(j,1)=(q*(sqrt(evl(j,1))-1/#nvar))**2." &vbCrLf strCommand = strCommand + "compute j=j+1." &vbCrLf strCommand = strCommand + "end loop." &vbCrLf strCommand = strCommand + "print (1/#nvar)/title=""許容最小固有値(1/アイテム数)(Nishisato,1994)""" &vbCrLf strCommand = strCommand + " /format=f9.7." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "do if (maxis >= j) ." &vbCrLf strCommand = strCommand + "compute maxis=j-1." &vbCrLf strCommand = strCommand + "end if." &vbCrLf strCommand = strCommand + "compute j=j-1." &vbCrLf strCommand = strCommand + "compute evl2sum=msum(evl2(1:j,1))." &vbCrLf strCommand = strCommand + "compute evl3sum=msum(evl3(1:j,1))." &vbCrLf strCommand = strCommand + "compute j=maxis." &vbCrLf strCommand = strCommand + "compute evl2=evl2(1:maxis,1)." &vbCrLf strCommand = strCommand + "compute evl3=evl3(1:maxis,1)." &vbCrLf strCommand = strCommand + "compute evl4=evl(1:maxis,1)&/sqrt(mssq(evl))." &vbCrLf strCommand = strCommand + "compute evl5=evl." &vbCrLf strCommand = strCommand + "*." &vbCrLf strCommand = strCommand + "!if (!coor='1') !then." &vbCrLf strCommand = strCommand + "loop j1=1 to nrow(evl)." &vbCrLf strCommand = strCommand + " compute kk=0." &vbCrLf strCommand = strCommand + " loop j2=1 to j1." &vbCrLf strCommand = strCommand + " compute kk=kk+evl(j2,1)*evl(j2,1)." &vbCrLf strCommand = strCommand + " end loop." &vbCrLf strCommand = strCommand + " compute evl5(j1,1)={sqrt(kk)&/sqrt(mssq(evl))}." &vbCrLf strCommand = strCommand + " compute j3=evl5(j1,1)." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + " do if (j1>1)." &vbCrLf strCommand = strCommand + " compute evl5(j1,1)={j3-j4}." &vbCrLf strCommand = strCommand + " end if." &vbCrLf strCommand = strCommand + " compute j4=j3." &vbCrLf strCommand = strCommand + "end loop." &vbCrLf strCommand = strCommand + "*." &vbCrLf strCommand = strCommand + "compute cnam={""固有値"",""ratio"",""Benzecri"","" ratio"",""Greenacr"",""e ratio""," &vbCrLf strCommand = strCommand + " ""岩坪"",""岩坪2""}." &vbCrLf strCommand = strCommand + "compute xx={evl(1:maxis,1),evl(1:maxis,1)&/msum(evl),evl2,(evl2&/evl2sum)," &vbCrLf strCommand = strCommand + " evl3(1:maxis,1),(evl3(1:maxis,1)/evl3sum)," &vbCrLf strCommand = strCommand + " evl4(1:maxis,1),(evl5(1:maxis,1)&/msum(evl5))}." &vbCrLf strCommand = strCommand + "print xx/cnames=cnam/rnames=num2/title=""寄与率""/format=f8.3." &vbCrLf strCommand = strCommand + "release w,xx." &vbCrLf strCommand = strCommand + "*reliablity." &vbCrLf strCommand = strCommand + "compute alpha=make(maxis,1,#nvar)." &vbCrLf strCommand = strCommand + "compute alpha=(alpha-make(maxis,1,1)&/(evl(1:maxis,1)))&/(#nvar-1)." &vbCrLf strCommand = strCommand + "*chi-square." &vbCrLf strCommand = strCommand + "compute chi=make(maxis,1,((nsample+ctotal-#nvar-1)/2-ntotal+1))." &vbCrLf strCommand = strCommand + "compute chi=chi&*ln(make(maxis,1,1)-(evl(1:maxis,1)))." &vbCrLf strCommand = strCommand + "compute df=make(maxis,1,nsample+ctotal-#nvar)." &vbCrLf strCommand = strCommand + "compute prob=make(maxis,1,0)." &vbCrLf strCommand = strCommand + "loop i=1 to maxis." &vbCrLf strCommand = strCommand + "compute df(i,1)=df(i,1)-2*i-1." &vbCrLf strCommand = strCommand + "compute prob(i,1)=1-chicdf(chi(i,1),df(i,1))." &vbCrLf strCommand = strCommand + "end loop." &vbCrLf strCommand = strCommand + "print {alpha,chi,df,prob}/title=""軸の統計量 (Nishisato,1994,p150)""" &vbCrLf strCommand = strCommand + " /format=f12.4/rnames=num2/clabels=""信頼性α"",""χ2"",""df"",""p""." &vbCrLf strCommand = strCommand + "!ifend." &vbCrLf strCommand = strCommand + "*." &vbCrLf strCommand = strCommand + "compute evc=evc(:,2:(maxis+1))." &vbCrLf strCommand = strCommand + "*------------------." &vbCrLf strCommand = strCommand + "*カテゴリーラベル." &vbCrLf strCommand = strCommand + "*------------------." &vbCrLf strCommand = strCommand + "compute catlab={nx(1,1),num2(1,2:cmaxs(1,1))}." &vbCrLf strCommand = strCommand + "do if #nvar > 1." &vbCrLf strCommand = strCommand + "loop i=2 to #nvar." &vbCrLf strCommand = strCommand + "compute catlab={catlab,nx(1,i),num2(1,2:cmaxs(1,i))}." &vbCrLf strCommand = strCommand + "end loop." &vbCrLf strCommand = strCommand + "end if." &vbCrLf strCommand = strCommand + "compute vlabel={""h3s1"",""h3s2"",""h3s3"",""h3s4"",""h3s5"",""h3s6"",""h3s7"",""h3s8"",""h3s9"",""h3s10"",""h3s11"",""h3s12"",""h3s13"",""h3s14"",""h3s15"",""h3s16""}." &vbCrLf strCommand = strCommand + "compute catlab2=make(ctotal,1,0)." &vbCrLf strCommand = strCommand + "compute k=0." &vbCrLf strCommand = strCommand + "loop i=1 to #nvar." &vbCrLf strCommand = strCommand + " loop j=1 to cmaxs(1,i)." &vbCrLf strCommand = strCommand + " compute k=k+1." &vbCrLf strCommand = strCommand + " compute catlab2(k,1)=i*100+j." &vbCrLf strCommand = strCommand + " end loop." &vbCrLf strCommand = strCommand + "end loop." &vbCrLf strCommand = strCommand + "*------------------------------------." &vbCrLf strCommand = strCommand + "*固有ベクトルの調整=>数量化の係数." &vbCrLf strCommand = strCommand + "*------------------------------------." &vbCrLf strCommand = strCommand + "compute dcoef=evc." &vbCrLf strCommand = strCommand + "*print dcoef/format=f7.2/title=""eigen vector""" &vbCrLf strCommand = strCommand + "* /rnames=catlab/cnames=num2." &vbCrLf strCommand = strCommand + "*平均値・標準偏差." &vbCrLf strCommand = strCommand + "compute sd=make(1,maxis,1/sqrt(ntotal))." &vbCrLf strCommand = strCommand + "compute sd=sd&*t(sqrt(evl(1:maxis,1)))." &vbCrLf strCommand = strCommand + "compute means=make(1,maxis,0)." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "*平均・標準偏差終了------------------." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "loop i=1 to ctotal." &vbCrLf strCommand = strCommand + "compute dcoef(i,:)=(dcoef(i,:)-means)&/sd." &vbCrLf strCommand = strCommand + "end loop." &vbCrLf strCommand = strCommand + "compute clab={""freq"",num2}." &vbCrLf strCommand = strCommand + "compute coef=dcoef." &vbCrLf strCommand = strCommand + "!if (!sdtype='1') !then." &vbCrLf strCommand = strCommand + "print {t(ncat),coef}/format=f7.2/title=""駒澤型数量化3類 カテゴリ数量""" &vbCrLf strCommand = strCommand + " /rnames=catlab/cnames=clab." &vbCrLf strCommand = strCommand + "!if (!zucoef='1') !then." &vbCrLf strCommand = strCommand + "*係数の保存." &vbCrLf strCommand = strCommand + "compute vlabel2={""varcat"",vlabel}." &vbCrLf strCommand = strCommand + "compute coef2={catlab2,coef}. /*数値型のラベル*/" &vbCrLf strCommand = strCommand + "save coef2/outfile='"+coeffile+"' /name = vlabel2." &vbCrLf strCommand = strCommand + "*係数の保存終了." &vbCrLf strCommand = strCommand + "!ifend." &vbCrLf strCommand = strCommand + "!ifend." &vbCrLf strCommand = strCommand + "compute evalue=mdiag(t(evl(1:maxis,1)))." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "!if (!sdtype='2') !then." &vbCrLf strCommand = strCommand + "compute coef=dcoef*sqrt(evalue)." &vbCrLf strCommand = strCommand + "print {t(ncat),coef}/format=f7.2/" &vbCrLf strCommand = strCommand + " title=""SPSS型数量化3類 カテゴリ数量(正規化)""" &vbCrLf strCommand = strCommand + " /rnames=catlab/cnames=clab." &vbCrLf strCommand = strCommand + "!if (!zucoef='1') !then." &vbCrLf strCommand = strCommand + "*係数の保存." &vbCrLf strCommand = strCommand + "compute vlabel2={""varcat"",vlabel}." &vbCrLf strCommand = strCommand + "compute coef2={catlab2,coef}. /*数値型のラベル*/" &vbCrLf strCommand = strCommand + "save coef2/outfile='"+coeffile+"' /name = vlabel2." &vbCrLf strCommand = strCommand + "*係数の保存終了." &vbCrLf strCommand = strCommand + "!ifend." &vbCrLf strCommand = strCommand + "!ifend." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "compute coef=dcoef*evalue." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "!if (!sdtype='3') !then." &vbCrLf strCommand = strCommand + "print {t(ncat),coef}/format=f7.2/" &vbCrLf strCommand = strCommand + " title=""HOMALS型 対応分析型 カテゴリ数量(正準正規化・主軸型・主座標)""" &vbCrLf strCommand = strCommand + " /rnames=catlab/cnames=clab." &vbCrLf strCommand = strCommand + "!if (!zucoef='1') !then." &vbCrLf strCommand = strCommand + "*係数の保存." &vbCrLf strCommand = strCommand + "compute vlabel2={""varcat"",vlabel}." &vbCrLf strCommand = strCommand + "compute coef2={catlab2,coef}. /*数値型のラベル*/" &vbCrLf strCommand = strCommand + "save coef2/outfile='"+coeffile+"' /name = vlabel2." &vbCrLf strCommand = strCommand + "*係数の保存終了." &vbCrLf strCommand = strCommand + "!ifend." &vbCrLf strCommand = strCommand + "!ifend." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "compute eta2=t(t((coef)&**2)*d)&/nsample." &vbCrLf strCommand = strCommand + "compute inertia=diag(inv(d)*spt)." &vbCrLf strCommand = strCommand + "compute dcoef=t(dcoef)." &vbCrLf strCommand = strCommand + "compute coef=t(dcoef)." &vbCrLf strCommand = strCommand + "compute coef={t(ncat),coef}." &vbCrLf strCommand = strCommand + "compute clab={""freq"",num2}." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "*================." &vbCrLf strCommand = strCommand + "* 各変数の得点." &vbCrLf strCommand = strCommand + "*================." &vbCrLf strCommand = strCommand + "compute loading1=make(ctotal,1,nsample)." &vbCrLf strCommand = strCommand + "compute loading1=sqrt((loading1-t(ncat))&/t(ncat)))." &vbCrLf strCommand = strCommand + "compute loading=loading1." &vbCrLf strCommand = strCommand + "compute k=1." &vbCrLf strCommand = strCommand + "loop if (k< maxis)." &vbCrLf strCommand = strCommand + " compute loading={loading,loading1}." &vbCrLf strCommand = strCommand + " compute k=k+1." &vbCrLf strCommand = strCommand + "end loop." &vbCrLf strCommand = strCommand + "compute loading=t(dcoef)&/loading." &vbCrLf strCommand = strCommand + "compute loading=loading*evalue." &vbCrLf strCommand = strCommand + "print {t(ncat),loading}/format=f7.3/" &vbCrLf strCommand = strCommand + " title=""軸との相関係数(負荷量)""" &vbCrLf strCommand = strCommand + " /rnames=catlab/cnames=clab." &vbCrLf strCommand = strCommand + "!if (!zucorr='1') !then." &vbCrLf '追加 strCommand = strCommand + "*相関係数の保存." &vbCrLf strCommand = strCommand + "compute vlabel2={""varcat"",vlabel}." &vbCrLf strCommand = strCommand + "compute coef2={catlab2,loading}. /*数値型のラベル*/" &vbCrLf strCommand = strCommand + "save coef2/outfile='"+corrfile+"' /name = vlabel2." &vbCrLf strCommand = strCommand + "*カテゴリ数量の保存終了." &vbCrLf strCommand = strCommand + "!ifend." &vbCrLf '追加終了 strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "!if (!coor='1') !then." &vbCrLf strCommand = strCommand + "compute loading1=loading&**2." &vbCrLf strCommand = strCommand + "print loading1/format=f6.2/" &vbCrLf strCommand = strCommand + " title=""相関係数(負荷量)の2乗(対応分析)""" &vbCrLf strCommand = strCommand + " /cnames=num2/rnames=catlab." &vbCrLf strCommand = strCommand + "print eta2/format=f6.3/" &vbCrLf strCommand = strCommand + " title=""軸×カテゴリーごとのinertia(分散)""" &vbCrLf strCommand = strCommand + " /cnames=num2/rnames=catlab." &vbCrLf strCommand = strCommand + "compute ainertia=eta2*inv(evalue)&/#nvar." &vbCrLf strCommand = strCommand + "print ainertia/format=f6.3/" &vbCrLf strCommand = strCommand + " title=""inertia(固有値)への絶対的寄与率""" &vbCrLf strCommand = strCommand + " /cnames=num2/rnames=catlab." &vbCrLf strCommand = strCommand + "compute tinertia=rsum(eta2)&/rsum(loading1)." &vbCrLf strCommand = strCommand + "compute summary={rsum(loading1),(rsum(eta2)&/msum(eta2))," &vbCrLf strCommand = strCommand + " (tinertia&/msum(tinertia))}." &vbCrLf strCommand = strCommand + "print summary " &vbCrLf strCommand = strCommand + " /format=f9.3/ title=""集約統計 (対応分析型)""" &vbCrLf strCommand = strCommand + " /clabels=""Quality"",""inertia"",""全inertia""/rnames=catlab." &vbCrLf strCommand = strCommand + "!ifend." &vbCrLf strCommand = strCommand + "*********************************." &vbCrLf strCommand = strCommand + "compute varcorr=make(#nvar,maxis,0)." &vbCrLf strCommand = strCommand + "compute range=make(#nvar,maxis,0)." &vbCrLf strCommand = strCommand + "compute sk=0." &vbCrLf strCommand = strCommand + "compute rowname={num2}." &vbCrLf strCommand = strCommand + "loop i=1 to #nvar." &vbCrLf strCommand = strCommand + "compute ek=sk+cmaxs(1,i)." &vbCrLf strCommand = strCommand + "compute sk=sk+1." &vbCrLf strCommand = strCommand + "compute inertia=eta2(sk:ek,:)." &vbCrLf strCommand = strCommand + "compute varcorr(i,:)=(csum(inertia))." &vbCrLf strCommand = strCommand + "compute m=t(dcoef(:,sk:ek))." &vbCrLf strCommand = strCommand + "compute range(i,:)=(cmax(m)-cmin(m))." &vbCrLf strCommand = strCommand + "compute sk=ek." &vbCrLf strCommand = strCommand + "end loop." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "print varcorr/format=f7.3/" &vbCrLf strCommand = strCommand + " title=""相関係数の2乗(HOMALS: discriminant measure)""" &vbCrLf strCommand = strCommand + " /cnames=num2/rnames=nx." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "!if (!sdtype='1') !then." &vbCrLf strCommand = strCommand + "print range/format=f7.3/" &vbCrLf strCommand = strCommand + " title=""範囲 (数量化3類: range:駒澤型)""" &vbCrLf strCommand = strCommand + " /cnames=num2/rnames=nx." &vbCrLf strCommand = strCommand + "!ifend." &vbCrLf strCommand = strCommand + "!if (!sdtype='2') !then." &vbCrLf strCommand = strCommand + "print (range*sqrt(evalue))/format=f7.3/" &vbCrLf strCommand = strCommand + " title=""範囲 (数量化3類: range:正規化)""" &vbCrLf strCommand = strCommand + " /cnames=num2/rnames=nx." &vbCrLf strCommand = strCommand + "!ifend." &vbCrLf strCommand = strCommand + "!if (!sdtype='3') !then." &vbCrLf strCommand = strCommand + "print (range*evalue)/format=f7.3/" &vbCrLf strCommand = strCommand + " title=""範囲 (数量化3類: range:正準正規化)""" &vbCrLf strCommand = strCommand + " /cnames=num2/rnames=nx." &vbCrLf strCommand = strCommand + "!ifend." &vbCrLf strCommand = strCommand + "*============." &vbCrLf strCommand = strCommand + "* 個体数量." &vbCrLf strCommand = strCommand + "*============." &vbCrLf strCommand = strCommand + "!let !pscore2=!upcase(!pscore)." &vbCrLf strCommand = strCommand + "!if (!pscore2='') !then." &vbCrLf strCommand = strCommand + "!let !pscore2='NO'." &vbCrLf strCommand = strCommand + "!ifend." &vbCrLf strCommand = strCommand + "!if ((!pscore2 <> 'NO') !or (!ascore2 <> 'NO') !or (!zuscore='1')) !then." &vbCrLf strCommand = strCommand + "compute dscore=x*t(dcoef)." &vbCrLf strCommand = strCommand + "loop i=1 to maxis." &vbCrLf strCommand = strCommand + "compute dscore(:,i)=dscore(:,i)&/sumr." &vbCrLf strCommand = strCommand + "end loop. " &vbCrLf strCommand = strCommand + "compute label={num2(1,1:maxis)}." &vbCrLf strCommand = strCommand + "!ifend." &vbCrLf strCommand = strCommand + "!if (!pscore2 <> 'NO') !then ." &vbCrLf strCommand = strCommand + "print dscore/title=""個体数量(標準得点)""/cname=label/format=f8.4." &vbCrLf strCommand = strCommand + "!ifend." &vbCrLf strCommand = strCommand + "*------------------------------------." &vbCrLf strCommand = strCommand + "* 個体数量のカレントファイルへの出力." &vbCrLf strCommand = strCommand + "*------------------------------------." &vbCrLf strCommand = strCommand + "!if (!ascore2 <> 'NO') !then." &vbCrLf strCommand = strCommand + " compute vlabel2={""case_id"",vlabel}." &vbCrLf strCommand = strCommand + " save {id,dscore}/outfile='"+scorefile+"'/names=vlabel2." &vbCrLf strCommand = strCommand + "!else." &vbCrLf strCommand = strCommand + " !if (!zuscore = '1') !then." &vbCrLf strCommand = strCommand + " save dscore/outfile='"+scorefile+"'/names=vlabel." &vbCrLf strCommand = strCommand + " !ifend." &vbCrLf strCommand = strCommand + "!ifend." &vbCrLf strCommand = strCommand + "end matrix." &vbCrLf strCommand = strCommand + "*restore." &vbCrLf strCommand = strCommand + "" &vbCrLf ' strCommand = strCommand + "!end define." &vbCrLf objSpssApp.ExecuteCommands strCommand , True End Sub Sub plotcorr() Dim strCommand As String ' strCommand = "**************************相関係数グラフ作成 *****************************." &vbCrLf strCommand = strCommand + "get file='"+corrfile+"'." &vbCrLf strCommand = strCommand + "exec." &vbCrLf strCommand = strCommand + "format varcat(f5.0)." &vbCrLf strCommand = strCommand + "exec." &vbCrLf objSpssApp.ExecuteCommands strCommand , True Call lookdata() Call summary() Call drawgraph("相関係数") strCommand = "save outfile='"+corrfile+"'." &vbCrLf strCommand = strCommand + "exec." &vbCrLf objSpssApp.ExecuteCommands strCommand , True End Sub Sub plotcoef() Dim strCommand As String ' strCommand = "**************************カテゴリ数量グラフ作成 *****************************." &vbCrLf strCommand = strCommand + "get file='"+coeffile+"'." &vbCrLf strCommand = strCommand + "exec." &vbCrLf strCommand = strCommand + "format varcat(f5.0)." &vbCrLf strCommand = strCommand + "exec." &vbCrLf objSpssApp.ExecuteCommands strCommand , True Call lookdata() Call summary() Call drawgraph("数量") strCommand = "save outfile='"+coeffile+"'." &vbCrLf strCommand = strCommand + "exec." &vbCrLf objSpssApp.ExecuteCommands strCommand , True End Sub Sub drawgraph(a As String) Dim strCommand As String Dim b As String b="カテゴリ"+a+"散布図" strCommand = "IGRAPH " &vbCrLf strCommand = strCommand + " /VIEWNAME='3類"+a+" 1x2 散布図'" &vbCrLf strCommand = strCommand + " /X1 = VAR(h3s1) TYPE = SCALE title='Axis 1'" &vbCrLf strCommand = strCommand + " /Y = VAR(h3s2) TYPE = SCALE title='Axis 2'" &vbCrLf strCommand = strCommand + " /COORDINATE = VERTICAL" &vbCrLf strCommand = strCommand + " /POINTLABEL = VAR(plabel) ALL " &vbCrLf strCommand = strCommand + " /X1LENGTH = 4.0 " &vbCrLf strCommand = strCommand + " /YLENGTH = 4.0 " &vbCrLf If a="相関係数" Then strCommand = strCommand + " /SCALERANGE = VAR(h3s1) MIN=-1.0 MAX=1.0" &vbCrLf strCommand = strCommand + " /SCALERANGE = VAR(h3s2) MIN=-1.0 MAX=1.0" &vbCrLf End If strCommand = strCommand + " /refline h3s2 0" &vbCrLf strCommand = strCommand + " /refline h3s1 0" &vbCrLf strCommand = strCommand + " /TITLE = '数量化3類'" &vbCrLf strCommand = strCommand + " /SUBTITLE = '第1軸(X)と第2軸(Y) "+b+"'" &vbCrLf strCommand = strCommand + " /SCATTER COINCIDENT = NONE." &vbCrLf strCommand = strCommand + "exec." &vbCrLf strCommand = strCommand + "IGRAPH " &vbCrLf strCommand = strCommand + " /VIEWNAME='3類"+a+" 1x3 散布図'" &vbCrLf strCommand = strCommand + " /X1 = VAR(h3s1) TYPE = SCALE title='Axis 1'" &vbCrLf strCommand = strCommand + " /Y = VAR(h3s3) TYPE = SCALE title='Axis 3'" &vbCrLf strCommand = strCommand + " /COORDINATE = VERTICAL" &vbCrLf strCommand = strCommand + " /POINTLABEL = VAR(plabel) ALL " &vbCrLf strCommand = strCommand + " /X1LENGTH = 4.0 " &vbCrLf strCommand = strCommand + " /YLENGTH = 4.0 " &vbCrLf If a="相関係数" Then strCommand = strCommand + " /SCALERANGE = VAR(h3s1) MIN=-1.0 MAX=1.0" &vbCrLf strCommand = strCommand + " /SCALERANGE = VAR(h3s3) MIN=-1.0 MAX=1.0" &vbCrLf End If strCommand = strCommand + " /refline h3s1 0" &vbCrLf strCommand = strCommand + " /refline h3s3 0" &vbCrLf strCommand = strCommand + " /TITLE = '数量化3類'" &vbCrLf strCommand = strCommand + " /SUBTITLE = '第1軸(X)と第3軸(Y) "+b+"'" &vbCrLf strCommand = strCommand + " /SCATTER COINCIDENT = NONE." &vbCrLf strCommand = strCommand + "exec." &vbCrLf strCommand = strCommand + "IGRAPH " &vbCrLf strCommand = strCommand + " /VIEWNAME='3類"+a+" 2x3 散布図'" &vbCrLf strCommand = strCommand + " /X1 = VAR(h3s2) TYPE = SCALE title='Axis 2'" &vbCrLf strCommand = strCommand + " /Y = VAR(h3s3) TYPE = SCALE title='Axis 3'" &vbCrLf strCommand = strCommand + " /COORDINATE = VERTICAL" &vbCrLf strCommand = strCommand + " /POINTLABEL = VAR(plabel) ALL " &vbCrLf strCommand = strCommand + " /X1LENGTH = 4.0 " &vbCrLf strCommand = strCommand + " /YLENGTH = 4.0 " &vbCrLf If a="相関係数" Then strCommand = strCommand + " /SCALERANGE = VAR(h3s2) MIN=-1.0 MAX=1.0" &vbCrLf strCommand = strCommand + " /SCALERANGE = VAR(h3s3) MIN=-1.0 MAX=1.0" &vbCrLf End If strCommand = strCommand + " /refline h3s2 0" &vbCrLf strCommand = strCommand + " /refline h3s3 0" &vbCrLf strCommand = strCommand + " /TITLE = '数量化3類'" &vbCrLf strCommand = strCommand + " /SUBTITLE = '第2軸(X)と第3軸(Y) "+b+"'" &vbCrLf strCommand = strCommand + " /SCATTER COINCIDENT = NONE." &vbCrLf strCommand = strCommand + "exec." &vbCrLf strCommand = strCommand + "IGRAPH " &vbCrLf strCommand = strCommand + " /VIEWNAME='3類"+a+" 1x2x3 散布図'" &vbCrLf strCommand = strCommand + " /X1 = VAR(h3s1) TYPE = SCALE title='Axis 1'" &vbCrLf strCommand = strCommand + " /Y = VAR(h3s3) TYPE = SCALE title='Axis 3'" &vbCrLf strCommand = strCommand + " /X2 = VAR(h3s2) TYPE = SCALE title='Axis 2'" &vbCrLf strCommand = strCommand + " /COORDINATE = THREE" &vbCrLf strCommand = strCommand + "/POINTLABEL = VAR(plabel) ALL " &vbCrLf strCommand = strCommand + " /SPIKE FLOOR " &vbCrLf strCommand = strCommand + " /X1LENGTH = 4.0 " &vbCrLf strCommand = strCommand + " /YLENGTH = 4.0 " &vbCrLf strCommand = strCommand + " /X2LENGTH = 4.0 " &vbCrLf If a="相関係数" Then strCommand = strCommand + " /SCALERANGE = VAR(h3s1) MIN=-1.0 MAX=1.0" &vbCrLf strCommand = strCommand + " /SCALERANGE = VAR(h3s2) MIN=-1.0 MAX=1.0" &vbCrLf strCommand = strCommand + " /SCALERANGE = VAR(h3s3) MIN=-1.0 MAX=1.0" &vbCrLf End If strCommand = strCommand + " /TITLE = '数量化3類'" &vbCrLf strCommand = strCommand + " /SUBTITLE = '3次元グラフ "+b+"'" &vbCrLf strCommand = strCommand + " /SCATTER COINCIDENT = NONE." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "EXEc." &vbCrLf objSpssApp.ExecuteCommands strCommand , True End Sub Sub plotscore() Dim strCommand As String strCommand = strCommand + "* ここでpause を置かないと上のigraph がうまく動かないうちに次のデータ読み込みに進む." &vbCrLf strCommand = strCommand + "***************************** 個体数量グラフ作成 *****************************." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "get file='"+scorefile+"'. " &vbCrLf objSpssApp.ExecuteCommands strCommand , True strCommand = "IGRAPH " &vbCrLf strCommand = strCommand + " /VIEWNAME='3類個体数量 1x2 散布図'" &vbCrLf strCommand = strCommand + " /X1 = VAR(h3s1) TYPE = SCALE title='Axis 1'" &vbCrLf strCommand = strCommand + " /Y = VAR(h3s2) TYPE = SCALE title='Axis 2'" &vbCrLf strCommand = strCommand + " /COORDINATE = VERTICAL" &vbCrLf strCommand = strCommand + " /X1LENGTH = 4.0 " &vbCrLf strCommand = strCommand + " /YLENGTH = 4.0 " &vbCrLf strCommand = strCommand + " /refline h3s2 0" &vbCrLf strCommand = strCommand + " /refline h3s1 0" &vbCrLf strCommand = strCommand + " /TITLE = '数量化3類'" &vbCrLf strCommand = strCommand + " /SUBTITLE = '第1軸(X)と第2軸(Y) 個体数量散布図'" &vbCrLf strCommand = strCommand + " /SCATTER COINCIDENT = NONE." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "IGRAPH " &vbCrLf strCommand = strCommand + " /VIEWNAME='3類個体数量 1x3 散布図'" &vbCrLf strCommand = strCommand + " /X1 = VAR(h3s1) TYPE = SCALE title='Axis 1'" &vbCrLf strCommand = strCommand + " /Y = VAR(h3s3) TYPE = SCALE title='Axis 3' " &vbCrLf strCommand = strCommand + " /COORDINATE = VERTICAL" &vbCrLf strCommand = strCommand + " /X1LENGTH = 4.0 " &vbCrLf strCommand = strCommand + " /YLENGTH = 4.0 " &vbCrLf strCommand = strCommand + " /refline h3s1 0 " &vbCrLf strCommand = strCommand + " /refline h3s3 0 " &vbCrLf strCommand = strCommand + " /TITLE = '数量化3類'" &vbCrLf strCommand = strCommand + " /SUBTITLE = '第1軸(X)と第3軸(Y) 個体数量散布図'" &vbCrLf strCommand = strCommand + " /SCATTER COINCIDENT = NONE." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "IGRAPH " &vbCrLf strCommand = strCommand + " /VIEWNAME='3類個体数量 2x3 散布図'" &vbCrLf strCommand = strCommand + " /X1 = VAR(h3s2) TYPE = SCALE title='Axis 2'" &vbCrLf strCommand = strCommand + " /Y = VAR(h3s3) TYPE = SCALE title='Axis 3'" &vbCrLf strCommand = strCommand + " /COORDINATE = VERTICAL" &vbCrLf strCommand = strCommand + " /X1LENGTH = 4.0 " &vbCrLf strCommand = strCommand + " /YLENGTH = 4.0 " &vbCrLf strCommand = strCommand + " /refline h3s2 0" &vbCrLf strCommand = strCommand + " /refline h3s3 0" &vbCrLf strCommand = strCommand + " /TITLE = '数量化3類'" &vbCrLf strCommand = strCommand + " /SUBTITLE = '第2軸(X)と第3軸(Y) 個体数量散布図'" &vbCrLf strCommand = strCommand + " /SCATTER COINCIDENT = NONE." &vbCrLf strCommand = strCommand + "EXE." &vbCrLf objSpssApp.ExecuteCommands strCommand , True End Sub Sub recall_original_data() Dim objDataDoc As ISpssDataDoc ' データ文書を開いて表示する Set objDataDoc = objSpssApp.OpenDataDoc(strFilepath) objDataDoc.Visible = True End Sub Sub addscore() Dim strCommand As String strCommand = "/* 数量化3類得点をひっつける */" &vbCrLf strCommand = strCommand + "match files file=* /file='"+scorefile+"' /by case_id." &vbCrLf strCommand = strCommand + "format case_id(f5.0)." &vbCrLf strCommand = strCommand + "exec." &vbCrLf strCommand = strCommand + "" &vbCrLf objSpssApp.ExecuteCommands strCommand , True End Sub Sub summary Dim strCommand As String strCommand = "string plabel (a11)." &vbCrLf strCommand = strCommand + "exec." &vbCrLf objSpssApp.ExecuteCommands strCommand , True While objSpssApp.IsBusy ' Screen.MousePointer = vbHourGlass ' マウス ポインタを砂時計で表示する Wend Dim objDocuments As ISpssDocuments Dim objDataDoc As ISpssDataDoc Set objDocuments=objSpssApp.Documents Set objDataDoc = objDocuments.GetDataDoc(0) Dim i As Integer, j As Integer, k As Integer Dim xd As Variant,slabel As String On Error GoTo errortrap 'On Error GoTo 0 For i=1 To na restart: xd=objDataDoc.GetTextData ("varcat", "varcat", i, i) j=Val(Right$(CStr(xd(0,0)),2)) k=Int(CVar(xd(0,0))/100) slabel=slabel+strVarsSelected(k-1)+"_"+CStr(j) &vbCrLf Next i xd = objDataDoc.GetTextData ("plabel", "plabel", 1, 1) Clipboard$ slabel Wait 1 objDataDoc.Paste 'On Error GoTo 0 Exit Sub errortrap: nerrors=nerrors+1 If nerrors> 500 Then MsgBox "エラートラップの500回かかりました。無限ループに入っている可能性があります。終了します。:"+Error$, 0 End End If ' Debug.Print "clipboard";Clipboard$() 'クリップボードの中身 ' Debug.Print "Error" & Err & vbCrLf & Err.Description ' Debug.Print "Error$=";Error$ Wait 1 Resume restart: End Sub Sub lookdata Dim objDocuments As ISpssDocuments Dim objDataDoc As ISpssDataDoc Dim lngNumCases As Long Set objDocuments = objSpssApp.Documents Set objDataDoc = objDocuments.GetDataDoc (0) ' ファイルに含まれているケースの数を取得する lngNumCases = objDataDoc.GetNumberOfCases If lngNumCases=0 Then MsgBox "データがありません。終了します。" End End If na = lngNumCases 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