Sig: Ficheros de Ejecuciones Sup: Cronometrado de un programa Ant: Con diferente tamaño y Err: Si hallas una errata ...

Un poco de OOP en R

# Lectura y construcción del objeto
read.bench <- function(filename = "log.txt", benchfile = ".benchrc") {
  x <- read.table(filename, header=T);
  x$FILE <- as.factor(filename)
  class(x) <- c("bench", "data.frame");
  attr(x,"FILE") <- filename;
  # Establecer los demas atributos del fichero de "bench"
  z <- readLines(benchfile);
  novalid <- grep("^#|(^\s*$)", z, perl=TRUE)
  z <- z[-novalid]
  z <- gsub("([^\\])\"","\\1",z) # quitamos " no escapadas
  for (i in z) {
    couple <- strsplit(i, "\\s*=\\s*", perl=TRUE)
    name <- couple[[1]][1]; value <- couple[[1]][2]
    attr(x, name) <- value
  }
  x
}

is.bench <- function(x) inherits(x, "bench")

bench <- function(...) {
  x <- data.frame(...)
  class(x) <- c("bench", "data.frame")
  x
}

as.bench <- function(x) { if (is.bench(x)) x else bench(x) }

# Establece el atributo FILE de un bench
# Importante: el segundo argumento se tiene que 
# llamar "value"

"filename<-" <- function(y, value) {
   if (missing(y) || (class(y) != "bench")) {
     stop("Expecting a bench object")
   }
   attr(y, "FILE") <- value;
   y
}

# Devuelve el atributo FILE de un bench
filename <- function(y) {
   if (missing(y) || (class(y) != "bench")) {
     stop("Expecting a bench object")
   }
   attr(y, "FILE")
}

summary.bench <- function (x) { 
  if (missing(x) || (class(x) != "bench")) {
    stop("Expecting a bench object")
  }
  attach(x); 
  on.exit(detach(x)); 
  data.frame(
    SIZE=unique(SIZE), 
    NREP=as.numeric(table(SIZE)),
    BEST=tapply(CPU, SIZE, min),
    WORSE=tapply(CPU, SIZE, max), 
    AVERAGE=tapply(CPU, SIZE, mean),
    MEDIAN=tapply(CPU, SIZE, median))
}

plot.bench <- function(x, ...) {
  if (missing(x) || (class(x) != "bench")) {
    stop("Expecting a bench object")
  }
  plot(x$CPU~x$SIZE,
    xlab="SIZE", ylab="CPU TIME",
    main = attr(x, "PROGRAM"),
    sub = paste("File ", attr(x, "FILE")[1]),
    ...
  )
  y <- summary(x);
  on.exit(detach(y))
  attach(y)
  points(SIZE, WORSE, col="red", lty="dashed", type="l")
  points(SIZE, BEST, col="red", lty="dashed", type="l")
  points(SIZE, MEDIAN, col="blue", lty="dotdash", type="l")
  points(SIZE, AVERAGE, col="green", lty="dotted", type="l")
}

hist.bench <- function (x, cut = 2, layout.limit = 9, ...) {
  on.exit(detach(x))
  attach(x)

  sizes = sort(unique(SIZE))
  nr = length(sizes) 
  nc = round(sqrt(nr))
  nr = round(nr/nc)
  if (nr*nc < layout.limit) { layout.size = nr*nc }
  else { 
    layout.size = layout.limit; 
    nr = round(sqrt(layout.limit))
    nc = round(layout.limit/nr)
  }
  layout(matrix(1:layout.size, nrow=nr, ncol=nc, byrow=TRUE))
  interactively <- (interactive() &&
   (getOption("device") %in% c("X11", "GTK", "gnome", "windows", "Macintosh")))
  par(ask=interactively)
  painted = 0
  while (painted < length(sizes)) {
    for (i in sizes) {
      if ((sum(SIZE == i)) >  cut) {
        b <- x$CPU[x$SIZE==i]
        barplot(table(b), 
          main=paste(attr(x, "PROGRAM")," SIZE=",i), 
          ylab="Frequency", xlab="Time",
        )
      }
      painted = painted+1
    }
  }
}

# Ejemplos de sobrecarga de operadores
"+.bench" <- function(b1, b2) {
  if (missing(b1) || missing(b2) || !is.bench(b1) || !is.bench(b2)) {
    stop("Expecting a bench object")
  }
  x <- rbind(b1, b2)
  i <- sort.list(x$SIZE)
  x$SIZE   <- x$SIZE[i]
  x$SORTED <- x$SORTED[i]
  x$wall   <- x$wall[i]
  x$cusr   <- x$cusr[i]
  x$csys   <- x$csys[i]
  x$CPU    <- x$CPU[i]
  x$FILE   <- x$FILE[i]
  rownames(x) <- 1:length(x$SIZE)
  #concatenar atributos
  for (i in names.attributes.bench()) {
    attr(x, i) <- c(attr(b1,i), attr(b2,i))
  }
  x
}

# Computa la intersección. 
# Ejemplo de llamada: w[w$SIZE > 40000,]*z[z$SIZE < 80000,]
"*.bench" <- function(b1, b2) {
  if (missing(b1) || missing(b2) || !is.bench(b1) || !is.bench(b2)) {
    stop("Expecting a bench object")
  }
  sizes <- sort(unique(b1$SIZE))
  x <- b1[0,];
  for (i in sizes) {
    if (sum(b2$SIZE == i) > 0) {
      t1 <- b1[b1$SIZE == i,]
      t2 <- b2[b2$SIZE == i,]
      x <- rbind(x, t1, t2)
    }
  }
  rownames(x) <- 1:length(x$SIZE)
  #concatenar atributos
  for (i in names.attributes.bench()) {
    attr(x, i) <- c(attr(b1,i), attr(b2,i))
  }
  x
}

names.attributes.bench <- function() {
c("FILE",
"TEST_FILE",
"PROGRAM",
"TITLE",
"GRAIN",
"TIMES",
"OUTPUT_DEVICE",
"OUTPUT_FILE",
"COLUMNS",
"GENERATE_INPUT",
"SUPPORT_FILE",
"FIRST"
)
}

print.bench <- function (x, cut=0, ...) {
  if (cut != 0) {
    x$FILE <- sub(paste("(.{",cut,"}).*", sep=""),"\\1",x$FILE);
  }
  print.data.frame(x, ...)
}

comments <- function( ... ) { 
  objects <- ls(env = parent.env(environment()), ...)
  string <- character(0)
  for (i in objects) {
    # Si es un identificador normal ...
    if (length(grep("^(\\w|\\.)+$",i,perl=TRUE))>0) {
      c <- comment(eval(parse(text = i)))
      if (!is.null(c)) { # si tiene comentario
        c <- paste(i,c,sep=": ")
        string <- c(string, c)
      }
    }
  }
  print.noquote(string)
}

slope.error <- function(x.lm, values = SIZE, ... ) {
  s.e2 <- var(residuals(x.lm))
  N2 <- df.residual(x.lm)
  s.x2 <- var(values)
  sqrt(s.e2/(N2*s.x2))
}

t.value <- function(x.lm, values = SIZE, beta = 0, ...) {
  b <- coefficients(x.lm)[2]
  N2 <- df.residual(x.lm)
  s.e2 <- var(residuals(x.lm))
  s.x2 <- var(values)
  t <- (b - beta)*sqrt((N2*s.x2)/s.e2)
  p <- pt(abs(t), N2, lower.tail=F)*2
  x <- c(t, p)
  names(x) <- c("t.value", "pr.gt.t");
  x
}

t.interval <- function(x.lm, values, p = 0.05, ...) {
  b <- coefficients(x.lm)[2]
  N2 <- df.residual(x.lm)
  s.e2 <- var(residuals(x.lm))
  s.x2 <- var(values)
  q <- qt(p, N2, lower.tail=FALSE)
  w <- q*sqrt(s.e2/(N2*s.x2))
  interval <- c(b-w, b+w)
  names(interval) <- c("left", "right")
  interval
}

standardize <- function(x) (x -mean(x))/sd(x)

screen2x2 <- function(d = c(2, 2)) {
  par(mfrow=d)
}

Sig: Ficheros de Ejecuciones Sup: Cronometrado de un programa Ant: Con diferente tamaño y Err: Si hallas una errata ...