R/summary.R

#' summary
#' @method summary editmatrix
#' @param object an R object
#' @param useBlocks \code{logical} Summarize each block?
#' @param ... Arguments to pass to or from other methods 
#'
#' @rdname editmatrix
#' @export
#' @example ../examples/editmatrix.R
summary.editmatrix <- function(object, useBlocks=TRUE, ...){
    if (useBlocks){ 
        B <- blocks(object)
    } else {
        B <- list(object)
    }
    A <- array(c(
        sapply(B,nrow),
        sapply(B,function(b) sum(getOps(b) == '==')),
        sapply(B,function(b) sum(getOps(b) != '==')),
        sapply(B,function(b) length(getVars(b)) )
        ), 
        dim=c(length(B),4),
        dimnames=list(
            block = 1:length(B),
            count = c('edits','equalities','inequalities','variables')
        )
    )
    structure(A,
        class=c('editsummary'),
        type ='editmatrix',
        normalized = isNormalized(object))
}


#' summary
#'
#'
#' @param object an R object
#' @param useBlocks \code{logical} Summarize each block?
#' @method summary editarray
#' @rdname editarray
#' @export
#' @example ../examples/editarray.R
summary.editarray <- function(object, useBlocks=TRUE, ...){
    if ( useBlocks ){
        B <- blocks(object)
    } else {
        B <- list(object)
    }
    A <- array(c(
        sapply(B,nrow),
        sapply(B,function(b) length(getVars(b)))
        ),
        dim=c(length(B),2),
        dimnames=list(
            block=1:length(B),
            count=c('edits','variables')
        )
    )
    structure(A,
        class='editsummary',
        type ='editarray')
}

#' summary
#' @param object an R object
#' @param useBlocks \code{logical} Summarize each block?
#' @method summary editset
#' 
#' @rdname editset
#' @export
#' @example ../examples/editset.R
summary.editset <- function(object, useBlocks=TRUE, ...){
    if ( useBlocks ){
        B <- blocks(object)
    } else {
        B <- list(object)
    }
    A <- array(c(
        sapply(B,nedits),
        sapply(B, function(b) nrow(b$num)),
        sapply(B, function(b) nrow(b$mixcat)),
        sapply(B, function(b) length(getVars(b)))
        ),
        dim=c(length(B),4),
        dimnames=list(
            block=1:length(B),
            count=c('edits','num.edits','mix.edits','variables')
        )
    )
    structure(A,
        class='editsummary',
        type ='editset')
}



#' summary
#' @method print editsummary
#' @export
#' @keywords internal
print.editsummary <- function(x,...){
    nrm <- ''
    if ( attr(x,'type')=='editmatrix' ){
        nrm <- 'normalized'
        if (!attr(x,'normalized')) nrm = paste('non-',nrm,sep='')
    }
    cat('Summary of',nrm,attr(x,'type'),'\n')
    print(x[,,drop=FALSE])

}

#' summary
#' @param object an R object
#' @method summary errorLocation
#' @rdname errorLocation
#' @export
#' @example ../examples/localizeErrors.R
#' @importFrom stats quantile
summary.errorLocation <- function(object,...){
    prb <- c(0,0.5,1)
     
    err.per.var <- c(quantile(colSums(object$adapt,na.rm=TRUE),probs=prb,names=FALSE))
    err.per.rec <- c(quantile(rowSums(object$adapt,na.rm=TRUE),probs=prb,names=FALSE))

    A <- sapply(object$status[,1:5], function(x) quantile(x,probs=prb,names=FALSE,na.rm=TRUE))
    dimnames(A) <- list(c('min','median','max'), status=names(object$status)[1:5])
    A <- cbind(err.per.var,err.per.rec,A)
    tt <- sum(object$adapt,na.rm=TRUE)
    total <- c(tt,tt,colSums(object$status[,1:5],na.rm=TRUE))
    te <- sum(object$status$maxDurationExceeded)
    tf <- sum(is.na(object$status$weight))
    structure(rbind(A,total),
        nexceeded = c(te,te/nrow(object$adapt)),
        nnotfound = c(tf,tf/nrow(object$adapt)),
        user = object$user,
        timestamp = object$timestamp,
        call = as.character(as.expression(object$call)),
        class=c('locationsummary')
    )
}

#' summary
#' @method print locationsummary
#' @export
#' @keywords internal
print.locationsummary <- function(x,...){
    cat("Summary of 'errorLocation' object, generated by",attr(x,'user'),'at',attr(x,'timestamp'),'\n')
    cat("by calling",attr(x,'call'),'\n\n')
    cat('Results:\n')
    print(x[,,drop=FALSE])
    cat(attr(x,'nexceeded')[1],
        ' records exceeded maximum search time (',
        round(attr(x,'nexceeded')[2]*100,2), '%)\n',sep='')
    cat(attr(x,'nnotfound')[1],
        ' records did not yield a solution (',
        round(attr(x,'nnotfound')[2]*100,2), '%)\n',sep='')

}

Try the editrules package in your browser

Any scripts or data that you put into this service are public.

editrules documentation built on May 1, 2019, 6:32 p.m.