改行位置を一部変更してあります。内容はそのままです。
修正が一箇所ありましたので,以下に反映しておきます。
============================================== 141 Re^3: 類似度指数と多様度指数 投稿者: ひの 日時: 2001/08/31 (金) 01:54 ============================================== 自分のライブラリにあったのをご参考までにアップします。 言語はObject Pascal です。Delphi 6.0 のPersonal版は Borlandからフリーでダウンロードできます。 インデントが消えるのを防ぐため行頭に"|"を追加しています。 コンパイル時にはこれを削除してください。 (管理者注:上の2行に記載されている問題は解消されています) (*------------------------------------------------- Shannon-Wienwer の多様度指数 H' H' = -Σpi*ln(pi), ---------------------------------------------------*) function Heterogeneity(var X : array of extended) : extended; var i : longint; N : extended; begin N := Sum(X); result := 0; for i := 0 to High(X) - 1 do if X[i] > 0 then Result := Result - X[i]/N*ln(X[i]/N); end; ============================================== 142 Re^4: 類似度指数と多様度指数 投稿者: ひの 日時: 2001/08/31 (金) 01:56 ============================================== 500字の制限に引っかかったので追加です。 (*-------------------------------------- Morisita の類似度指数 Cλ Cλ = 2Σ(niA * niB) / ((λA + λB) * NA * NB) NA = ΣniA, NB = ΣniB λA = ΣniA(niA - 1) / NA(NA - 1) λB = ΣniB(niB - 1) / NB(NB - 1) ---------------------------------------*) function C_Rambda(var A,B : array of extended) : extended; var i : longint; NA,NB, RA,RB,PAB : extended; begin if High(A) <> High(B) then Raise Exception.Create('データ数の不一致 in C_Rambda'); NA := Sum(A); NB := Sum(B); if NA * NB <= 0 then Result := 0 else begin RA := 0; RB := 0; PAB := 0; for i := 0 to High(A) - 1 do begin RA := RA + A[i] * (A[i] - 1); RB := RB + B[i] * (B[i] - 1); PAB := PAB + A[i] * B[i]; end; RA := RA / NA / (NA - 1); RB := RB / NB / (NB - 1); Result := 2 * PAB / ((RA + RB) * NA * NB); end; end; ******************************************************************* 以上のPascalプログラムを VBA に書き直してみました。(青木繁伸) ' (*------------------------------------------------- ' Shannon-Wienwer の多様度指数 H' ' ' H ' = -Σpi*ln(pi), ' ---------------------------------------------------*) ' function Heterogeneity(var X : array of extended) : extended; Function Heterogeneity(x As Range) ' var ' i : longint; ' N : extended; Dim i As Integer Dim N As Double ' begin ' N := Sum(X); N = Sum(x) ' result := 0; ' for i := 0 to High(X) - 1 do ' if X[i] > 0 then Result := Result - X[i]/N * ln(X[i]/N); result = 0 For i = 1 To x.Rows.Count If x(i) > 0 Then result = result - x(i) / N * Log(x(i) / N) End If Next i Heterogeneity = result ' end; End Function ' (*-------------------------------------- ' Morisita の類似度指数 Cλ ' Cλ = 2Σ(niA * niB) / ((λA + λB) * NA * NB) ' NA = ΣniA, NB = ΣniB ' λA = ΣniA(niA - 1) / NA(NA - 1) ' λA = ΣniB(niB - 1) / NB(NB - 1) ' ---------------------------------------*) ' function C_Rambda(var A,B : array of extended) : extended; Function High(r As Range) High = r.Rows.Count End Function Function Sum(x As Range) Sum = 0 For i = 1 To x.Rows.Count Sum = Sum + x(i) Next i End Function Function C_Rambda(A As Range, B As Range) ' var ' i : longint; ' NA,NB, ' RA,RB,PAB : extended; Dim i As Integer Dim NA As Double, NB As Double Dim RA As Double, RB As Double, PAB As Double ' begin ' if High(A) <> High(B) then ' Raise Exception.Create('データ数の不一致 in C_Rambda'); If High(A) <> High(B) Then C_Rambda = "データ数の不一致 in C_Rambda" Exit Function End If ' NA := Sum(A); ' NB := Sum(B); NA = Sum(A) NB = Sum(B) ' if NA * NB <= 0 then ' Result := 0 If NA * NB <= 0 Then C_Rambda = 0 ' else begin Else ' RA := 0; ' RB := 0; ' PAB := 0; RA = 0 RB = 0 PAB = 0 ' for i := 0 to High(A) - 1 do begin ' RA := RA + A[i] * (A[i] - 1); ' RB := RB + B[i] * (B[i] - 1); ' PAB := PAB + A[i] * B[i]; ' end; For i = 1 To High(A) RA = RA + A(i) * (A(i) - 1) RB = RB + B(i) * (B(i) - 1) PAB = PAB + A(i) * B(i) Next i ' RA := RA / NA / (NA - 1); ' RB := RB / NB / (NB - 1); RA = RA / NA / (NA - 1) RB = RB / NB / (NB - 1) ' Result := 2 * PAB / ((RA + RB) * NA * NB); C_Rambda = 2 * PAB / ((RA + RB) * NA * NB) ' end; End If ' end; End Function