Skip to content

Instantly share code, notes, and snippets.

@abikoushi
Last active August 29, 2015 14:10
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save abikoushi/722ce195fb70df5cc679 to your computer and use it in GitHub Desktop.
Save abikoushi/722ce195fb70df5cc679 to your computer and use it in GitHub Desktop.
create unsorted Pareto chart
#create unsorted Pareto chart
#depend on library qcc
pareto.chart2 <- function (x, unsorted=TRUE,
ylab = "Frequency", ylab2 = "Cumulative Percentage",
xlab, cumperc = seq(0, 100, by = 25), ylim, main, col = heat.colors(length(x)),
plot = TRUE, ...)
{
call <- match.call(expand.dots = TRUE)
varname <- deparse(substitute(x))
x <- as.table(x)
if (length(dim(x)) > 1)
stop("only one-dimensional object (table, vector, etc.) may be provided")
if(!unsorted){x <- sort(x, decreasing = TRUE, na.last = TRUE)} # revised part
cumsum.x <- cumsum(x)
cumperc <- cumperc[cumperc >= 0 & cumperc <= 100]
q <- quantile(seq(0, max(cumsum.x, na.rm = TRUE), by = max(cumsum.x,
na.rm = TRUE)/100), cumperc/100)
tab <- cbind(x, cumsum.x, x/max(cumsum.x, na.rm = TRUE) *
100, cumsum.x/max(cumsum.x, na.rm = TRUE) * 100)
colnames(tab) <- c("Frequency", "Cum.Freq.", "Percentage",
"Cum.Percent.")
names(dimnames(tab)) <- c("", paste("\nPareto chart analysis for",
varname))
if (plot) {
if (missing(xlab))
xlab <- ""
if (missing(ylim))
ylim <- c(0, max(cumsum.x, na.rm = TRUE) * 1.05)
if (missing(main))
main <- paste("Pareto Chart for", varname)
if (missing(col))
col <- heat.colors(length(x))
w <- max(sapply(names(x), nchar))
if (is.null(call$las))
las <- 3
else las <- call$las
if (is.null(call$mar)) {
if (las == 1)
mar <- c(1, 1, 0, 2)
else mar <- c(log(max(w), 2), 0, 0, 2)
}
else mar <- call$mar
oldpar <- par(mar = pmax(par("mar") + mar, c(4.1, 4.1,
3.1, 4.1)), las = las, cex = qcc.options("cex"),
no.readonly = TRUE)
on.exit(par(oldpar))
pc <- barplot(x, width = 1, space = 0.2, main = main,
ylim = ylim, ylab = ylab, xlab = xlab, yaxt = "n",
col = col, ...)
abline(h = q, col = "lightgrey", lty = 3)
rect(pc - 0.5, rep(0, length(x)), pc + 0.5, x, col = col)
lines(pc, cumsum.x, type = "b", cex = 0.7, pch = 19)
box()
axis(2, las = 3)
axis(4, at = q, las = 3, labels = paste(cumperc, "%",
sep = ""))
mtext(ylab2, 4, line = 2.5, las = 3)
}
return(tab)
}
@abikoushi
Copy link
Author

Example

library(qcc)
library(devtools)
source_gist("https://gist.github.com/abikoushi/722ce195fb70df5cc679")
defect <- c(80, 27, 66, 94, 33)
names(defect) <- c("price code", "schedule date", "supplier code", "contact num.", "part num.")
pareto.chart2(defect, ylab = "Error frequency")
pareto.chart2(defect, unsorted=FALSE, ylab = "Error frequency")

see also

pareto.chart {qcc}

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment