## Copyright (C) 2015-2018 Philip Nienhuis
##
## This program is free software; you can redistribute it and/or modify it
## under the terms of the GNU General Public License as published by
## the Free Software Foundation; either version 3 of the License, or
## (at your option) any later version.
##
## This program is distributed in the hope that it will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
## GNU General Public License for more details.
##
## You should have received a copy of the GNU General Public License
## along with this program. If not, see .
## -*- texinfo -*-
## @deftypefn {Function File} [@var{status}] = dbfwrite (@var{fname}, @var{data})
## Write data in a cell array to a dbf (xBase) file, provisionally dBase III+.
##
## @var{fname} must be a valid file name, optionally with '.dbf' suffix.
## @var{data} should be a cell array of which the top row contains column
## names (character strings). Each column must contain only one class of data,
## except of course the top entry (the column header).
## Value type that can be written are character (text sring), numeric
## (integer and float, the latter with 6 decimal places), and logical.
##
## Ouput argument @var{status} is 1 if the file was written successfully, 0
## otherwise.
##
## Provisionally only dBase v. III+ files can be written without memos.
##
## @seealso{dbfread}
## @end deftypefn
## Author: Philip Nienhuis
## Created: 2014-12-24
function [status] = dbfwrite (fname, data)
status = 0;
## Input validation
if (! ischar (fname))
error ("dbfwrite: file name expected for argument #1\n");
elseif (! iscell (data))
error ("dbfwrite: cell array expected for argument #2\n");
elseif (! iscellstr (data (1, :)))
error ("dbfwrite: column header titles (text) expected on first row of data\n");
endif
## Column headers length cannot exceed 10 characters
toolong = [];
for ii=1:size (data, 2)
title = data{1, ii};
if (length (title) > 10)
toolong = [ toolong, ii ];
data(1, ii) = title(1:10);
endif
endfor
if (! isempty (toolong))
## Truncate headers if required and check for uniqueness
warning ("dbfwrite: one or more column header(s) > 10 characters - truncated\n");
fmt = [repmat(sprintf ("%d "), 1, numel (toolong))(:)];
printf ("Applies to columns %s\n", sprintf (fmt, toolong));
if (numel (unique (data(1, :))) < numel (data(1, :)))
error ("dbfwrite: column headers aren't unique - please fix data\n");
endif
endif
## Assess nr of records
## Data contains header row. Data toprow = 2
nrecs = size (data, 1) - 1;
tr = 2;
## Check file name
[pth, fnm, ext] = fileparts (fname);
if (isempty (ext))
fname = [fname ".dbf"];
elseif (! strcmpi (ext, ".dbf"))
error ("dbfwrite: file name should have a '.dbf' suffix\n");
endif
## Try to open file
fid = fopen (fname, "w+");
if (fid < 0)
error ("dbfwrite: could not open file %s\n", fname);
endif
## Start writing header
## Provisionally assume dbase III+ w/o memos
fwrite (fid, 3, "uint8");
upd = datevec (date);
fwrite (fid, upd(1) - 1900, "uint8");
fwrite (fid, upd(2), "uint8");
fwrite (fid, upd(3), "uint8");
fwrite (fid, nrecs, "uint32");
## The next two uint16 fields are to be written later, just fill temporarily
pos_lhdr = ftell (fid);
fwrite (fid, 0, "uint32");
## Another place holder, write enough to allow next fseek to succeed
fwrite (fid, uint32 (zeros (1, 7)), "uint32");
## Write record descriptors
nfields = size (data, 2);
fldtyp = "";
fldlngs = {};
reclen = 1; ## "Erased" byte first
fseek (fid, 32, "bof");
for ii=1:nfields
decpl = 0;
recdesc = sprintf ("%d", uint32 (zeros (1, 8)));
recdesc(1:10) = strjust (sprintf ("%10s", data{1, ii}), "left"); ## Field name
if (isnumeric ([data{tr:end, ii}]))
if (isinteger ([data{tr:end, ii}]) ||
all ([data{tr:end, ii}] - floor([data{tr:end, ii}]) < eps))
ftype = "N";
decpl = 0;
else
ftype = "F";
## ML compatibility for .dbf/.shp file: 6 decimal places
decpl = 6;
endif
fldlng = 20;
elseif (ischar ([data{tr:end, ii}]))
ftype = "C";
fldlng = max (cellfun (@(x) length(x), data(tr:end, ii)));
elseif (islogical ([data{tr:end, ii}]))
ftype = "L";
fldlng = 1;
endif
recdesc(12) = ftype; ## Field type
fldtyp = [ fldtyp ftype ];
recdesc(17) = uint8 (fldlng); ## Field length
recdesc(18) = uint8 (decpl); ## Decimal places
recdesc(32) = "\0"; ## Fill to byte# 32
fwrite (fid, recdesc, "char");
reclen += fldlng;
fldlngs = [ fldlngs; sprintf("%d", fldlng) ];
endfor
## Write header record terminator
fwrite (fid, 13, "uint8");
## Remember position
fpos_data = ftell (fid);
## Write missing data in header
fseek (fid, pos_lhdr, "bof");
fwrite (fid, fpos_data, "uint16");
fwrite (fid, reclen, "uint16");
## Write data2
fseek (fid, fpos_data, "bof");
## FIXME replace by vectorized code (num2str etc) & concatenating columns
## for speeding up
for ii=tr:nrecs+tr-1
## Write "erased" byte
fwrite (fid, "\0", "uint8");
for jj=1:nfields
switch fldtyp(jj)
case "C"
txt = sprintf (["%" fldlngs{jj} "s"], data{ii, jj});
case "N"
txt = sprintf (["%" fldlngs{jj} "d"], data{ii, jj});
case "L"
if (data{ii, jj})
txt = "Y";
else
txt = "N";
endif
case "F"
txt = sprintf (["%" fldlngs{jj} "f"], data{ii, jj});
case "D"
% txt = sprintf (["%" fldlngs{jj} "s"], data{ii, jj});
otherwise
endswitch
fwrite (fid, txt, "char");
endfor
endfor
## Close file
fclose (fid);
status = 1;
endfunction