1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
|
unit valformat;
{$H+}
interface
uses
{$IFNDEF UNIX} Windows,{Registry,ShlObj,}{$ENDIF}
Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Grids, Menus, ToolWin, ComCtrls, Buttons,Clipbrd, StdCtrls,
Spin,define_types,npmform;
const
{$IFDEF FPC}
kNaN = -maxint;
{$ELSE}
kNaN : double = 1/0;
{$ENDIF}
kVALNativeSignatureBase = '#Version:';
kValMaxVers = 1; //version 0 = 3D, version 1 = 4D, version 2 not yet supported
kTxtExt = '.txt';
kVALNativeExt = '.val';
kValFilter = 'Text description (*.val)|*.val';
function RowColPos (lRow,lCol,lnCol: integer): integer;
function OpenValFile (var lFilename,lTemplateName:string; var lnRow,lnCol,lnColWObs,lnCritPct: integer;
var lDesignUnspecified : boolean; var lPredictorList,lFileList:TStringList; var lDoublePtr: Pointer): boolean;
function GetValCore (var lVALFilename:string; var lnSubj, lnFactors: integer; var lSymptomRA: singleP; var lImageNames: TStrings; var lCrit,lCritPct: integer; {lBinomial : boolean;} var lPredictorList: TStringList):boolean;
implementation
procedure MsgX (lStr: string);
begin
//output something here
showmessage(lStr);
end;
function VALNativeSignature (lStr: string): boolean;
var
lP,lLen: integer;
lVers: string;
begin
result := false;
lLen := length(lStr);
if lLen < (length(kVALNativeSignatureBase)+1) then
exit;
for lP := 1 to length(kVALNativeSignatureBase) do
if lStr[lP] <> kVALNativeSignatureBase[lP] then
exit;
//VAL format, but can we read this version?
for lP := (length(kVALNativeSignatureBase)+1) to lLen do
lVers := lVers + lStr[lP];
if strtoint(lVers) <= kValMaxVers then
result := true;
end;
function ReadTabStr (var lStr: string; var lPos: integer): string;
var
lLen: integer;
begin
result := '';
if lPos < 1 then lPos := 1;
lLen := length(lStr);
while (lPos <= lLen) and (lStr[lPos] <> kTab) do begin
result := result + lStr[lPos];
inc(lPos);
end;
inc(lPos);
end;
function RowColPos (lRow,lCol,lnCol: integer): integer;
begin
result := ((lRow-1{alfa})*lnCol)+lCol;
end;
//Replicates Readln, but works for Unix files... Delphi 4's readln fails for non-MSDOS EOLs
procedure ReadlnX (var F: TextFile; var lResult: string);
var
lCh: char;
begin
lResult := '';
while not Eof(F) do begin
Read(F, lCh);
if (lCh in [#10,#13]) then begin
if lResult <> '' then begin
//Showmessage(lResult);
exit;
end;
end else
lResult := lResult + lCh;
end;
end; //ReadlnX
function OpenValFile (var lFilename,lTemplateName:string; var lnRow,lnCol,lnColwObs,lnCritPct: integer;
var lDesignUnspecified : boolean; var lPredictorList,lFileList:TStringList; var lDoublePtr: Pointer): boolean;
var
lNumStr,lStr,lExt,lPrevNumStr,lCmdStr: string;
F: TextFile;
lTempFloat: double;
lCh: char;
lPos,MaxC,R,C:integer;
lDoubleBuf: DoubleP;
lError: boolean;
lDecimalSep: char;
begin
lnRow := 0;
lnCol := 0;
result := false;
if not fileexists(lFilename) then exit;
lError:= false;
lnCritPct := 0;
lExt := StrLower(PChar(extractfileext(lFilename)));
if (lExt = kTxtExt) or (lExt = kVALNativeExt) then
else begin
Showmessage('This version is unable to recognize the extension of the file: '+lFilename);
exit;
end;
lDecimalSep := DecimalSeparator;
DecimalSeparator := '.';
AssignFile(F, lFilename);
FileMode := 0; //Set file access to read only
//First pass: determine column height/width
Reset(F);
C := 0;
MaxC := 0;
R := 0;
if lExt = kVALNativeExt then begin
ReadlnX(F,lStr);//Version
if not VALNativeSignature(lStr) then begin
showmessage('This software can not read this file. Perhaps you need to upgrade your software. The first line should read "'+kVALNativeSignatureBase+'x" where "x" is <'+inttostr(kValMaxVers+1));
CloseFile(F);
FileMode := 2; //Set file access to read/write
exit;
end;
lDesignUnspecified := false;
lStr := '#';
while (length(lStr)> 0) and (lStr[1] = '#') and (not Eof(F)) do begin
ReadlnX(F,lStr);
lPos := 0; //start at beginning of line
lCmdStr := ReadTabStr(lStr,lPos);
if lCmdStr = '#Template' then
lTemplateName := ReadTabStr(lStr,lPos);
if lCmdStr = '#CritPct' then
lnCritPct := StrToInt(ReadTabStr(lStr,lPos));
end;
if (length(lStr)> 0) and (lStr[1] = '#') then showmessage(lCmdStr);
end else begin
lnCritPct := 0;
lDesignUnspecified := true;
lTemplateName := '-';
end;//Ext=native version
Reset(F);
while not Eof(F) do begin
//read next line
//read next line
Read(F, lCh);
if lCh = '#' then
while not (lCh in [#10,#13]) do
Read(F, lCh)
else if not (lCh in [#10,#13,#9]) then begin
lNumStr := lNumStr + lCh;
end else if lNumStr <> '' then begin
lNumStr := '';
inc(C);
if C > MaxC then
MaxC := C;
if (lCh in [#10,#13]) then begin
C := 0;
inc(R);
end; //eoln
end; //if lNumStr <> '' and not tab
end;
if lNumStr <> '' then //july06- read data immediately prior to EOF
inc(R);
lnRow:= R;
lnCol := MaxC-1;
lnColWObs := lnCol+1;
getmem(lDoublePtr,(lnRow*lnColWObs* sizeof(double))+16);
{$IFDEF FPC}
lDoubleBuf := align(lDoublePtr,16);
{$ELSE}
//lDoubleBuf := DoubleP((integer(lDoublePtr) and $FFFFFFF0)+16);
lDoubleBuf := DoubleP($fffffff0 and (integer(lDoublePtr)+15));
{$ENDIF}
for C := 1 to (lnRow*lnColWObs) do
lDoubleBuf^[C] := 0;
//Second pass: fill values
Reset(F);
C := 0;
MaxC := 0;
R := 1;
lNumStr := '';
while not Eof(F) do begin
//read next line
Read(F, lCh);
if lCh = '#' then
while not (lCh in [#10,#13]) do
Read(F, lCh)
else if not (lCh in [#10,#13,#9]) then begin
lNumStr := lNumStr + lCh;
end else if lNumStr <> '' then begin
//read current entry
if R = 1 then begin //1st Row
if C > 0 then
lPredictorList.Add( lNumStr)
end else if C = 0 then begin //1st Row
//showmessage(lNumStr);
lFileList.Add( lNumStr)
end else begin //note: below -1 as we strip first header row for predictor names
if lNumStr = '-' then begin
lDoubleBuf^[RowColPos (R-1{ july 06 alfa},C,lnColWObs)] := 0;
end else begin //number
try
lTempFloat := strtofloat(lNumStr);
except
on EConvertError do begin
if not lError then
showmessage('Empty cells? Error reading VAL file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number');
lError := true;
lTempFloat := knan;
end;
end;
lDoubleBuf^[RowColPos (R-1{ july 06 alfa},C,lnColWObs)] := lTempFloat;//DataGrid.Cells[ C, kMaxFactors+R-1 ] := (lNumStr) ;
end;
end;
lPrevNumStr := lNumStr;
lNumStr := '';
inc(C);
if C > MaxC then
MaxC := C;
if (lCh in [#10,#13]) then begin
C := 0;
inc(R);
end; //eoln
end; //if lNumStr <> '' and not tab
end;
if (lNumStr <> '') and (C>0) then //alfa read data immediately prior to EOF
lDoubleBuf^[RowColPos (R-1{alfa},C,lnColWObs)] := strtofloat(lNumStr);
CloseFile(F);
FileMode := 2; //Set file access to read/write
result := true;
DecimalSeparator := lDecimalSep;
//fx(lPredictorList.Count,lnCol);
if lPredictorList.Count < lnCol then begin
for C := (lPredictorList.Count+1) to lnCol do
lPredictorList.Add('Predictor'+inttostr(C));
end;
end;
function GetValCore (var lVALFilename:string; var lnSubj, lnFactors: integer; var lSymptomRA: singleP; var lImageNames: TStrings; var lCrit,lCritPct: integer; {lBinomial : boolean;} var lPredictorList: TStringList):boolean;
//warning: you MUST free lPredictorList
var
lTemplateName: string;
lnRow,lCol,lnColWObs,lInc,lRow: integer;
lDesignUnspecified : boolean;
lFileList:TStringList;
lInRA: DoubleP0;
lInP: Pointer;
begin
lPredictorList := TStringList.Create;
result := false;
lnSubj := 0;
if not Fileexists(lVALFilename) then begin
MsgX('NPM aborted: VAL file selection failed:' +lValFilename);
exit;
end; //if not selected
lFileList := TStringList.Create;
//MsgX( 'VAL filename: '+lVALFilename);
if not OpenValFile (lVALFilename,lTemplateName, lnRow,lnFactors,lnColWObs,lCritPct,
lDesignUnspecified,lPredictorList,lFileList, lInP) then exit;
if lnRow > 1 then begin
lnSubj := lnRow -1; //top row is predictor
{$IFDEF FPC}
lInRA := align(lInP,16);
{$ELSE}
lInRA := DoubleP0($fffffff0 and (integer(lInP)+15));
{$ENDIF}
getmem(lSymptomRA,lnSubj*lnFactors* sizeof(single));
for lCol := 1 to lnFactors do begin
for lRow := 1 to lnSubj do begin
lSymptomRA^[lRow+ ((lCol-1)*lnSubj)] := lInRA^[(lRow*lnColWObs)-lnColWObs-1+lCol];
end;
end;
for lInc := 1 to lnSubj do
lImageNames.add(ExtractFileDirWithPathDelim(lVALFilename)+lFileList.Strings[lInc-1]);
//end reverse
end; //for lRow = each subject
lFileList.free;
Freemem(lInP);
lCrit := round( (lnSubj*lCritPct)/100);
result := true;
end;
end.
|