R help - May 2013 - column width in .dbf files using write.dbf ... to be continued

Hello Arnaud,

You posted this question a long long time ago, however I found your answer so I
decided to post it anyway in case somebody else have the same problem as you and
me.

You were actually very close in finding your solution.  The function DoWritedbf
is an internal function from the foreign package.  To access it outside of the
package just do:

foreign:::DoWritedbf

so in your line:

invisible(.Call(foreign:::DoWritedbf, as.character(file), dataframe,
  as.integer(precision), as.integer(scale), as.character(DataTypes)))

It is explain here:
http://stackoverflow.com/questions/2165342/r-calling-a-function-from-a-namespace

Sorry for the delay in my answer...

Bastien Ferland-Raymond, M.Sc. Stat., M.Sc. Biol.
Division des orientations et projets sp?ciaux
Direction des inventaires forestiers
Minist?re des Ressources naturelles

In reply to :
#####
Dear UseRs,
I did not have any answer to my previous message ("Is there a way to define
"manually" columns width when using write.dbf function from the
library foreign ?"), so I tried to modify write.dbf function to do what I
want.
Here is my modified version :
write.dbfMODIF <- function (dataframe, file, factor2char = TRUE, max_nchar =
254, width = d)
{
    allowed_classes <- c("logical", "integer",
"numeric", "character",
        "factor", "Date")
    if (!is.data.frame(dataframe))
        dataframe <- as.data.frame(dataframe)     if (any(sapply(dataframe,
function(x) !is.null(dim(x)))))
        stop("cannot handle matrix/array columns")     cl <-
sapply(dataframe, function(x) class(x[1L]))     asis <- cl ==
"AsIs"
    cl[asis & sapply(dataframe, mode) == "character"] <-
"character"     if (length(cl0 <- setdiff(cl, allowed_classes)))
        stop("data frame contains columns of unsupported class(es) ",
            paste(cl0, collapse = ","))

    m <- ncol(dataframe)
    DataTypes <- c(logical = "L", integer = "N", numeric
= "F",
        character = "C", factor = if (factor2char) "C" else
"N",
        Date = "D")[cl]
    for (i in seq_len(m)) {
        x <- dataframe[[i]]
        if (is.factor(x))
            dataframe[[i]] <- if (factor2char)
                as.character(x)
            else as.integer(x)
        else if (inherits(x, "Date"))
            dataframe[[i]] <- format(x, "%Y%m%d")
    }
    precision <- integer(m)
    scale <- integer(m)
    dfnames <- names(dataframe)
    for (i in seq_len(m)) {
        nlen <- nchar(dfnames[i], "b")
        x <- dataframe[, i]
        if (is.logical(x)) {
            precision[i] <- 1L
            scale[i] <- 0L


        }

        else if (is.integer(x)) {
            rx <- range(x, na.rm = TRUE)
            rx[!is.finite(rx)] <- 0
            if (any(rx == 0))
                rx <- rx + 1
            mrx <- as.integer(max(ceiling(log10(abs(rx)))) +
                3L)
            precision[i] <- min(max(nlen, mrx), 19L)
            scale[i] <- 0L


        }

        else if (is.double(x)) {
            precision[i] <- 19L
            rx <- range(x, na.rm = TRUE)
            rx[!is.finite(rx)] <- 0
            mrx <- max(ceiling(log10(abs(rx))))
            scale[i] <- min(precision[i] - ifelse(mrx > 0L, mrx +
                3L, 3L), 15L)


        }

        else if (is.character(x)) {
        if (width == "d") {
                   mf <- max(nchar(x[!is.na(x)], "b"))
                p <- max(nlen, mf)
                if (p > max_nchar)
                    warning(gettext("character column %d will be truncated
to %d bytes",
                      i, max_nchar), domain = NA)
                precision[i] <- min(p, max_nchar)
                scale[i] <- 0L


        } else {


            if (width > max_nchar)
                    warning(gettext("character column %d will be truncated
to %d bytes",
                      i, max_nchar), domain = NA)
                precision[i] <- min(width, max_nchar)


        }

        }

        else stop("unknown column type in data frame")
    }
    if (any(is.na(precision)))
        stop("NA in precision")
    if (any(is.na(scale)))
        stop("NA in scale")
    invisible(.Call(DoWritedbf, as.character(file), dataframe,
        as.integer(precision), as.integer(scale), as.character(DataTypes))) }
However, when I wanted to use this function ... it does not find the DoWritedbf
function that is called in the last lines (a function written in C).
Is there a way to temporally replace the original write.dbf function by this one
in the foreign package ?
Thanks,
Arnaud
R version 2.10.0 (2009-10-26)
i386-pc-mingw32
######

Thanks Bastien,
I completely forgot that I asked this question.
I learned a lot since then ... actually, now I know how to do it, but it
was not the case in 2009 :-)

Arnaud


2013/5/22 <Bastien.Ferland-Raymond@mrn.gouv.qc.ca>
>
> Hello Arnaud,
>
> You posted this question a long long time ago, however I found your answer
> so I decided to post it anyway in case somebody else have the same problem
> as you and me.
>
> You were actually very close in finding your solution.  The function
> DoWritedbf is an internal function from the foreign package.  To access it
> outside of the package just do:
>
> foreign:::DoWritedbf
>
> so in your line:
>
> invisible(.Call(foreign:::DoWritedbf, as.character(file), dataframe,
>   as.integer(precision), as.integer(scale), as.character(DataTypes)))
>
> It is explain here:
>
http://stackoverflow.com/questions/2165342/r-calling-a-function-from-a-namespace
>
> Sorry for the delay in my answer...
>
> Bastien Ferland-Raymond, M.Sc. Stat., M.Sc. Biol.
> Division des orientations et projets spéciaux
> Direction des inventaires forestiers
> Ministère des Ressources naturelles
>
> In reply to :
> #####
> Dear UseRs,
> I did not have any answer to my previous message ("Is there a way to
> define "manually" columns width when using write.dbf function
from the
> library foreign ?"), so I tried to modify write.dbf function to do
what I
> want.
> Here is my modified version :
> write.dbfMODIF <- function (dataframe, file, factor2char = TRUE,
max_nchar
> = 254, width = d)
> {
>     allowed_classes <- c("logical", "integer",
"numeric", "character",
>         "factor", "Date")
>     if (!is.data.frame(dataframe))
>         dataframe <- as.data.frame(dataframe)     if
> (any(sapply(dataframe, function(x) !is.null(dim(x)))))
>         stop("cannot handle matrix/array columns")     cl <-
> sapply(dataframe, function(x) class(x[1L]))     asis <- cl ==
"AsIs"
>     cl[asis & sapply(dataframe, mode) == "character"] <-
"character"
> if (length(cl0 <- setdiff(cl, allowed_classes)))
>         stop("data frame contains columns of unsupported class(es)
",
>             paste(cl0, collapse = ","))
>
>     m <- ncol(dataframe)
>     DataTypes <- c(logical = "L", integer = "N",
numeric = "F",
>         character = "C", factor = if (factor2char) "C"
else "N",
>         Date = "D")[cl]
>     for (i in seq_len(m)) {
>         x <- dataframe[[i]]
>         if (is.factor(x))
>             dataframe[[i]] <- if (factor2char)
>                 as.character(x)
>             else as.integer(x)
>         else if (inherits(x, "Date"))
>             dataframe[[i]] <- format(x, "%Y%m%d")
>     }
>     precision <- integer(m)
>     scale <- integer(m)
>     dfnames <- names(dataframe)
>     for (i in seq_len(m)) {
>         nlen <- nchar(dfnames[i], "b")
>         x <- dataframe[, i]
>         if (is.logical(x)) {
>             precision[i] <- 1L
>             scale[i] <- 0L
>
>
>         }
>
>         else if (is.integer(x)) {
>             rx <- range(x, na.rm = TRUE)
>             rx[!is.finite(rx)] <- 0
>             if (any(rx == 0))
>                 rx <- rx + 1
>             mrx <- as.integer(max(ceiling(log10(abs(rx)))) +
>                 3L)
>             precision[i] <- min(max(nlen, mrx), 19L)
>             scale[i] <- 0L
>
>
>         }
>
>         else if (is.double(x)) {
>             precision[i] <- 19L
>             rx <- range(x, na.rm = TRUE)
>             rx[!is.finite(rx)] <- 0
>             mrx <- max(ceiling(log10(abs(rx))))
>             scale[i] <- min(precision[i] - ifelse(mrx > 0L, mrx +
>                 3L, 3L), 15L)
>
>
>         }
>
>         else if (is.character(x)) {
>         if (width == "d") {
>                    mf <- max(nchar(x[!is.na(x)], "b"))
>                 p <- max(nlen, mf)
>                 if (p > max_nchar)
>                     warning(gettext("character column %d will be
truncated
> to %d bytes",
>                       i, max_nchar), domain = NA)
>                 precision[i] <- min(p, max_nchar)
>                 scale[i] <- 0L
>
>
>         } else {
>
>
>             if (width > max_nchar)
>                     warning(gettext("character column %d will be
truncated
> to %d bytes",
>                       i, max_nchar), domain = NA)
>                 precision[i] <- min(width, max_nchar)
>
>
>         }
>
>         }
>
>         else stop("unknown column type in data frame")
>     }
>     if (any(is.na(precision)))
>         stop("NA in precision")
>     if (any(is.na(scale)))
>         stop("NA in scale")
>     invisible(.Call(DoWritedbf, as.character(file), dataframe,
>         as.integer(precision), as.integer(scale),
> as.character(DataTypes))) }
> However, when I wanted to use this function ... it does not find the
> DoWritedbf function that is called in the last lines (a function written in
> C).
> Is there a way to temporally replace the original write.dbf function by
> this one in the foreign package ?
> Thanks,
> Arnaud
> R version 2.10.0 (2009-10-26)
> i386-pc-mingw32
> ######
>
>
>
	[[alternative HTML version deleted]]