改行位置を一部変更してあります。内容はそのままです。
修正が一箇所ありましたので，以下に反映しておきます。
==============================================
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