「統計学関連なんでもあり」掲示板へ,ひのさんが投稿してくれた記事の中に,インデント付きのプログラムを含むため,閲覧者の便を考えて以下に再録しておきます。

改行位置を一部変更してあります。内容はそのままです。

修正が一箇所ありましたので,以下に反映しておきます。


==============================================
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