File: ROCR_aux.R

package info (click to toggle)
r-cran-rocr 1.0-11-2
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, sid
  • size: 676 kB
  • sloc: sh: 13; makefile: 2
file content (89 lines) | stat: -rw-r--r-- 2,954 bytes parent folder | download
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
## ---------------------------------------------------------------------------
## Dealing with argument lists, especially '...'
## ---------------------------------------------------------------------------

## return list of selected arguments, skipping those that
## are not present in arglist
.select.args <- function( arglist, args.to.select, complement=FALSE) {
    match.bool <- names(arglist) %in% args.to.select
    if (complement==TRUE) match.bool <- !match.bool
    return( arglist[ match.bool] )
}

## return arguments in arglist which match prefix, with prefix removed
## ASSUMPTION: prefix is separated from rest by a '.'; this is removed along
## with the prefix
.select.prefix <- function( arglist, prefixes, complement=FALSE ) {
    match.expr <- paste(paste('(^',prefixes,'\\.)',sep=""),collapse='|')
    match.bool <- (1:length(arglist)) %in% grep( match.expr, names(arglist) )
    if (complement==TRUE) match.bool <- !match.bool
    arglist <- arglist[ match.bool]
    names(arglist) <- sub( match.expr, '', names(arglist))

    return( arglist )
}

.garg <- function( arglist, arg, i=1) {
    if (is.list(arglist[[arg]])) arglist[[ arg ]][[i]]
    else arglist[[ arg ]]
}

.sarg <- function( arglist, ...) {
    ll <- list(...)
    for (argname in names(ll) ) {
        arglist[[ argname ]] <- ll[[ argname ]]
    }
    return(arglist)
}

.farg <- function( arglist, ...) {
    ll <- list(...)
    for (argname in names(ll) ) {
        if (length(arglist[[argname]])==0)
            arglist[[ argname ]] <- ll[[ argname ]]
    }
    return(arglist)
}

.slice.run <- function( arglist, runi=1) {
    r <- lapply( names(arglist), function(name) .garg( arglist, name, runi))
    names(r) <- names(arglist)
    r
}

## ---------------------------------------------------------------------------
## Line segments
## ---------------------------------------------------------------------------

.construct.linefunct <- function( x1, y1, x2, y2) {
    if (x1==x2) {
        stop("Cannot construct a function from data.")
    }

    lf <- eval(parse(text=paste("function(x) {",
                                "m <- (",y2,"-",y1,") / (",x2,"-",x1,");",
                                "c <- ",y1," - m * ",x1,";",
                                "return( m * x + c)}",sep=" ")))
    lf
}

#' @importFrom stats uniroot
.intersection.point <- function( f, g ) {
    ## if lines are parallel, no intersection point
    if (f(1)-f(0) == g(1)-g(0)) {
        return( c(Inf,Inf) )
    }

    ## otherwise, choose search interval
    imin <- -1
    imax <- 1
    while (sign(f(imin)-g(imin)) == sign(f(imax)-g(imax))) {
        imin <- 2*imin
        imax <- 2*imax
    }
    h <- function(x) { f(x) - g(x) }

    intersect.x <- stats::uniroot( h, interval=c(imin-1,imax+1) )$root
    intersect.y <- f( intersect.x )
    return( c(intersect.x, intersect.y ))
}