← Back to branch summary

~showard314/ubuntu/karmic/r-base/remove_start_comments

« back to all changes in this revision

Viewing changes to src/library/stats/R/symnum.R

  • Committer: Bazaar Package Importer
  • Author(s): Dirk Eddelbuettel
  • Date: 2009-04-17 06:56:48 UTC
  • mfrom: (1.3.1 upstream) (6.1.2 sid)
  • Revision ID: james.westby@ubuntu.com-20090417065648-9mgm2udb2eanluot
* New upstream version released this morning

* debian/rules: Turn optimisation back to -O3 on alpha (as elsewhere) 
  with thanks to Kurt Roeckx for applying a fix to gcc

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/library/stats/R/symnum.R
28
28
    ## Martin Maechler, 21 Jan 1994; Dedicated to Benjamin Schaad, born that day
29
29
 
30
30
    ##--------------- Argument checking -----------------------------
31
 
    if(length(x) == 0)
32
 
        return(noquote(if(is.null(d <- dim(x)))character(0) else array("", dim=d)))
 
31
    if(length(x) == 0L)
 
32
        return(noquote(if(is.null(d <- dim(x)))character(0L) else array("", dim=d)))
33
33
    has.na <- any(nax <- is.na(x))
34
34
    if(numeric.x) {
35
35
        force(corr) # missingness..
41
41
                 else gettext("'cutpoints' must be unique, but are = "),
42
42
                 paste(format(cutpoints), collapse="|"), domain = NA)
43
43
        nc <- length(cutpoints)
44
 
        minc <- cutpoints[1]
 
44
        minc <- cutpoints[1L]
45
45
        maxc <- cutpoints[nc]
46
46
        range.msg <- if(corr) gettext("'x' must be between -1 and 1")
47
47
        else gettextf("'x' must be between %s and %s",
65
65
        iS <- cut(x, breaks=cutpoints, include.lowest=TRUE, labels= FALSE)
66
66
        if(any(ii <- is.na(iS))) {
67
67
            ##-- can get 0, if x[i]== minc  --- only case ?
68
 
            iS[which(ii)[!is.na(x[ii]) & (abs(x[ii] - minc) < eps)]] <- 1#-> symbol[1]
 
68
            iS[which(ii)[!is.na(x[ii]) & (abs(x[ii] - minc) < eps)]] <- 1#-> symbol[1L]
69
69
        }
70
70
    }
71
71
##     else if(!is.logical(x))
72
72
##      stop("'x' must be numeric or logical")
73
73
    else  { ## assume logical x : no need for cut(points)
74
 
        if(!missing(symbols) && length(symbols) != 2)
 
74
        if(!missing(symbols) && length(symbols) != 2L)
75
75
            stop("must have 2 'symbols' for logical 'x' argument")
76
76
        iS <- x + 1 # F = 1,  T = 2
77
77
    }
90
90
    if(lower.triangular && is.matrix(x))
91
91
        ans[!lower.tri(x, diag = diag.lower.tri)] <- ""
92
92
    attributes(ans) <- attributes(x)
93
 
    if(is.array(ans)&& (rank <- length(dim(x))) >= 2) { # `fix' column names
 
93
    if(is.array(ans)&& (rank <- length(dim(x))) >= 2L) { # `fix' column names
94
94
        has.colnames <- !is.null(dimnames(ans))
95
95
        if(!has.colnames) {
96
96
            dimnames(ans) <- vector("list",rank)
97
97
        } else {
98
 
            has.colnames <- length(dimnames(ans)[[2]]) > 0
 
98
            has.colnames <- length(dimnames(ans)[[2L]]) > 0L
99
99
        }
100
100
        if((is.logical(abbr.colnames) || is.numeric(abbr.colnames))
101
101
           && abbr.colnames) {
102
 
            dimnames(ans)[[2]] <-
103
 
                abbreviate(dimnames(ans)[[2]], minlength= abbr.colnames)
 
102
            dimnames(ans)[[2L]] <-
 
103
                abbreviate(dimnames(ans)[[2L]], minlength= abbr.colnames)
104
104
            ## dropped further abbrev. depending on getOption("width")
105
105
        }
106
 
        else if(is.null(abbr.colnames) || is.null(dimnames(ans)[[2]]))
107
 
            dimnames(ans)[[2]] <- rep("", dim(ans)[2])
 
106
        else if(is.null(abbr.colnames) || is.null(dimnames(ans)[[2L]]))
 
107
            dimnames(ans)[[2L]] <- rep("", dim(ans)[2L])
108
108
        else if(!is.logical(abbr.colnames)) stop("invalid 'abbr.colnames'")
109
109
    }
110
110
    if(legend) {