testcorrhtunit.pas

maths lib with source

        LTTbl[I] := 0;
        RTTbl[I] := 0;
        Inc(I);
    end;
    
    //
    // Fill p-table
    //
    Pass:=1;
    while Pass<=PassCount do
    begin
        Med := 20*RandomReal-10;
        Width := 1+5*RandomReal;
        Generate(N, Med, Width, X);
        Generate(N, Med, Width, Y);
        R := SpearmanRankCorrelation(X, Y, N);
        SpearmanRankCorrelationSignificance(R, N, BT, LT, RT);
        I:=0;
        while I<=QCnt-1 do
        begin
            if BT<=BTQTbl[I] then
            begin
                BTTbl[I] := BTTbl[I]+1/PassCount;
            end;
            if LT<=LRQTbl[I] then
            begin
                LTTbl[I] := LTTbl[I]+1/PassCount;
            end;
            if RT<=LRQTbl[I] then
            begin
                RTTbl[I] := RTTbl[I]+1/PassCount;
            end;
            Inc(I);
        end;
        Inc(Pass);
    end;
    
    //
    // Check
    //
    TmpTestOK := True;
    I:=0;
    while I<=QCnt-1 do
    begin
        if AbsReal(BTTbl[I]-BTQTbl[I])/BTSigmaTbl[I]>SigmaThreshold then
        begin
            TmpTestOK := False;
        end;
        if AbsReal(RTTbl[I]-LRQTbl[I])/LRSigmaTbl[I]>SigmaThreshold then
        begin
            TmpTestOK := False;
        end;
        if AbsReal(LTTbl[I]-LRQTbl[I])/LRSigmaTbl[I]>SigmaThreshold then
        begin
            TmpTestOK := False;
        end;
        Inc(I);
    end;
    STestOK := TmpTestOK;
    
    //
    // Report
    //
    if  not Silent and DetailedReport then
    begin
        Write(Format(''#13#10'SPEARMAN TEST TABLE'#13#10'',[]));
        Write(Format('Q no.     BT err.   LT err.   RT err.   '#13#10'',[]));
        I:=0;
        while I<=QCnt-1 do
        begin
            Write(Format('%1d         %3.1f std.  %3.1f std.  %3.1f std.  '#13#10'',[
                I+1,
                AbsReal(BTTbl[I]-BTQTbl[I])/BTSigmaTbl[I],
                AbsReal(LTTbl[I]-LRQTbl[I])/LRSigmaTbl[I],
                AbsReal(RTTbl[I]-LRQTbl[I])/LRSigmaTbl[I]]));
            Inc(I);
        end;
        if TmpTestOK then
        begin
            Write(Format('TEST PASSED'#13#10''#13#10'',[]));
        end
        else
        begin
            Write(Format('TEST FAILED'#13#10''#13#10'',[]));
        end;
    end;
    
    //
    // Sperman power test
    //
    
    //
    // Prepare p-table
    //
    I:=0;
    while I<=QCnt-1 do
    begin
        BTTbl[I] := 0;
        LTTbl[I] := 0;
        RTTbl[I] := 0;
        Inc(I);
    end;
    
    //
    // Fill p-table
    //
    LPower := 0;
    RPower := 0;
    BPower := 0;
    Pass:=1;
    while Pass<=PassCount do
    begin
        V := 10;
        Generate(N, 0.0, 1.0, X);
        Generate(N, 0.0, 1.0, Y);
        APVSub(@Y[0], 0, N-1, @X[0], 0, N-1, V);
        R := SpearmanRankCorrelation(X, Y, N);
        SpearmanRankCorrelationSignificance(R, N, BT, LT, RT);
        if LT<0.05 then
        begin
            LPower := LPower+1/PassCount;
        end;
        Generate(N, 0.0, 1.0, Y);
        APVAdd(@Y[0], 0, N-1, @X[0], 0, N-1, V);
        R := SpearmanRankCorrelation(X, Y, N);
        SpearmanRankCorrelationSignificance(R, N, BT, LT, RT);
        if RT<0.05 then
        begin
            RPower := RPower+1/PassCount;
        end;
        Generate(N, 0.0, 1.0, Y);
        if RandomReal>0.5 then
        begin
            APVAdd(@Y[0], 0, N-1, @X[0], 0, N-1, V);
        end
        else
        begin
            APVSub(@Y[0], 0, N-1, @X[0], 0, N-1, V);
        end;
        R := SpearmanRankCorrelation(X, Y, N);
        SpearmanRankCorrelationSignificance(R, N, BT, LT, RT);
        if BT<0.05 then
        begin
            BPower := BPower+1/PassCount;
        end;
        Inc(Pass);
    end;
    
    //
    // Check
    //
    STestPowOK := (LPower>0.95) and (RPower>0.95) and (BPower>0.95);
    
    //
    // Report
    //
    if  not Silent and DetailedReport then
    begin
        Write(Format(''#13#10'SPEARMAN POWER TEST TABLE'#13#10'',[]));
        Write(Format('LEFT-TAIL TEST POWER:  %4.2f'#13#10'',[
            LPower]));
        Write(Format('RIGHT-TAIL TEST POWER: %4.2f'#13#10'',[
            RPower]));
        Write(Format('BOTH-TAIL TEST POWER:  %4.2f'#13#10'',[
            BPower]));
        if PTestPowOK then
        begin
            Write(Format('TEST PASSED'#13#10''#13#10'',[]));
        end
        else
        begin
            Write(Format('TEST FAILED'#13#10''#13#10'',[]));
        end;
    end;
    
    //
    // Final report
    //
    WasErrors :=  not PTestOK or  not STestOK or  not PTestPowOK or  not STestPowOK;
    if  not Silent then
    begin
        Write(Format('PEARSON CONTINUOUS VALIDITY TEST:        ',[]));
        if PTestOK then
        begin
            Write(Format('OK'#13#10'',[]));
        end
        else
        begin
            Write(Format('FAILED'#13#10'',[]));
        end;
        Write(Format('PEARSON POWER TEST:                      ',[]));
        if PTestPowOK then
        begin
            Write(Format('OK'#13#10'',[]));
        end
        else
        begin
            Write(Format('FAILED'#13#10'',[]));
        end;
        Write(Format('SPEARMAN CONTINUOUS VALIDITY TEST:       ',[]));
        if STestOK then
        begin
            Write(Format('OK'#13#10'',[]));
        end
        else
        begin
            Write(Format('FAILED'#13#10'',[]));
        end;
        Write(Format('SPEARMAN POWER TEST:                     ',[]));
        if STestPowOK then
        begin
            Write(Format('OK'#13#10'',[]));
        end
        else
        begin
            Write(Format('FAILED'#13#10'',[]));
        end;
        if WasErrors then
        begin
            Write(Format('TEST SUMMARY: FAILED'#13#10'',[]));
        end
        else
        begin
            Write(Format('TEST SUMMARY: PASSED'#13#10'',[]));
        end;
        Write(Format(''#13#10''#13#10'',[]));
    end;
    Result :=  not WasErrors;
end;


procedure Generate(N : Integer;
     Med : Double;
     Width : Double;
     var R : TReal1DArray);
var
    I : Integer;
    V : Double;
begin
    i:=0;
    while i<=N-1 do
    begin
        V := 2*RandomReal-1;
        if V>0 then
        begin
            R[I] := Med+Width*V;
        end
        else
        begin
            R[I] := Med+3*Width*V;
        end;
        Inc(i);
    end;
end;


procedure GenerateNormal(N : Integer;
     Mean : Double;
     Sigma : Double;
     var R : TReal1DArray);
var
    I : Integer;
    U : Double;
    V : Double;
    S : Double;
    Sum : Double;
begin
    i := 0;
    while i<n do
    begin
        u := (2*RandomInteger(2)-1)*RandomReal;
        v := (2*RandomInteger(2)-1)*RandomReal;
        sum := u*u+v*v;
        if (sum<1) and (sum>0) then
        begin
            sum := sqrt(-2*ln(sum)/sum);
            if i<n then
            begin
                r[i] := Sigma*u*sum+Mean;
            end;
            if i+1<n then
            begin
                r[i+1] := Sigma*v*sum+Mean;
            end;
            i := i+2;
        end;
    end;
end;


(*************************************************************************
Silent unit test
*************************************************************************)
function testcorrhtunit_test_silent():Boolean;
begin
    Result := TestCorrTest(True);
end;


(*************************************************************************
Unit test
*************************************************************************)
function testcorrhtunit_test():Boolean;
begin
    Result := TestCorrTest(False);
end;


end.