epicalc/0000755000176000001440000000000012026255064011704 5ustar ripleyusersepicalc/MD50000644000176000001440000001440412026255064012217 0ustar ripleyusers0ca08fb2e6419cce6d173ef1f26d3c27 *DESCRIPTION a7029ab4e2d345ccd376d76e711f28f6 *NAMESPACE 1ad1067efc042fe95459eaf240159266 *R/epicalc.R 1721d9a396b168fe50a85b52adbc228f *data/ANCdata.rdata c1ddefc687a4e0421362affcbb17debb *data/ANCtable.txt.gz af5abbf83afc371f6a64009cd3eb9106 *data/Attitudes.rdata b74941b9c0e39aab9ce46a65cc0e6017 *data/BP.rdata 10ac1bc5995389c482bbe6278d6b8490 *data/Bang.txt.gz db376e7583b47344e08781fc3aa7c6a9 *data/Compaq.rdata ce97b37315be80409eef2acf20fa0a5d *data/DHF99.rda 7c2b03dfe8f264eb68069cfa94c3a64f *data/Decay.rdata 9d741cd6bb48601c76283de22888a935 *data/Ectopic.rdata 976c174d476db6c9393a3d1e55524e7e *data/Familydata.rda 60ae2fa6584ba23c3a20d8fbdf26440a *data/HW93.rdata 07c33360f778472b379ee3f918eaf808 *data/Hakimi.txt.gz ee77f961ef2713e723d024de4437aa76 *data/IudAdmit.rdata ee5a0c2d399978a5ec13a52402ed3751 *data/IudDiscontinue.rdata ce582503413b73e86268bc542c1e6382 *data/IudFollowup.rdata 874058f386c420c865b2f01588e95054 *data/Marryage.rdata 5b42f9375cc9fce94930ee00e8400fb0 *data/Montana.txt.gz 5a358d6a350000c3b3bc863abd5cd667 *data/Oswego.rdata 1ee4d5c3c0a59df7c61af372d3cbaf4e *data/Outbreak.rdata 3f68a8c96a0782405b696b09b469c550 *data/Planning.rda b20d998e2af19f79ba051575adda1c53 *data/SO2.rda f2b594fd2353ae9b392d8bb7706e7873 *data/Sleep3.rdata 1c0228037216d81e564191c5d4a2bfc2 *data/Suwit.rdata 8c6aa5cbfc373c34e646fb4b1ef4fb17 *data/Timing.rdata a31159d20bffdd2cd691df910d88d41c *data/VC1to1.rdata a32744b74bc4149729c1a47ccdb09e16 *data/VC1to6.rdata 1ea982f70fd11fac9532e5b36cef32bb *data/VCT.rdata b11f04ad27fb73c6ea475554381aa98c *data/Xerop.rdata 8676ade3887e44c6161064766705a430 *demo/00Index 0569071645c9419c7d563d6f1a1208de *demo/Epicalc.features.r ac3f402503ebd2cc05b24cbca675a6cc *man/ANCdata.Rd 56f320374198e33905bf41f97bc12339 *man/ANCtable.rd 258ad8ddeeeb2100fc7f7d0bb9a74aaa *man/Attitudes.rd add2184be6005a39cbe28663dd664d03 *man/BP.rd 360c9a43602a5f45c2e6f93499dfb99b *man/Compaq.rd b15a6d51791a2767338636fb162c2183 *man/DHF99.Rd ea2400846cce54aead3f2aeed742e459 *man/Decay.rd 7c2cd5fa3108fb3bb505a1fb4b4cb66c *man/Ectopic.Rd 4c60aac8c00ddc6089e8ce09774bcc58 *man/Familydata.Rd 68aa04ef1d4439569bb2b992433a5ddb *man/HW93.Rd 950b14a4fb09192987c15c073a3f0b26 *man/Hakimi.rd 94923887d2f2843568ec6bbf556590ac *man/IudAdmit.rd 1ac989233f49db3d232edfd7eedb3f95 *man/IudDiscontinue.rd c2c15250d9136b9387b80fc0658e5e67 *man/IudFollowup.rd 0ef5c444803095ca3f8fcfb9a8b274ff *man/Marryage.Rd 4f32957d6f1fa99c13bf1fe27e8b3934 *man/Montana.rd b0b7d898d62f73311cd480c9d5cfa697 *man/Oswego.rd 0279095f67c1f244063e752221074ca6 *man/Outbreak.rd ff0995ca289b5eb36c02a3d457f85f56 *man/Planning.rd d249e2f58b77d9e7ec5ab6ed760d95c1 *man/SO2.Rd e09a0d0827415199e0138089ff6b1de0 *man/Sleep3.Rd 49c850411e4afac90dec668b138f538d *man/Suwit.Rd aeb3b19d389cbcd6914c682211227e2f *man/Timing.Rd db4026d637b5a72e97b4c3577a7bd043 *man/VCT.rd cd7145b2f22fb45cf227d115978ef233 *man/Vc1to1.rd da8fad92605356060b08dbfc1efc30b1 *man/Xerop.rd 0cd43ae08083059da23a80808234a14d *man/addMissingRecords.rd 9608d02cf938c8ab2b3d966d04caaf7b *man/adjust.rd 55225f7928e5b48a75824136c1915d86 *man/aggregate.numeric.rd cbab361898d3e545deb9a628ab5d4999 *man/aggregate.plot.rd 0378be67ad6f3bd68a6aed21e6e9e263 *man/alpha.rd 09adf0ee65fd2cd8d316466e13eb2f0e *man/auc.rd 00a4f440548f98a0041f0762530a3961 *man/bang.rd e3864cad8d857ebbe6f53015cbbcf526 *man/be2ad.rd 34beee2551c599d9745b38b6c4e840df *man/cc.rd 57e910fcdc669d2b58dc29b2f7af4623 *man/ci.rd 8eb1e850ca97103400ccfb59a02e43ad *man/codebook.rd 18cef11c983f5b62c2a5befd66662eb2 *man/des.rd a7ceacf9cecbff2ab3a5002ec2233a0a *man/detachAlllData.rd b05ac9f552b153cda0bcec73729777bf *man/dotplot.rd cafa7528254d902379359519c4d53078 *man/expand.rd 5455292c07818c8798d78f6994abdc1a *man/fillin.rd b2f1048a1c52efd9e6da84f8718a1302 *man/followup.plot.rd 6a44510e3acf7e1effb05557aa9376f3 *man/kap.rd 8308d4fe9cd83761871d0bdc0532d081 *man/keepData.rd 4d7123503fc2f25df3144273ab320abf *man/label.var.rd 42554d536bb9191bdd0226a3a701f5dc *man/lagVar.rd 943699995ac214ef9e569c76cf5d9906 *man/lookup.rd b2696f2723cae99754efb3e46bbc4008 *man/lrtest.rd 8b86026730db77d2cec2dbdf91a28fc9 *man/lsNoFunction.rd e0211f82cdf428fad19571eab5372823 *man/markVisits.rd 71a87c0ad4f493ceaaf09e924ead0ec6 *man/matchTab.rd 8ba0c30f5b58e59040f350dc92728db2 *man/merge.lab.rd 883a69e4fcd3b9dcd289698991eeb91b *man/mhor.rd 3da38b1fd55e0440b6154f60a51e523b *man/poisgof.rd d0812c38cf9893ed00ec282cc47094ae *man/power.for.2means.rd 3ce2de01ce6904b631eedf01b04b2a99 *man/power.rd ee5830516339c15bb4e5474af30dbd15 *man/print.alpha.rd abd1607ad3940db6d707a8406134f47c *man/print.cci.rd 51b6904a353f64bf6e561cecc63291d7 *man/print.des.rd 701e8676c916b8c3dc6f25ae385ffd50 *man/print.kap.ByCategory.rd c47276e99743ddcdf53dfac55f9cb936 *man/print.kap.table.rd 8d35042898cc2cc841e830a532a4d338 *man/print.lrtest.rd ed303bd6bd17cd5733a1a3acc7e02323 *man/print.n.for.2means.rd ef96f4b8b4e60f2d86b4eb86e5ece360 *man/print.n.for.2p.rd c5d638ac77b51ac22656055731953e13 *man/print.n.for.cluster.2means.rd 5e0620b6233948a28812f211e15e5c41 *man/print.n.for.cluster.2p.rd 7310cf967c767aae04f23ac2f30753ff *man/print.n.for.equi.2p.rd 3c8c9d033362973233f73211a058edd4 *man/print.n.for.lqas.rd a185a16fe0b7a30779dba73b46f381e4 *man/print.n.for.noninferior.2p.rd 5197211e1351d347d13583cad5a7d2f2 *man/print.n.for.survey.rd 83d509c3f444242b6c564d45301a812c *man/print.power.for.2p.rd 51027ec29cd79d1ac9bf4718a78b3fab *man/print.summ.rd 45c8d5ce54a89b52c42e3aa1e1a4808f *man/print.tableStack.rd 3256eaf21745ce6617fbc01c96356929 *man/pyramid.rd b9830e5cef92c2361b2852240c07ff4d *man/recode.rd 64de73205cd08a0e270850ab275bcc71 *man/rename.rd cfe2d2a33101ad848019b3c4687388cd *man/risk.display.rd b032c7dab030c105983848a7c913b943 *man/roc.rd a8fe624bea5dbd0a8b54b922507d9365 *man/sampsize.rd 8548945cf4ad6ea1c60ecfbd97068e36 *man/setTitle.rd 4ef70c1e97c4ed8d9b134b82ebabf98f *man/shapiro.qqnorm.rd d1112f183e41c0869a4b8799dc5a0e7b *man/sortBy.rd 4afa2f6c82060cd8043d590dd6782a93 *man/summ.rd 57aeae04190080742ef5d49e812b3e2c *man/tab1.rd d350d29c584a5fdc63661ffbd4c6262e *man/tableStack.rd 5f077ee0762704bed014948e0a8b723e *man/tabpct.rd caa582cc8fae84f921313ac5ac170a89 *man/tally.events.rd c40f827949feb0b87802c2ffbbba41e7 *man/titleString.rd 5bff92fc08dfa3e03d1219c201b035f7 *man/unclassDataframe.rd 7a5df4cafd280a0819eacac508367e6a *man/use.rd b5f540781728e80cc0894eec3b7bad09 *man/zap.rd epicalc/R/0000755000176000001440000000000012026244665012112 5ustar ripleyusersepicalc/R/epicalc.R0000644000176000001440000117211612026244665013646 0ustar ripleyusers# This file is written to make simple epidemiological calculator available on R. # Prepared by # Virasakdi Chongsuvivatwong, Epidemiology Unit, # Prince of Songkla University # Hat Yai, Thailand 90110 # License: GPL version 2 or newer # Work started in 2002-October ## The below .locale is a local function. Thanks to Kurt Hornik for the trick. .locale <- local({ val <- FALSE # All automatic graphs will initially have English titles function(new){ if(!missing(new)) val <<- new else val } }) .distribution.of <- "Distribution of" .by <- "by" .frequency <- "Frequency" .frequency1 <- "Frequency" .No.of.observations <- "No. of observations = " .ylab.for.summ <- "Subject sorted by X-axis values" .percent <- "Percent" .cum.percent <- "Cum. percent" .var.name <- "Var. name" .obs <- "obs." .mean <- "mean " .median <- "median " .sd <- "s.d. " .min <- "min. " .max <- "max. " codebook <- function (dataFrame = .data) { cat("\n", attr(dataFrame, "datalabel"), "\n", "\n") x1 <- dataFrame[1, ] for (i in 1:ncol(dataFrame)) { cat(paste(names(dataFrame)[i], "\t", ":", "\t", attr(dataFrame, "var.labels")[i]), "\n") if (all(is.na(dataFrame[, i]))) { cat(paste("All elements of ", names(dataFrame)[i], " have a missing value", "\n")) } else { if (any(class(x1) == "data.frame")) { x2 <- x1[, i] } else { x2 <- x1 } if (any(class(x2) == "character") | any(class(x2) == "AsIs")) { cat("A character vector", "\n") } else { if (any (class(x2) == "difftime")) { print(summary(x2)) } else{ if (is.logical(x2)) x2 <- as.factor(x2) if (any(class(x2) == "factor")) { table1 <- (t(t(table(dataFrame[, i])))) table1 <- cbind(table1, format(table1/sum(table1) * 100, digits = 3)) colnames(table1) <- c(.frequency1, .percent) if (is.null(attr(dataFrame, "val.labels")[i])) { print.noquote(table1, right = TRUE) } else { if (any(is.na(attr(dataFrame, "label.table")))) { print.noquote(table1, right = TRUE) } else { attr(dataFrame, "label.table")[which(is.na(attr(attr(dataFrame, "label.table"), "names")))] <- "" index <- attr(attr(dataFrame, "label.table"), "names") == attr(dataFrame, "val.labels")[i] index <- na.omit(index) if (suppressWarnings(!all(rownames(as.data.frame(attr(dataFrame, "label.table")[index])) == levels(x2)))) { print.noquote(table1, right = TRUE) } else { table2 <- data.frame(attr(dataFrame, "label.table")[index], table1) colnames(table2) <- c("code", colnames(table1)) cat("Label table:", attr(dataFrame, "val.labels")[i], "\n") print.noquote(table2, right = TRUE) } } } } else { print(summ(dataFrame[, i], graph = FALSE)) } }} } cat("\n", "==================", "\n") } } ################### # Setting locale and automatic graph titles setTitle <- function(locale){ suppressWarnings(Sys.setlocale("LC_ALL",locale)) if(nchar(suppressWarnings(Sys.setlocale("LC_ALL",locale)))>0){ print(Sys.getlocale()) .locale(TRUE) }else{print("Invalid locale under this system.")} # With `setTitle' command the language of title will change with locale # listed in the array of the title string. } titleString <- function(distribution.of=.distribution.of,by=.by,frequency=.frequency, locale=.locale(), return.look.up.table=FALSE){ # title.array can be changed or added rows title.array <- rbind( c("Distribution of","by","Frequency"), c("Pembahagian","mengikut","Kekerapan"), c("Phan bo","theo","Tan so"), c("Verteilung von","nach","frequenz"), c("Distribution de","par","frequence"), c("distribuzione di","per","frequenza"), c("distribucion de", "por", "frecuencia")) colnames(title.array) <- c("Distribution of","by","Frequency") rownames(title.array) <- c("English", "Malay", "Vietnamese", "German", "French", "Italian", "Spanish") if(locale){ i <- 1 while(length(grep(rownames(title.array)[i],Sys.getlocale("LC_ALL")))!=1){ i <- i+1 } row.chosen <- i if(i <= nrow(title.array)){ distribution.of <- title.array[row.chosen,1] by <- title.array[row.chosen,2]; frequency <- title.array[row.chosen,3] } }else{.locale(FALSE) .distribution.of <- distribution.of .by <- by .frequency <- frequency } if(return.look.up.table){ return(list(locale=.locale(),distribution.of=distribution.of,by=by,frequency=frequency, look.up.table=title.array)) }else{ return(list(locale=.locale(),distribution.of=distribution.of,by=by,frequency=frequency)) } } library(foreign) ### Display variables and their description des <- function (x = .data, select, exclude) { if (!missing(select) | !missing(exclude)) { nl <- as.list(1:ncol(x)) names(nl) <- names(x) if (!missing(select)) vars.selected <- eval(substitute(select), nl, parent.frame()) if (!missing(exclude)) vars.excluded <- eval(substitute(exclude), nl, parent.frame()) if ((length(grep(pattern = "[*]", as.character(substitute(select)))) == 1) | (length(grep(pattern = "[?]", as.character(substitute(select)))) == 1)) { vars.selected <- grep(pattern = glob2rx(as.character(substitute(select))), names(x)) if (length(vars.selected) == 0) { stop(paste(select, "not matchable with any variable name.")) } } if ((length(grep(pattern = "[*]", as.character(substitute(exclude)))) == 1) | (length(grep(pattern = "[?]", as.character(substitute(exclude)))) == 1)) { vars.excluded <- grep(pattern = glob2rx(as.character(substitute(exclude))), names(x)) if (length(vars.excluded) == 0) { stop(paste(exclude, "not matchable with any variable name.")) } } vars <- 1:ncol(x) if (exists("vars.selected")) vars <- vars[vars.selected] if (exists("vars.excluded")) vars <- vars[-vars.excluded] x1 <- x[1,] class.a <- rep("", length(vars)) for (i in 1:length(vars)) { class.a[i] <- class(x1[,vars[i]])[1] } if (is.null(attr(x, "var.labels"))) { a <- cbind(colnames(x1)[vars], class.a, rep("", length(vars))) } else { a <- cbind(colnames(x1)[vars], class.a, attr(x, "var.labels")[vars]) } colnames(a) <- c("Variable ", "Class ", "Description") rownames(a) <- vars header <- paste(attr(x, "datalabel"), "\n",.No.of.observations,nrow(x), "\n") options(warn = 0) } else { if (!is.data.frame(x)) { if (is.character(x) & (length(grep(pattern = "[*]", x)) == 1) | (length(grep(pattern = "[?]", x) == 1))) { vars <- grep(pattern = glob2rx(x), names(.data)) if (length(vars) == 0) { stop(paste(x, "not matchable with any variable name.")) } x1 <- .data[1,] class.a <- rep("", length(vars)) for (i in 1:length(vars)) { class.a[i] <- class(x1[,vars[i]])[1] } if (is.null(attr(.data, "var.labels"))) { a <- cbind(colnames(x1)[vars], class.a, rep("", length(vars))) } else { a <- cbind(colnames(x1)[vars], class.a, attr(.data, "var.labels")[vars]) } colnames(a) <- c("Variable ", "Class ", "Description") rownames(a) <- vars header <- paste(attr(x, "datalabel"), "\n",.No.of.observations,nrow(x), "\n") options(warn = 0) } else { candidate.position <- NULL for (search.position in 1:length(search())) { if (exists(as.character(substitute(x)), where = search.position)) { if (any(names(get(search()[search.position])) == as.character(substitute(x))) | any(ls(all.names = TRUE, pos = 1) == as.character(substitute(x)))) candidate.position <- c(candidate.position, search.position) } } var.order <- as.character(NULL) var.class <- NULL var.size <- NULL var.lab <- NULL for (i in candidate.position) { if (i == 1) { var.order <- c(var.order, "") } else { var.order <- c(var.order, which(as.character(substitute(x)) == names(get(search()[i])))) } if (i == 1) { var.class <- c(var.class, class(x)) } else { var.class <- c(var.class, class(get(search()[i])[, which(as.character(substitute(x)) == names(get(search()[i])))])) } if (i == 1) { var.size <- c(var.size, length(x)) } else { var.size <- c(var.size, nrow(get(search()[i]))) } if (i == 1 | is.null(attr(get(search()[i]), "var.labels")[attr(get(search()[i]), "names") == substitute(x)])) { var.lab <- c(var.lab, " ") } else { var.lab <- c(var.lab, attr(get(search()[i]), "var.labels")[attr(get(search()[i]), "names") == substitute(x)]) } } a <- cbind(search()[candidate.position], var.order, var.class, var.size, var.lab) dim(a) colnames(a) <- c("Var. source ", "Var. order", "Class ", "# records", "Description") rownames(a) <- rep("", length(candidate.position)) header <- paste("'", deparse(substitute(x)), "'", " is a variable found in the following source(s):", "\n", "\n", sep = "") } } else { x1 <- x[1,] if (is.null(attr(x, "var.labels"))) { b <- " " } else { b <- attr(x, "var.labels") if (length(b) < length(colnames(x))) { options(warn = -1) } } class.a <- rep("", ncol(x1)) for (i in 1:ncol(x1)) { class.a[i] <- class(x1[, i])[1] } a <- cbind(colnames(x1), class.a, b) colnames(a) <- c("Variable ", "Class ", "Description") rownames(a) <- 1:nrow(a) header <- paste(attr(x, "datalabel"), "\n",.No.of.observations,nrow(x), "\n") options(warn = 0) } } results <- list(table=a, header=header) class(results) <- c("des","matrix") results } ##### print.des <- function(x, ...) { cat(x$header) print.noquote(x$table) } ### Detaching all data frame from the search path detachAllData <- function () { pos.to.detach <- (1:length(search()))[substring(search(), first = 1, last = 8) != "package:" & search() != ".GlobalEnv" & search() != "Autoloads" & search() != "CheckExEnv" & search() != "tools:rstudio" & search() != "TempEnv"] for (i in 1:length(pos.to.detach)) { if (length(pos.to.detach) > 0) { detach(pos = pos.to.detach[1]) pos.to.detach <- (1:length(search()))[substring(search(), first = 1, last = 8) != "package:" & search() != ".GlobalEnv" & search() != "Autoloads" & search() != "CheckExEnv" & search() != "tools:rstudio" & search() != "TempEnv"] } } } ### Getting percentage from the tabulation tabpct <- function(row, column, decimal=1, percent=c("both","col","row"), graph=TRUE, las=0, main = "auto", xlab = "auto", ylab = "auto", col="auto", ...) { tab <- table(row, column, deparse.level=1, dnn=list(deparse(substitute(row)),deparse(substitute(column)))) # column percent cpercent <-tab for(i in 1:ncol(tab)) { cpercent[,i] <-paste("(",format(round(tab[,i]/colSums(tab)[i]*100, digits=decimal),trim=TRUE),")", sep="")} cpercent <- rbind(cpercent, rep("(100)", ncol(tab))) col.1.1 <- cbind(format(c(tab[,1],sum(tab[,1])), trim=TRUE), cpercent[,1]) for(i in 2:ncol(tab)){ col.1.1 <- cbind(col.1.1, c(format(tab[,i], trim=TRUE), format(sum(tab[,i]), trim=TRUE)), cpercent[,i]) } cpercent <- col.1.1 cnames <- character(0) for(i in 1:ncol(tab) ){ cnames <- c(cnames, colnames(tab)[i], "%")} colnames(cpercent) <- cnames rownames(cpercent)[nrow(cpercent)] <- "Total" # rowpercent rpercent <-tab for(i in 1:nrow(tab)) { rpercent[i,] <-paste("(",round(tab[i,]/rowSums(tab)[i]*100, digits=1),")", sep="")} rpercent <- cbind(rpercent,c(rep("(100)",nrow(tab)))) row.1.1 <- rbind(format(c(tab[1,],sum(tab[1,])), trim=TRUE), rpercent[1,]) for(i in 2:nrow(tab)){ row.1.1 <- rbind(row.1.1, c(format(tab[i,], trim=TRUE), format(sum(tab[i,]), trim=TRUE)), rpercent[i,]) } rpercent <- row.1.1 rnames <- character(0) for(i in 1:nrow(tab) ){ rnames <- c(rnames, rownames(tab)[i], "")} rownames(rpercent) <- rnames colnames(rpercent)[ncol(rpercent)] <- "Total" var1 <- deparse(substitute(row)) if(length(var1)>1){ string2 <- var1[length(var1)] }else if(substring(search()[2],first=1,last=8)!="package:"){ string2 <- attr(get(search()[2]), "var.labels")[attr(get(search()[2]), "names")==deparse(substitute(row))] if(length(string2)==0){ string2 <- deparse(substitute(row)) } if(string2==""){ string2 <- deparse(substitute(row)) } }else{ string2 <- deparse(substitute(row)) } if(substring(search()[2],first=1,last=8)!="package:"){ string4 <- attr(get(search()[2]), "var.labels")[attr(get(search()[2]), "names")==deparse(substitute(column))] if(length(string4)==0){ string4 <- deparse(substitute(column)) }else{ if(string4==""){ string4 <- deparse(substitute(column)) } } }else{ string4 <- deparse(substitute(column)) } names(attr(tab,"dimnames")) <-c(string2, string4) cat( "\n") suppressWarnings(if(percent=="both"){ cat("Original table", "\n") tabtotal <- addmargins(tab) colnames(tabtotal)[ncol(tabtotal)] <- "Total" rownames(tabtotal)[nrow(tabtotal)] <- "Total" print(tabtotal, print.gap=2) cat( "\n")}) suppressWarnings(if(percent=="both" | percent=="row"){ cat("Row percent", "\n") names(attr(rpercent,"dimnames")) <- c(string2, string4) print.table(rpercent, right=TRUE, print.gap=2) cat( "\n")}) suppressWarnings(if(percent=="both" | percent=="col"){ cat("Column percent", "\n") names(attr(cpercent,"dimnames")) <- c(string2, string4) print.table(cpercent, right=TRUE, print.gap=2) cat( "\n")}) if(graph==TRUE){ rownames(tab)[is.na(rownames(tab))] <- "missing" colnames(tab)[is.na(colnames(tab))] <- "missing" las.value <- las if(any(col=="auto")) {colours <- c("white",2:length(column))}else{colours=col} if(nchar(paste(titleString()$distribution.of,string4,titleString()$by,string2))>45){ mosaicplot(as.table(tab),xlab=ifelse(xlab=="auto",string2,xlab), ylab=ifelse(ylab=="auto",string4, ylab), main= ifelse(main=="auto",paste(titleString()$distribution.of,string4,"\n",titleString()$by,string2), main), col=colours, las=las.value, ...) }else{ mosaicplot(as.table(tab),xlab=ifelse(xlab=="auto",string2,xlab), ylab=ifelse(ylab=="auto",string4,ylab), main=ifelse(main=="auto",paste(titleString()$distribution.of,string4,titleString()$by,string2),main), col=colours, las=las.value, ...)}} cpercent <- tab for(i in 1:ncol(tab)) {cpercent[,i] <- tab[,i]/colSums(tab)[i]*100} rpercent <- tab for(i in 1:nrow(tab)) {rpercent[i,] <- tab[i,]/rowSums(tab)[i]*100} returns <- list(table.row.percent=rpercent, table.column.percent=cpercent) } #### cci <- function (caseexp, controlex, casenonex, controlnonex, cctable = NULL, graph = TRUE, design = "cohort", main, xlab, ylab, xaxis, yaxis, alpha = 0.05, fisher.or = FALSE, exact.ci.or = TRUE, decimal = 2) { if (is.null(cctable)) { frame <- cbind(Outcome <- c(1, 0, 1, 0), Exposure <- c(1, 1, 0, 0), Freq <- c(caseexp, controlex, casenonex, controlnonex)) Exposure <- factor(Exposure) expgrouplab <- c("Non-exposed", "Exposed") levels(Exposure) <- expgrouplab Outcome <- factor(Outcome) outcomelab <- c("Negative", "Positive") levels(Outcome) <- outcomelab table1 <- xtabs(Freq ~ Outcome + Exposure, data = frame) } else { table1 <- as.table(get("cctable")) } fisher <- fisher.test(table1) caseexp <- table1[2, 2] controlex <- table1[1, 2] casenonex <- table1[2, 1] controlnonex <- table1[1, 1] se.ln.or <- sqrt(1/caseexp + 1/controlex + 1/casenonex + 1/controlnonex) if (!fisher.or) { or <- caseexp/controlex/casenonex * controlnonex p.value <- chisq.test(table1, correct = FALSE)$p.value } else { or <- fisher$estimate p.value <- fisher$p.value } if (exact.ci.or) { ci.or <- as.numeric(fisher$conf.int) } else { ci.or <- or * exp(c(-1, 1) * qnorm(1 - alpha/2) * se.ln.or) } if (graph == TRUE) { caseexp <- table1[2, 2] controlex <- table1[1, 2] casenonex <- table1[2, 1] controlnonex <- table1[1, 1] if (!any(c(caseexp, controlex, casenonex, controlnonex) < 5)) { if (design == "prospective" || design == "cohort" || design == "cross-sectional") { graph.prospective(caseexp, controlex, casenonex, controlnonex) if (missing(main)) main <- "Odds ratio from prospective/X-sectional study" if (missing(xlab)) xlab <- "" if (missing(ylab)) ylab <- paste("Odds of being", ifelse(missing(yaxis), "a case", yaxis[2])) if (missing(xaxis)) xaxis <- c("non-exposed", "exposed") axis(1, at = c(0, 1), labels = xaxis) } else { graph.casecontrol(caseexp, controlex, casenonex, controlnonex) if (missing(main)) main <- "Odds ratio from case control study" if (missing(ylab)) ylab <- "Outcome category" if (missing(xlab)) xlab <- "" if (missing(yaxis)) yaxis <- c("Control", "Case") axis(2, at = c(0, 1), labels = yaxis, las = 2) mtext(paste("Odds of ", ifelse(xlab == "", "being exposed", paste("exposure being", xaxis[2]))), side = 1, line = ifelse(xlab == "", 2.5, 1.8)) } title(main = main, xlab = xlab, ylab = ylab) } } if (!fisher.or) { results <- list(or.method = "Asymptotic", or = or, se.ln.or = se.ln.or, alpha = alpha, exact.ci.or = exact.ci.or, ci.or = ci.or, table = table1, decimal = decimal) } else { results <- list(or.method = "Fisher's", or = or, alpha = alpha, exact.ci.or = exact.ci.or, ci.or = ci.or, table = table1, decimal = decimal) } class(results) <- c("cci", "cc") return(results) } print.cci <- function(x, ...){ cat("\n") table2 <- addmargins(x$table) rownames(table2)[nrow(table2)] <- "Total" colnames(table2)[ncol(table2)] <- "Total" print(table2) cat("\n") cat(c(paste(x$method,"OR = ",sep=""), round(x$or, x$decimal),"\n")) cat(c(paste(ifelse(x$exact.ci.or,"Exact ",""),100*(1-x$alpha), "% CI = ", sep=""), paste(round(x$ci.or[1], x$decimal),",",sep=""),paste(round(x$ci.or[2], x$decimal),sep=""), sep=""), "\n") cat(paste("Chi-squared = ", round(summary(x$table)$statistic, x$decimal), ", ", summary(x$table)$parameter, " d.f.,", " P value = ", round(summary(x$table)$p.value, x$decimal + 1), "\n", sep="")) cat(paste("Fisher's exact test (2-sided) P value =", round(fisher.test(x$table)$p.value, x$decimal + 1), "\n")) cat("\n") } ########## case control study from a data file or cctable cc <- function (outcome, exposure, decimal = 2, cctable = NULL, graph = TRUE, original = TRUE, design = "cohort", main, xlab = "auto", ylab,alpha=.05, fisher.or=FALSE, exact.ci.or=TRUE) { if (is.null(cctable)) { cctable <- table(outcome, exposure, deparse.level = 1, dnn = list(substitute(outcome), substitute(exposure))) cctable.dimnames <- names(attr(cctable, "dimnames")) if (xlab == "auto") { xlab <- paste("Exposure = ", as.character(substitute(exposure)), ", ", "outcome = ", as.character(substitute(outcome)), sep = "") } xaxis <- levels(factor(exposure)) yaxis <- levels(factor(outcome)) } else { cctable.dimnames <- names(attr(cctable, "dimnames")) if (xlab == "auto") { xlab <- paste("Exposure = ", cctable.dimnames[2], ", ", "outcome = ", cctable.dimnames[1], sep = "") } xaxis <- attr(cctable, "dimnames")[[2]] yaxis <- attr(cctable, "dimnames")[[1]] } if (ncol(cctable) > 2 & nrow(cctable) == 2) { or <- rep(NA, ncol(cctable)) lowci <- rep(NA, ncol(cctable)) hici <- rep(NA, ncol(cctable)) or[1] <- 1 for (i in 2:ncol(cctable)) { or[i] <- fisher.test(cctable[, c(1, i)])$estimate } for (i in 2:ncol(cctable)) { lowci[i] <- fisher.test(cctable[, c(1, i)])$conf.int[1] } for (i in 2:ncol(cctable)) { hici[i] <- fisher.test(cctable[, c(1, i)])$conf.int[2] } row4 <- as.character(round(or, decimal)) row4[1] <- "1" row5 <- as.character(round(lowci, decimal)) row5[1] <- " " row6 <- as.character(round(hici, decimal)) row6[1] <- " " table2 <- rbind(cctable, "", row4, row5, row6) rownames(table2)[4] <- "Odds ratio" rownames(table2)[5] <- "lower 95% CI " rownames(table2)[6] <- "upper 95% CI " names(attr(table2, "dimnames")) <- names(attr(cctable, "dimnames")) cat("\n") print.noquote(table2) cat("\n") cat("Chi-squared =", round(chisq.test(cctable)$statistic, 3), ",", chisq.test(cctable)$parameter, "d.f.,", "P value =", round(chisq.test(cctable, correct = FALSE)$p.value, decimal + 1), "\n") cat("Fisher's exact test (2-sided) P value =", round(fisher.test(cctable)$p.value, decimal + 1), "\n") cat("\n") if (graph == TRUE & design == "cohort") { if (any(cctable < 5)) { cat("Cell counts too small - graph not shown", "\n", "\n") } else { y <- rep(NA, ncol(cctable)) x <- 1:ncol(cctable) x.left <- x - 0.02 x.right <- x + 0.02 plot(x, or, ylab = "Odds ratio", xlab = paste(names(attr(cctable, "dimnames")[2])), xaxt = "n", main = "Odds ratio from prospective/X-sectional study", pch = " ", xlim = c(min(x.left) - 0.2, x.right[ncol(cctable)] + 0.2), ylim = c(min(c(1, min(lowci, na.rm = TRUE), min(hici, na.rm = TRUE))), max(c(1, max(hici, na.rm = TRUE, max(lowci, na.rm = TRUE))))), log = "y", type = "l") for (i in 1:ncol(cctable)) { lines(x = c(x[i], x[i]), y = c(lowci[i], hici[i])) lines(x = c(x.left[i], x.right[i]), y = c(lowci[i], lowci[i])) lines(x = c(x.left[i], x.right[i]), y = c(hici[i], hici[i])) points(x[i], or[i], pch = 22, cex = sum(cctable[, i]) * (5/sum(cctable))) } axis(1, at = x, labels = colnames(cctable)) text(1, 1, labels = "1", pos = 4, font = 4, col = "brown") text(x[-1], or[-1], labels = row4[-1], col = "brown", pos = 1, font = 4) text(x, or, labels = ifelse(x == 1, "", paste("(", row5, ",", row6, ")")), pos = 1, font = 4, offset = 1.5, col = "brown") } } } else { if (!original) { a <- labelTable(outcome, exposure, cctable = cctable, cctable.dimnames = cctable.dimnames) cci(caseexp = a$caseexp, controlex = a$controlex, casenonex = a$casenonex, controlnonex = a$controlnonex, cctable = a$cctable, decimal = decimal, graph = graph, design = design, main, xlab, ylab, xaxis, yaxis, alpha=alpha, fisher.or=fisher.or, exact.ci.or=exact.ci.or) } else { if (exists("cctable")) { cci(cctable = cctable, decimal = decimal, graph = graph, design = design, main = main, xlab = xlab, ylab = ylab, xaxis = xaxis, yaxis = yaxis, alpha=alpha, fisher.or=fisher.or, exact.ci.or=exact.ci.or) } else { cci(cctable = table(outcome, exposure, dnn = c(as.character(substitute(outcome)), as.character(substitute(exposure)))), decimal = decimal, graph = graph, design = design, main = main, xlab = xlab, ylab = ylab, xaxis = xaxis, yaxis = yaxis, alpha=alpha, fisher.or=fisher.or, exact.ci.or=exact.ci.or) } } } } ##### graph for a case control study graph.casecontrol <- function (caseexp, controlex, casenonex, controlnonex, decimal = 2) { if (any(c(caseexp, controlex, casenonex, controlnonex) < 5)) { cat("One of more cells is/are less than 5, not appropriate for graphing", "\n") } else { table <- c(caseexp, controlex, casenonex, controlnonex) dim(table) <- c(2, 2) fisher <- fisher.test(table) logit0 <- log(controlex/controlnonex) se0 <- sqrt(1/controlex + 1/controlnonex) logit1 <- log(caseexp/casenonex) se1 <- sqrt(1/caseexp + 1/casenonex) x <- c(c(-1, 0, 1) * 1.96 * se0 + logit0, c(-1, 0, 1) * 1.96 * se1 + logit1) y <- c(rep(0, 3), rep(1, 3)) plot(x[c(1, 3, 4, 6)], y[c(1, 3, 4, 6)], xlab = "", ylab = "", yaxt = "n", xaxt = "n", pch = 73) points(x[c(2, 5)], y[c(2, 5)], pch = 22, cex = c((controlex + controlnonex), (caseexp + casenonex))/sum(table) * 5) x1 <- exp(x) a <- 2^(-10:10) if (length(a[a > min(x1) & a < max(x1)]) > 2 & length(a[a > min(x1) & a < max(x1)]) < 10) { a1 <- a[a > min(x1) & a < max(x1)] if (any(a1 >= 1)) axis(1, at = log(a1[a1 >= 1]), labels = as.character(a1[a1 >= 1])) if (any(a1 < 1)) axis(1, at = log(a1[a1 < 1]), labels = paste(as.character(1), "/", as.character(trunc(1/a1[a1 < 1])), sep = "")) } else { options(digit = 2) at.x <- seq(from = min(x), to = max(x), by = ((max(x) - min(x))/5)) labels.oddsx <- exp(at.x) axis(1, at = at.x, labels = as.character(round(labels.oddsx, digits = decimal)), las = 1) } lines(x[1:3], y[1:3]) lines(x[4:6], y[4:6]) lines(x[c(2, 5)], y[c(2, 5)]) arrows(x0 = logit0, x1 = logit1, y0 = 0.1, y1 = 0.1, code = 2, col = "red") text(x = (max(x) + min(x))/2, y = 0.3, labels = paste("OR = ", round(fisher$estimate, decimal))) text(x = (max(x) + min(x))/2, y = 0.2, labels = paste("95% CI =", round(fisher$conf.int, 2)[1], ",", round(fisher$conf.int, 2)[2])) abline(v = c(logit0, logit1), lty = 3, col = "blue") } } ##### graph for a cohort study graph.prospective <- function (caseexp, controlex, casenonex, controlnonex, decimal = 2) { if (any(c(caseexp, controlex, casenonex, controlnonex) < 5)) { cat("One of more cells is/are less than 5, not appropriate for graphing", "\n", "\n") } else { table <- c(caseexp, controlex, casenonex, controlnonex) dim(table) <- c(2, 2) fisher <- fisher.test(table) logit0 <- log(casenonex/controlnonex) se0 <- sqrt(1/casenonex + 1/controlnonex) logit1 <- log(caseexp/controlex) se1 <- sqrt(1/caseexp + 1/controlnonex) y <- c(c(-1, 0, 1) * 1.96 * se0 + logit0, c(-1, 0, 1) * 1.96 * se1 + logit1) x <- c(rep(0, 3), rep(1, 3)) plot(x[c(1, 3, 4, 6)], y[c(1, 3, 4, 6)], ylab = "", xlab = "", yaxt = "n", xaxt = "n", pch = " ") lines(x = c(-0.02, 0.02), y = c(y[1], y[1])) lines(x = c(-0.02, 0.02), y = c(y[3], y[3])) lines(x = c(0.98, 1.02), y = c(y[4], y[4])) lines(x = c(0.98, 1.02), y = c(y[6], y[6])) points(x[c(2, 5)], y[c(2, 5)], pch = 22, cex = c((controlnonex + casenonex), (caseexp + controlex))/sum(table) * 5) y1 <- exp(y) a <- 2^(-10:10) if (length(a[a > min(y1) & a < max(y1)]) > 2 & length(a[a > min(y1) & a < max(y1)]) < 10) { a1 <- a[a > min(y1) & a < max(y1)] if (any(a1 >= 1)) axis(2, at = log(a1[a1 >= 1]), labels = as.character(a1[a1 >= 1]), las = 1) if (any(a1 < 1)) axis(2, at = log(a1[a1 < 1]), labels = paste(as.character(1), "/", as.character(trunc(1/a1[a1 < 1])), sep = ""), las = 1) } else { options(digit = 2) at.y <- seq(from = min(y), to = max(y), by = ((max(y) - min(y))/5)) labels.oddsy <- exp(at.y) axis(2, at = at.y, labels = as.character(round(labels.oddsy, digits = decimal)), las = 1) } lines(x[1:3], y[1:3]) lines(x[4:6], y[4:6]) lines(x[c(2, 5)], y[c(2, 5)]) arrows(y0 = logit0, y1 = logit1, x0 = 0.25, x1 = 0.25, code = 2, col = "red") text(y = min(y) + 0.55 * (max(y) - min(y)), x = 0.5, labels = paste("OR = ", round(fisher$estimate, decimal))) text(y = min(y) + 0.45 * (max(y) - min(y)), x = 0.5, labels = paste("95% CI =", round(fisher$conf.int, decimal)[1], ",", round(fisher$conf.int, decimal)[2])) abline(h = c(logit0, logit1), lty = 3, col = "blue") mtext("Exposure category", side = 1, line = 1.0) } } #### Create a `cctable' in global environment and label row and column with the variable descriptions labelTable <- function(outcome, exposure, cctable=NULL , cctable.dimnames=NULL){ if(is.null(cctable)){ cctable <- table(outcome, exposure, deparse.level=1, dnn=list(substitute(row),substitute(col))) } if(is.null(names(attr(cctable,"dimnames")))){ dimnames(cctable) <- list(Outcome=c("Non-diseased","Diseased"),Exposure=c("Non-exposed","Exposed")) } if(is.null(cctable.dimnames)){ cctable.dimnames <- names(attr(cctable,"dimnames")) } if(substring(search()[2],first=1,last=8)!="package:"){ string2 <- attr(get(search()[2]), "var.labels")[attr(get(search()[2]), "names")==cctable.dimnames[1]] if(length(string2)==0){ string2 <- cctable.dimnames[1] }else{ if(string2==""){ string2 <- cctable.dimnames[1] }else{ string2 <- cctable.dimnames[1] } }} if(substring(search()[2],first=1,last=8)!="package:"){ string4 <- attr(get(search()[2]), "var.labels")[attr(get(search()[2]), "names")==cctable.dimnames[2]] if(length(string4)==0){ string4 <- cctable.dimnames[2] }else{ if(string4==""){ string4 <- cctable.dimnames[2] } } }else{ string4 <- cctable.dimnames[2] string2 <- cctable.dimnames[1] } names(attr(cctable,"dimnames")) <-c(string2, string4) suppressWarnings(return(list(cctable, caseexp=cctable[2,2], controlex=cctable[1,2], casenonex=cctable[2,1], controlnonex=cctable[1,1]))) } #### Cohort tabulation from a dataset cs <- function (outcome, exposure, cctable = NULL, decimal = 2, method="Newcombe.Wilson", main, xlab, ylab, cex, cex.axis) { if (is.null(cctable)) { cctable <- table(outcome, exposure, deparse.level = 1, dnn = list(substitute(outcome), substitute(exposure))) cctable.dimnames <- names(attr(cctable, "dimnames")) } else { cctable.dimnames <- names(attr(cctable, "dimnames")) } if (ncol(cctable) > 2 & nrow(cctable) == 2) { r <- rep(NA, ncol(cctable)) rr <- rep(NA, ncol(cctable)) lowci <- rep(NA, ncol(cctable)) hici <- rep(NA, ncol(cctable)) for (i in 1:ncol(cctable)) { r[i] <- cctable[2, i]/colSums(cctable)[i] } rr[1] <- 1 for (i in 2:ncol(cctable)) { rr[i] <- (cctable[2, i]/colSums(cctable)[i])/(cctable[2, 1]/colSums(cctable)[1]) } for (i in 2:ncol(cctable)) { lowci[i] <- rr[i]^(1 - qnorm(1 - 0.05/2)/sqrt(suppressWarnings(chisq.test(cbind(cctable[, 1], cctable[, i])))$statistic)) } for (i in 2:ncol(cctable)) { hici[i] <- rr[i]^(1 + qnorm(1 - 0.05/2)/sqrt(suppressWarnings(chisq.test(cbind(cctable[, 1], cctable[, i])))$statistic)) } row4 <- as.character(round(r, decimal)) row5 <- as.character(round(rr, decimal)) row5[1] <- "1" row6 <- as.character(round(lowci, decimal)) row6[1] <- " " row7 <- as.character(round(hici, decimal)) row7[1] <- " " table2 <- rbind(cctable, "", row4, row5, row6, row7) rownames(table2)[4] <- "Absolute risk" rownames(table2)[5] <- "Risk ratio" rownames(table2)[6] <- "lower 95% CI " rownames(table2)[7] <- "upper 95% CI " names(attr(table2, "dimnames")) <- names(attr(cctable, "dimnames")) cat("\n") print.noquote(table2) cat("\n") cat("Chi-squared =", round(chisq.test(cctable)$statistic, 3), ",", chisq.test(cctable)$parameter, "d.f.,", "P value =", round(chisq.test(cctable, correct = FALSE)$p.value, decimal + 1), "\n") if (sum(chisq.test(cctable)$expected < 5)/sum(chisq.test(cctable)$expected > 0) > 0.2) { cat("Fisher's exact test (2-sided) P value =", round(fisher.test(cctable)$p.value, decimal + 1), "\n") } cat("\n") if (any(cctable < 5)) { cat("One of more cells is/are less than 5, not appropriate for graphing", "\n", "\n") } else { x <- 1:ncol(cctable) x.left <- x - 0.02 x.right <- x + 0.02 plot(x, rr, ylab = ifelse(missing(ylab), "Risk ratio", ylab), xaxt = "n", xlab = ifelse(missing(xlab),paste(names(attr(cctable, "dimnames")[2])),xlab), main = ifelse(missing(main),"Risk ratio from a cohort study", main), pch = " ", xlim = c(min(x.left) - 0.2, x.right[ncol(cctable)] + 0.2), ylim = c(min(c(1, min(lowci, na.rm = TRUE), min(hici, na.rm = TRUE))), max(c(1, max(hici, na.rm = TRUE, max(lowci, na.rm = TRUE))))), log = "y", type = "l", cex.axis=ifelse(missing(cex.axis), 1, cex.axis)) for (i in 1:ncol(cctable)) { lines(x = c(x[i], x[i]), y = c(lowci[i], hici[i])) lines(x = c(x.left[i], x.right[i]), y = c(lowci[i], lowci[i])) lines(x = c(x.left[i], x.right[i]), y = c(hici[i], hici[i])) points(x[i], rr[i], pch = 22, cex = sum(cctable[, i]) * (5/sum(cctable))) } axis(1, at = x, labels = colnames(cctable), ifelse(missing(cex.axis), 1, cex.axis)) text(1, 1, labels = "1", pos = 4, font = 4, col = "brown", cex=ifelse(missing(cex),1,cex)) text(x[-1], rr[-1], labels = row5[-1], col = "brown", pos = 1, font = 4, cex=ifelse(missing(cex),1,cex)) text(x, rr, labels = ifelse(x == 1, "", paste("(", row6, ",", row7, ")")), pos = 1, font = 4, offset = 1.5, col = "brown", cex=ifelse(missing(cex),1,cex)) } } else { a <- labelTable(outcome, exposure, cctable = cctable, cctable.dimnames = cctable.dimnames) csi(caseexp = a$caseexp, controlex = a$controlex, casenonex = a$casenonex, controlnonex = a$controlnonex, cctable = a$cctable, decimal = decimal, method=method) } } #### Cohort tabulation from keyboard csi <- function (caseexp, controlex, casenonex, controlnonex, cctable = NULL, decimal = 2, method="Newcombe.Wilson") { if (is.null(cctable)) { frame <- cbind(Outcome <- c(1, 0, 1, 0), Exposure <- c(1, 1, 0, 0), Freq <- c(caseexp, controlex, casenonex, controlnonex)) Exposure <- factor(Exposure) expgrouplab <- c("Non-exposed", "Exposed") levels(Exposure) <- expgrouplab Outcome <- factor(Outcome) outcomelab <- c("Negative", "Positive") levels(Outcome) <- outcomelab table <- xtabs(Freq ~ Outcome + Exposure, data = frame) } else { table <- get("cctable") } cat("\n") table2 <- addmargins(table) rownames(table2)[nrow(table2)] <- "Total" colnames(table2)[ncol(table2)] <- "Total" risk <- table2[2, ]/table2[3, ] table2 <- rbind(table2, c("", "", ""), c("Rne", "Re", "Rt"), round(risk, decimal), deparse.level = 1) rownames(table2)[c(4:6)] <- c("", "", "Risk") names(attr(table2, "dimnames")) <- names(attr(table, "dimnames")) print.noquote(table2) a <- table[1, 1] A <- sum(table[, 1]) * sum(table[1, ])/sum(table[, ]) Vara <- sum(table[, 1])/(sum(table[, ]) - 1) * sum(table[1, ]) * sum(table[, 2]) * sum(table[2, ])/sum(table[, ])^2 chi2 <- abs(a - A)^2/Vara if(method=="Newcombe.Wilson"){ newcombe.wilson <- function(caseexp, controlex, casenonex, controlnonex, alpha=0.05) { n1 <- casenonex+controlnonex n2 <- caseexp+controlex CER <- casenonex/n1 EER <- caseexp/n2 Z <- qnorm(1-alpha/2) lower1 <- (1/(2*(n2+Z^2)))*(2*n2*CER+Z^2 - Z*(Z^2+4*n2*CER*(1-CER))^0.5) upper1 <- (1/(2*(n2+Z^2)))*(2*n2*CER+Z^2 + Z*(Z^2+4*n2*CER*(1-CER))^0.5) lower2 <- (1/(2*(n1+Z^2)))*(2*n1*EER+Z^2 - Z*(Z^2+4*n1*EER*(1-EER))^0.5) upper2 <- (1/(2*(n1+Z^2)))*(2*n1*EER+Z^2 + Z*(Z^2+4*n1*EER*(1-EER))^0.5) term1 <- sqrt(abs((lower1*(1-lower1)/n2)+(upper2*(1-upper2)/n1))) term2 <- sqrt(abs((upper1*(1-upper1)/n2)+(lower2*(1-lower2)/n1))) lower <- CER-EER - Z * term1 upper <- CER-EER + Z * term2 return(list(Risk = -(CER-EER), Lower.CI=-upper, Upper.CI=-lower))#ifelse(EER < CER,-upper,-upper), Upper.CI=ifelse(EER < CER, -lower,-lower))) } newcombe.wilson.results <- newcombe.wilson(caseexp, controlex, casenonex, controlnonex) risk.diff <- newcombe.wilson.results$Risk risk.diff.lower <- round(min(c(newcombe.wilson.results$Lower.CI,newcombe.wilson.results$Upper.CI)),decimal) risk.diff.upper <- round(max(c(newcombe.wilson.results$Lower.CI,newcombe.wilson.results$Upper.CI)),decimal) }else{ risk.diff <- risk[2] - risk[1] risk.diff.lower <- round(risk.diff * (1 - sign(risk.diff) * (qnorm(1 - 0.05/2)/sqrt(chi2))), decimal) risk.diff.upper <- round(risk.diff * (1 + sign(risk.diff) * (qnorm(1 - 0.05/2)/sqrt(chi2))), decimal) } risk.ratio <- round(risk[2]/risk[1], decimal) risk.ratio.lower <- round(risk.ratio^(1 - sign(risk.diff) * (qnorm(1 - 0.05/2)/sqrt(suppressWarnings(chisq.test(table)$statistic)))), decimal) risk.ratio.upper <- round(risk.ratio^(1 + sign(risk.diff) * (qnorm(1 - 0.05/2)/sqrt(suppressWarnings(chisq.test(table)$statistic)))), decimal) if (risk.ratio < 1) { protective.efficacy <- round(-risk.diff/risk[1] * 100, decimal - 1) protective.efficacy.lower <- round(100 * (1 - (risk.ratio^(1 - (qnorm(1 - 0.05/2)/sqrt(suppressWarnings(chisq.test(table)$statistic)))))), decimal) protective.efficacy.upper <- round(100 * (1 - (risk.ratio^(1 + (qnorm(1 - 0.05/2)/sqrt(suppressWarnings(chisq.test(table)$statistic)))))), decimal) nnt <- round(-1/risk.diff, decimal) if(method=="Newcombe.Wilson"){ nnt.lower <- round(min(c(-1/newcombe.wilson.results$Lower.CI, -1/newcombe.wilson.results$Upper.CI)),decimal) nnt.upper <- round(max(c(-1/newcombe.wilson.results$Lower.CI, -1/newcombe.wilson.results$Upper.CI)),decimal) }else{ nnt.lower <- round(min(c(-1/(risk.diff * (1 + (qnorm(1 - 0.05/2)/sqrt(chi2)))),-1/(risk.diff * (1 - (qnorm(1 - 0.05/2)/sqrt(chi2)))))), decimal) nnt.upper <- round(max(c(-1/(risk.diff * (1 + (qnorm(1 - 0.05/2)/sqrt(chi2)))),-1/(risk.diff * (1 - (qnorm(1 - 0.05/2)/sqrt(chi2)))))), decimal) } risk.names <- c("Risk difference (Re - Rne)", "Risk ratio", "Protective efficacy =(Rne-Re)/Rne*100 ", " or percent of risk reduced", "Number needed to treat (NNT)", " or -1/(risk difference)") risk.table <- cbind(risk.names, c(round(risk.diff, decimal), risk.ratio, protective.efficacy, " ", nnt, ""), c(risk.diff.lower, risk.ratio.lower, protective.efficacy.lower, " ", nnt.lower, ""), c(risk.diff.upper, risk.ratio.upper, protective.efficacy.upper, " ", nnt.upper, "")) } else { attributable.frac.exp <- round(risk.diff/risk[2], decimal) pop.risk.diff <- risk[3] - risk[1] attributable.frac.pop <- round((risk[3] - risk[1])/risk[3] * 100, decimal) nnh <- round(1/risk.diff, decimal) if(method=="Newcombe.Wilson"){ nnh.lower <- round(min(c(1/newcombe.wilson.results$Upper.CI,1/newcombe.wilson.results$Lower.CI)), decimal) nnh.upper <- round(max(c(1/newcombe.wilson.results$Upper.CI,1/newcombe.wilson.results$Lower.CI)), decimal) }else{ nnh.lower <- round(min(c(1/(risk.diff * (1 - (qnorm(1 - 0.05/2)/sqrt(chi2)))),1/(risk.diff * (1 + (qnorm(1 - 0.05/2)/sqrt(chi2)))))), decimal) nnh.upper <- round(max(c(1/(risk.diff * (1 - (qnorm(1 - 0.05/2)/sqrt(chi2)))),1/(risk.diff * (1 + (qnorm(1 - 0.05/2)/sqrt(chi2)))))), decimal) } cat("\n") risk.names <- c("Risk difference (attributable risk)", "Risk ratio", "Attr. frac. exp. -- (Re-Rne)/Re", "Attr. frac. pop. -- (Rt-Rne)/Rt*100 % ", "Number needed to harm (NNH)", " or 1/(risk difference)") risk.table <- cbind(risk.names, c(round(risk.diff, decimal), risk.ratio, attributable.frac.exp, attributable.frac.pop, nnh, ""), c(risk.diff.lower, risk.ratio.lower, "", "", nnh.lower, ""), c(risk.diff.upper, risk.ratio.upper, "", "", nnh.upper, "")) } row.names(risk.table) <- rep("", nrow(risk.table)) colnames(risk.table) <- c("", "Estimate", "Lower95ci", "Upper95ci") print.noquote(risk.table) cat("\n") suppressWarnings(rm(cctable, caseexp, controlex, casenonex, controlnonex, pos = 1)) } ### IDR display for poisson and negative binomial regression idr.display <- function (idr.model, alpha = 0.05, crude = TRUE, crude.p.value = FALSE, decimal = 2, simplified = FALSE) { model <- idr.model if(length(grep("[$]", attr(model$term, "term.labels"))) > 0 | length(grep(")", attr(model$term, "term.labels"))) > 0 | length(model$call) < 3){ simplified <- TRUE; crude <- TRUE }else{ factor.with.colon <- NULL for(i in 1:(length(attr(model$term, "term.labels"))-1)){ factor.with.colon <- c(factor.with.colon, any(grep(pattern=":",model$xlevels[i]))) } factor.with.colon <- any(factor.with.colon) if(length(grep(":", attr(model$terms, "term.labels")))> 1 | factor.with.colon){ simplified <- TRUE; crude <- TRUE }} if(simplified){ coeff <- summary(model)$coefficients[-1,] table1 <- cbind(exp(coeff[, 1]), exp(coeff[, 1] - qnorm(1 - alpha/2) * coeff[, 2]), exp(coeff[, 1] + qnorm(1 - alpha/2) * coeff[, 2]), coeff[,4] ) colnames(table1) <- c("Adj. IDR", paste("lower", 100 - 100 * alpha, "ci", sep = ""), paste("upper", 100 - 100 * alpha, "ci", sep = ""), "Pr(>|Z|)") }else{ if (length(class(model)) == 1) { stop("Model not from logistic regression") } if (!any(class(model) == "glm") | !any(class(model) == "lm") | (model$family$family != "poisson" & length(grep("Negative Binomial", model$family$family))== 0)) { stop("Model not from poisson regression") } var.names <- attr(model$terms, "term.labels") if (length(var.names) == 1) { crude <- FALSE } if (crude) { idrci0 <- NULL for (i in 1:length(var.names)) { formula0 <- as.formula(paste(names(model$model)[1], "~", var.names[i])) if(names(model$coefficient)[1]!="(Intercept)"){ formula0 <- as.formula(paste(names(model$model)[1], "~", var.names[i], "- 1")) } model0 <- glm(formula0, weights = model$prior.weights, offset=model$offset, family = poisson, data = model$model) if(any(class(model)=="negbin")){ model0 <- glm.nb (as.formula(paste(names(model$model)[1], "~", var.names[i]))) } coeff.matrix <- (summary(model0))$coefficients[-1, , drop = FALSE] if(names(model$coefficient)[1]!="(Intercept)"){ coeff.matrix <- (summary(model0))$coefficients[, , drop = FALSE] } if (length(grep(":", var.names[i])) > 0) { var.name.interact <- unlist(strsplit(var.names[i], ":")) if (any(names(model$xlevels) == var.name.interact[1])) { level1 <- length(unlist(model$xlevels[var.name.interact[1]])) - 1 } else { level1 <- 1 } if (any(names(model$xlevels) == var.name.interact[2])) { level2 <- length(unlist(model$xlevels[var.name.interact[2]])) - 1 } else { level2 <- 1 } dim.coeff <- dim((summary(model0))$coefficients[-1, , drop = FALSE]) coeff.matrix <- matrix(rep(NA, dim.coeff[1] * dim.coeff[2]), dim.coeff[1], dim.coeff[2]) coeff.matrix <- coeff.matrix[1:(level1 * level2), , drop = FALSE] } idrci0 <- rbind(idrci0, coeff.matrix) } if(names(model$coefficient)[1]=="(Intercept)"){ idrci0 <- rbind(matrix(rep(0, 4), 1, 4), idrci0) } colnames(idrci0) <- c("crudeIDR", paste("lower0", 100 - 100 * alpha, "ci", sep = ""), paste("upper0", 100 - 100 * alpha, "ci", sep = ""), "crude P value") idrci0[, 3] <- exp(idrci0[, 1] + qnorm(1 - alpha/2) * idrci0[, 2]) idrci0[, 2] <- exp(idrci0[, 1] - qnorm(1 - alpha/2) * idrci0[, 2]) idrci0[, 1] <- exp(idrci0[, 1]) } s1 <- summary(model) idrci <- s1$coefficients colnames(idrci) <- c("idr", paste("lower", 100 - 100 * alpha, "ci", sep = ""), paste("upper", 100 - 100 * alpha, "ci", sep = ""), "P(Wald's test)") idrci[, 3] <- exp(idrci[, 1] + qnorm(1 - alpha/2) * idrci[, 2]) idrci[, 2] <- exp(idrci[, 1] - qnorm(1 - alpha/2) * idrci[, 2]) idrci[, 1] <- exp(idrci[, 1]) cat("\n") decimal1 <- ifelse(abs(idrci[, 1] - 1) < 0.01, 4, decimal) a <- cbind(paste(round(idrci[, 1], decimal1), " (", round(idrci[, 2], decimal1), ",", round(idrci[, 3], decimal1), ") ", sep = ""), ifelse(idrci[, 4] < 0.001, "< 0.001", round(idrci[, 4], decimal + 1))) colnames(a) <- c(paste("adj. IDR(", 100 - 100 * alpha, "%CI)", sep = ""), "P(Wald's test)") if (length(var.names) == 1) { colnames(a) <- c(paste("IDR(", 100 - 100 * alpha, "%CI)", sep = ""), "P(Wald's test)") } rownames.a <- rownames(a) if (crude) { decimal0 <- ifelse(abs(idrci0[, 1] - 1) < 0.01, 4, decimal) if (crude.p.value) { a0 <- cbind(paste(round(idrci0[, 1], decimal0), " (", round(idrci0[, 2], decimal0), ",", round(idrci0[, 3], decimal0), ") ", sep = ""), ifelse(idrci0[, 4, drop = FALSE] < 0.001, "< 0.001", round(idrci0[, 4, drop = FALSE], decimal + 1))) a <- cbind(a0, a) rownames(a) <- rownames.a colnames(a) <- c(paste("crude IDR(", 100 - 100 * alpha, "%CI)", sep = ""), "crude P value", paste("adj. IDR(", 100 - 100 * alpha, "%CI)", sep = ""), "P(Wald's test)") a[grep(":", rownames(a)), 1:2] <- "-" } else { a <- cbind(paste(round(idrci0[, 1], decimal1), " (", round(idrci0[, 2], decimal1), ",", round(idrci0[, 3], decimal1), ") ", sep = ""), a) colnames(a) <- c(paste("crude IDR(", 100 - 100 * alpha, "%CI)", sep = ""), paste("adj. IDR(", 100 - 100 * alpha, "%CI)", sep = ""), "P(Wald's test)") a[grep(":", rownames(a)), 1] <- "-" } } modified.coeff.array <- a table1 <- tableGlm(model, modified.coeff.array, decimal) } if(simplified) { first.line <- NULL last.lines <- NULL }else{ outcome.name <- names(model$model)[1] if(any(class(model)=="negbin")){ modelData <- get(as.character(model$call)[3]) }else{ modelData <- model$data } if (!is.null(attr(modelData, "var.labels"))) { outcome.name <- attr(modelData, "var.labels")[attr(modelData, "names") == names(model$model)[1]] } else { outcome.name <- names(model$model)[1] } outcome.name <- ifelse(outcome.name == "", names(model$model)[1], outcome.name) if(!is.null(model$offset)){ outcome.lab <- paste(outcome.name, "with offset =", deparse(as.list(model$call)$offset), "\n") }else{ outcome.lab <- paste(outcome.name, "\n") } } first.line <- paste("\n", ifelse(any(class(model)=="negbin"),"Negative binomial", "Poisson"), " regression predicting ", outcome.lab, sep = "") last.lines <- paste("Log-likelihood = ", round(logLik(model), decimal + 2), "\n", "No. of observations = ", length(model$y), "\n", "AIC value = ", round(s1$aic, decimal + 2), "\n","\n", sep = "") results <- list(first.line=first.line, table=table1, last.lines=last.lines) class(results) <- c("display", "list") results } ### MH- stratified analysis mhor <- function(..., mhtable=NULL, decimal=2, graph=TRUE, design="cohort") { if(is.null(mhtable)) {mhtable <- table(...)}else{mhtable <- as.table(mhtable)} a <-0 A <-0 Vara <-0 numerator <- 0 denominator <-0 or <- c(1:dim(mhtable)[3]) logse <- c(1:dim(mhtable)[3]) lowlim <- c(1:dim(mhtable)[3]) uplim <- c(1:dim(mhtable)[3]) p.value <- c(1:dim(mhtable)[3]) stratlab <- levels(as.data.frame(mhtable)[,3]) # Vector labelling strata tabodds <- c(1:(4*length(stratlab))) dim(tabodds) <- c(length(stratlab), 4) p <-0; q <-0; r <-0; s <-0; pr <-0; ps <-0; qr <-0; qs <-0; psqr <-0 for (i in 1:dim(mhtable)[3]) { # OR, ln(SE) and 95 ci for each staratum or[i] <- fisher.test(as.table(mhtable[,,i]))$estimate lowlim[i] <- fisher.test(as.table(mhtable[,,i]))$conf.int[1] uplim[i] <- fisher.test(as.table(mhtable[,,i]))$conf.int[2] p.value[i] <- fisher.test(as.table(mhtable[,,i]))$p.value # Computing MH odds ratio and standard error numerator <- numerator+ mhtable[1,1,i]*mhtable[2,2,i]/sum(mhtable[,,i]) denominator <- denominator+mhtable[1,2,i]*mhtable[2,1,i]/sum(mhtable[,,i]) p <- p+(mhtable[1,1,i]+mhtable[2,2,i])/sum(mhtable[,,i]) q <- q+(mhtable[1,2,i]+mhtable[2,1,i])/sum(mhtable[,,i]) r <- numerator s <- denominator pr <- pr+(mhtable[1,1,i]+mhtable[2,2,i])/sum(mhtable[,,i])* mhtable[1,1,i]*mhtable[2,2,i]/sum(mhtable[,,i]) ps <- ps+(mhtable[1,1,i]+mhtable[2,2,i])/sum(mhtable[,,i])* mhtable[1,2,i]*mhtable[2,1,i]/sum(mhtable[,,i]) qr <- qr+(mhtable[1,2,i]+mhtable[2,1,i])/sum(mhtable[,,i])* mhtable[1,1,i]*mhtable[2,2,i]/sum(mhtable[,,i]) qs <- qs+(mhtable[1,2,i]+mhtable[2,1,i])/sum(mhtable[,,i])* mhtable[1,2,i]*mhtable[2,1,i]/sum(mhtable[,,i]) psqr <- psqr+(mhtable[1,1,i]+mhtable[2,2,i])/sum(mhtable[,,i])* mhtable[1,2,i]*mhtable[2,1,i]/sum(mhtable[,,i])+ (mhtable[1,2,i]+mhtable[2,1,i])/sum(mhtable[,,i])* mhtable[1,1,i]*mhtable[2,2,i]/sum(mhtable[,,i]) # Computing chi-squared a <- a+ mhtable[1,1,i] A <- A+sum(mhtable[,1,i])*sum(mhtable[1,,i])/sum(mhtable[,,i]) Vara <- Vara + sum(mhtable[, 1, i]) / (sum(mhtable[, , i]) - 1) * sum(mhtable[1, , i]) * sum(mhtable[, 2, i]) * sum(mhtable[2, , i]) / sum(mhtable[, , i])^2 # Individual stratum tabodds[i,] <- c(or[i], lowlim[i], uplim[i], p.value[i]) } cat("\n") colnames(tabodds) <- c("OR", "lower lim.", "upper lim.", "P value") collab <- colnames(as.data.frame(mhtable))[3] cat("Stratified analysis by ",(collab), "\n") rownames(tabodds) <- paste(collab, stratlab, "") mhor <- numerator/denominator mhlogse <- sqrt(pr/2/r^2 + psqr/2/r/s + qs/2/s^2) mhlolim <- exp(log(mhor)-qnorm(0.975)*mhlogse) mhhilim <- exp(log(mhor)+qnorm(0.975)*mhlogse) chi2 <- abs(a-A)^2/Vara # If needs corrected chisquare: chi2 <-(abs(a-A)-1/2)^2/Vara mh.p.value <-pchisq(chi2,1, lower.tail=FALSE) het <- sum((log(or)-log(mhor))^2/(1/mhtable[1,1,]+ 1/mhtable[1,2,]+ 1/ mhtable[2,1,]+ 1/ mhtable[2,2,])) p.value.het <- pchisq(het, length(or)-1, lower.tail=FALSE) tabodds1 <- rbind(tabodds, c(mhor, mhlolim, mhhilim, mh.p.value)) rownames(tabodds1)[dim(tabodds1)[1]] <- "M-H combined" print(tabodds1, digit=3) cat("\n") cat("M-H Chi2(1) =", round(chi2,decimal), ", P value =", round(mh.p.value, decimal+1), "\n") mhresults <- list(strat.table=mhtable, mh.or=mhor, ci95=c(mhlolim, mhhilim)) if (any(mhtable==0)){ cat(paste("\n","One or more cells of the stratified table == 0.","\n", "Homogeneity test not computable.","\n","\n")) if(graph==TRUE){ graph <- FALSE cat(paste(" Graph not drawn","\n","\n")) } }else{ cat("Homogeneity test, chi-squared", dim(tabodds)[1]-1, "d.f. =", round(het,decimal),",", "P value =", round(p.value.het, decimal+1), "\n") cat("\n") } # mhresults if (graph==TRUE){ caseexp <- rep(0, dim(mhtable)[3]) controlex <- rep(0, dim(mhtable)[3]) casenonex <- rep(0, dim(mhtable)[3]) controlnonex <- rep(0, dim(mhtable)[3]) logit0 <- rep(0, dim(mhtable)[3]) se0 <- rep(0, dim(mhtable)[3]) logit1 <- rep(0, dim(mhtable)[3]) se1 <- rep(0, dim(mhtable)[3]) x <- rep(0, 6*dim(mhtable)[3]) y <- rep(0, 6*dim(mhtable)[3]) for(i in 1:dim(mhtable)[3]){ caseexp[i] <- mhtable[2,2,i] controlex[i] <- mhtable[1,2,i] casenonex[i] <- mhtable[2,1,i] controlnonex[i] <- mhtable[1,1,i] } if(design=="case control"||design=="case-control"||design=="casecontrol"){ for(i in 1:dim(mhtable)[3]){ logit0[i] <- log(controlex[i]/controlnonex[i]) se0[i] <- sqrt(1/controlex[i]+1/controlnonex[i]) logit1[i] <- log(caseexp[i]/casenonex[i]) se1[i] <- sqrt(1/caseexp[i]+1/casenonex[i]) x[(1:6)+(i-1)*6] <- c(c(-1,0,1)*1.96*se0[i] + logit0[i], c(-1,0,1)*1.96*se1[i] + logit1[i] ) y[(1:6)+(i-1)*6] <- c(rep(0+0.025*(i-1),3),rep(1+0.025*(i-1),3)) } plot(x,y, xlab="Odds of exposure",yaxt="n", xaxt="n", main="Stratified case control analysis", ylab=paste("Outcome=",colnames(as.data.frame(mhtable))[1], ", Exposure=",colnames(as.data.frame(mhtable))[2]),pch=" ") for(i in 1:dim(mhtable)[3]){ lines(x[c(1,3)+(i-1)*6],y[c(1,3)+(i-1)*6], col=i+1) lines(x[c(4,6)+(i-1)*6],y[c(4,6)+(i-1)*6], col=i+1) lines(x[c(2,5)+(i-1)*6],y[c(2,5)+(i-1)*6], col=i+1, lty=2) points(x[c(1,3)+(i-1)*6],y[c(1,3)+(i-1)*6], col=i+1, pch="I") points(x[c(4,6)+(i-1)*6],y[c(4,6)+(i-1)*6], col=i+1, pch="I") points(x[c(2,5)+(i-1)*6],y[c(2,5)+(i-1)*6], col=i+1,pch=22, cex=c(controlex[i]+controlnonex[i],caseexp[i]+casenonex[i])/sum(mhtable[,,])*8) text(x=(max(x)+min(x))/2, y=0.3+0.1*i, col=dim(mhtable)[3]+2-i, labels=paste(collab, stratlab[dim(mhtable)[3]+1-i],": OR= ", round(or[dim(mhtable)[3]+1-i],decimal)," (",round(lowlim[dim(mhtable)[3]+1-i],decimal),", ", round(uplim[dim(mhtable)[3]+1-i],decimal),")",sep="")) } x1 <- exp(x) a <- 2^(-10:10) if(length(a[a>min(x1) & a2 & length(a[a>min(x1) & amin(x1) & a=1))axis(1,at=log(a1[a1>=1]),labels=as.character(a1[a1>=1])) if(any(a1<1))axis(1,at=log(a1[a1<1]),labels=paste(as.character(1),"/", as.character(trunc(1/a1[a1<1])), sep="")) } else { options(digit=2) at.x <- seq(from=min(x),to=max(x),by=((max(x)-min(x))/5)) labels.oddsx <- exp(at.x) axis(1,at=at.x, labels=as.character(round(labels.oddsx,digits=decimal))) } text(x=(max(x)+min(x))/2, y=.3, labels=paste("MH-OR"," = ", round(mhor,decimal)," (",round(mhlolim,decimal),", ", round(mhhilim,decimal),")",sep="")) text(x=(max(x)+min(x))/2, y=.2, labels=paste("homogeneity test P value"," = ", round(p.value.het, decimal+1),sep="")) axis(2, at=0.025*(dim(mhtable)[3]-1)/2, labels="Control", las=1) axis(2, at=1+0.025*(dim(mhtable)[3]-1)/2, labels="Case", las=1) } if(design=="cohort" || design=="prospective"){ for(i in 1:dim(mhtable)[3]){ logit0[i] <- log(casenonex[i]/controlnonex[i]); se0[i] <-sqrt(1/casenonex[i]+1/controlnonex[i]) logit1[i] <- log(caseexp[i]/controlex[i]); se1[i] <- sqrt(1/caseexp[i]+1/controlnonex[i]) y[(1:6)+(i-1)*6] <- c(c(-1,0,1)*1.96*se0[i] + logit0[i],c(-1,0,1)*1.96*se1[i] + logit1[i] ) x[(1:6)+(i-1)*6] <- c(rep(0+0.025*(i-1),3),rep(1+0.025*(i-1),3)) } plot(x,y, ylab="Odds of outcome",yaxt="n", xaxt="n", main="Stratified prospective/X-sectional analysis", xlab=paste("Outcome=",colnames(as.data.frame(mhtable))[1], ", Exposure=",colnames(as.data.frame(mhtable))[2]),pch=" ") for(i in 1:dim(mhtable)[3]){ lines(x[(1:3)+(i-1)*6],y[(1:3)+(i-1)*6], col=i+1) lines(x[(4:6)+(i-1)*6],y[(4:6)+(i-1)*6], col=i+1) lines(x[c(2,5)+(i-1)*6],y[c(2,5)+(i-1)*6], col=i+1, lty=2) lines(x=c(-.02,.02)+0.025*(i-1),y=c(y[1+(i-1)*6],y[1+(i-1)*6]), col=i+1) lines(x=c(-.02,.02)+0.025*(i-1),y=c(y[3+(i-1)*6],y[3+(i-1)*6]), col=i+1) lines(x=c(.98,1.02)+0.025*(i-1),y=c(y[4+(i-1)*6],y[4+(i-1)*6]), col=i+1) lines(x=c(.98,1.02)+0.025*(i-1),y=c(y[6+(i-1)*6],y[6+(i-1)*6]), col=i+1) points(x[c(2,5)+(i-1)*6],y[c(2,5)+(i-1)*6], col=i+1, pch=22, cex=c((controlnonex[i]+casenonex[i]),(caseexp[i]+controlex[i]))/sum(mhtable[,,])*8) text(x=.5, y=0.3*(max(y)-min(y))+min(y)+ 0.1*i*(max(y)-min(y)), col=dim(mhtable)[3]+2-i, labels=paste(collab,stratlab[dim(mhtable)[3]+1-i],": OR = ", round(or[dim(mhtable)[3]+1-i],decimal)," (",round(lowlim[dim(mhtable)[3]+1-i],decimal),", ", round(uplim[dim(mhtable)[3]+1-i],decimal),")",sep="")) } text(x=.5, y=.3*(max(y)-min(y))+min(y), labels=paste("MH-OR"," = ", round(mhor,decimal)," (",round(mhlolim,decimal),", ", round(mhhilim,decimal),")",sep="")) text(x=.5, y=.2*(max(y)-min(y))+min(y), labels=paste("homogeneity test P value"," = ", round(p.value.het, decimal+1),sep="")) axis(1, at=0.025*(dim(mhtable)[3]-1)/2, labels="Non-exposed") axis(1, at=1+0.025*(dim(mhtable)[3]-1)/2, labels="Exposed") y1 <- exp(y) a <- 2^(-10:10) if(length(a[a>min(y1) & a2 & length(a[a>min(y1) & amin(y1) & a=1)) {axis(2,at=log(a1[a1>=1]),labels=as.character(a1[a1>=1]),las=1)} if(any(a<1)) {axis(2,at=log(a1[a1<1]),labels=paste(as.character(1),"/", as.character(trunc(1/a1[a1<1])), sep=""),las=1)} } else { options(digit=2) at.y <- seq(from=min(y),to=max(y),by=((max(y)-min(y))/5)) labels.oddsy <- exp(at.y) axis(2,at=at.y, labels=as.character(round(labels.oddsy,digits=decimal+1)),las=1) } } } } #### Logistic regression display logistic.display <- function (logistic.model, alpha = 0.05, crude = TRUE, crude.p.value = FALSE, decimal = 2, simplified = FALSE) { model <- logistic.model if(length(grep("[$]", attr(model$term, "term.labels"))) > 0 | length(grep(")", attr(model$term, "term.labels"))) > 0 | length(model$call) < 3){ simplified <- TRUE; crude <- TRUE }else{ factor.with.colon <- NULL for(i in 1:(length(attr(model$term, "term.labels")))){ factor.with.colon <- c(factor.with.colon, any(grep(":",model$xlevels[i]))) } factor.with.colon <- any(factor.with.colon) if((length(grep(":", attr(model$terms, "term.labels"))) > 1) | factor.with.colon){ simplified <- TRUE; crude <- TRUE }} if(simplified){ coeff <- summary(model)$coefficients[-1,] table1 <- cbind(exp(coeff[, 1]), exp(coeff[, 1] - qnorm(1 - alpha/2) * coeff[, 2]), exp(coeff[, 1] + qnorm(1 - alpha/2) * coeff[, 2]), coeff[,4] ) colnames(table1) <- c("OR", paste("lower", 100 - 100 * alpha, "ci", sep = ""), paste("upper", 100 - 100 * alpha, "ci", sep = ""), "Pr(>|Z|)") }else{ if (length(class(model)) == 1) { stop("Model not from logistic regression") } if (class(model)[1] != "glm" | class(model)[2] != "lm" | model$family$family != "binomial") { stop("Model not from logistic regression") } var.names <- attr(model$terms, "term.labels") if (length(var.names) == 1) { crude <- FALSE } if (crude) { orci0 <- NULL for (i in 1:length(var.names)) { formula0 <- as.formula(paste(names(model$model)[1], "~", var.names[i])) if(names(model$coefficient)[1]!="(Intercept)"){ formula0 <- as.formula(paste(names(model$model)[1], "~", var.names[i], "- 1")) } if(length(grep("cbind", names(model$model)[1])) > 0){ model0 <- glm(formula0, family = binomial, data = get(as.character(model$call)[4])) }else{ model0 <- glm(formula0, weights = model$prior.weights, family = binomial, data = model$model) } coeff.matrix <- (summary(model0))$coefficients[-1, , drop = FALSE] if(names(model$coefficient)[1]!="(Intercept)"){ coeff.matrix <- (summary(model0))$coefficients[, , drop = FALSE] } if (length(grep(":", var.names[i])) > 0) { var.name.interact <- unlist(strsplit(var.names[i], ":")) if (any(names(model$xlevels) == var.name.interact[1])) { level1 <- length(unlist(model$xlevels[var.name.interact[1]])) - 1 } else { level1 <- 1 } if (any(names(model$xlevels) == var.name.interact[2])) { level2 <- length(unlist(model$xlevels[var.name.interact[2]])) - 1 } else { level2 <- 1 } dim.coeff <- dim((summary(model0))$coefficients[-1, , drop = FALSE]) coeff.matrix <- matrix(rep(NA, dim.coeff[1] * dim.coeff[2]), dim.coeff[1], dim.coeff[2]) coeff.matrix <- coeff.matrix[1:(level1 * level2), , drop = FALSE] } orci0 <- rbind(orci0, coeff.matrix) } if(names(model$coefficient)[1]=="(Intercept)"){ orci0 <- rbind(matrix(rep(0, 4), 1, 4), orci0) } colnames(orci0) <- c("crudeOR", paste("lower0", 100 - 100 * alpha, "ci", sep = ""), paste("upper0", 100 - 100 * alpha, "ci", sep = ""), "crude P value") orci0[, 3] <- exp(orci0[, 1] + qnorm(1 - alpha/2) * orci0[, 2]) orci0[, 2] <- exp(orci0[, 1] - qnorm(1 - alpha/2) * orci0[, 2]) orci0[, 1] <- exp(orci0[, 1]) } s1 <- summary(model) orci <- s1$coefficients colnames(orci) <- c("OR", paste("lower", 100 - 100 * alpha, "ci", sep = ""), paste("upper", 100 - 100 * alpha, "ci", sep = ""), "P(Wald's test)") orci[, 3] <- exp(orci[, 1] + qnorm(1 - alpha/2) * orci[, 2]) orci[, 2] <- exp(orci[, 1] - qnorm(1 - alpha/2) * orci[, 2]) orci[, 1] <- exp(orci[, 1]) decimal1 <- ifelse(abs(orci[, 1] - 1) < 0.01, 4, decimal) a <- cbind(paste(round(orci[, 1], decimal1), " (", round(orci[, 2], decimal1), ",", round(orci[, 3], decimal1), ") ", sep = ""), ifelse(orci[, 4] < 0.001, "< 0.001", round(orci[, 4], decimal + 1))) colnames(a) <- c(paste("adj. OR(", 100 - 100 * alpha, "%CI)", sep = ""), "P(Wald's test)") if (length(var.names) == 1) { colnames(a) <- c(paste("OR(", 100 - 100 * alpha, "%CI)", sep = ""), "P(Wald's test)") } rownames.a <- rownames(a) if (crude) { decimal0 <- ifelse(abs(orci0[, 1] - 1) < 0.01, 4, decimal) if (crude.p.value) { a0 <- cbind(paste(round(orci0[, 1], decimal0), " (", round(orci0[, 2], decimal0), ",", round(orci0[, 3], decimal0), ") ", sep = ""), ifelse(orci0[, 4, drop = FALSE] < 0.001, "< 0.001", round(orci0[, 4, drop = FALSE], decimal + 1))) a <- cbind(a0, a) rownames(a) <- rownames.a colnames(a) <- c(paste("crude OR(", 100 - 100 * alpha, "%CI)", sep = ""), "crude P value", paste("adj. OR(", 100 - 100 * alpha, "%CI)", sep = ""), "P(Wald's test)") a[grep(":", rownames(a)), 1:2] <- "-" } else { a <- cbind(paste(round(orci0[, 1], decimal1), " (", round(orci0[, 2], decimal1), ",", round(orci0[, 3], decimal1), ") ", sep = ""), a) colnames(a) <- c(paste("crude OR(", 100 - 100 * alpha, "%CI)", sep = ""), paste("adj. OR(", 100 - 100 * alpha, "%CI)", sep = ""), "P(Wald's test)") a[grep(":", rownames(a)), 1] <- "-" } } modified.coeff.array <- a table1 <- tableGlm(model, modified.coeff.array, decimal) } if(simplified) { first.line <- NULL last.lines <- NULL }else{ outcome.name <- names(model$model)[1] if (!is.null(attr(model$data, "var.labels"))) { outcome.name <- attr(model$data, "var.labels")[attr(model$data, "names") == names(model$model)[1]] } else { outcome.name <- names(model$model)[1] } outcome.name <- ifelse(outcome.name == "", names(model$model)[1], outcome.name) if (crude) { if (attr(model0$term, "dataClasses")[1] == "logical") { outcome.lab <- paste(outcome.name, "\n") } else { if ((attr(model$term, "dataClasses")[1] == "numeric") | (attr(model$term, "dataClasses")[1] == "integer")) { outcome.levels <- levels(factor(model$model[, 1])) outcome.lab <- paste(outcome.name, outcome.levels[2], "vs", outcome.levels[1], "\n") } } } if (attr(model$term, "dataClasses")[1] == "factor") { outcome.lab <- paste(names(model$model)[1], ":", levels(model$model[, 1])[2], "vs", levels(model$model[, 1])[1], "\n") } else { outcome.lab <- paste(outcome.name, "\n") } first.line <-paste("\n", "Logistic regression predicting ", outcome.lab, sep = "") last.lines <- paste("Log-likelihood = ", round(logLik(model), decimal + 2), "\n", "No. of observations = ", length(model$y), "\n", "AIC value = ", round(s1$aic, decimal + 2), "\n","\n", sep = "") } results <- list(first.line=first.line, table=table1, last.lines=last.lines) class(results) <- c("display", "list") results } print.display <- function(x, ...) { cat(x$first.line, "\n") print.noquote(x$table) cat(x$last.lines) } ###### Linear regression display regress.display <- function (regress.model, alpha = 0.05, crude=FALSE, crude.p.value=FALSE, decimal = 2, simplified=FALSE) { model <- regress.model if(length(grep("[$]", attr(model$term, "term.labels"))) > 0 | length(grep(")", attr(model$term, "term.labels"))) > 0 | length(model$call) < 3){ simplified <- TRUE; crude <- TRUE }else{ factor.with.colon <- NULL for(i in 1:(length(attr(model$term, "term.labels"))-1)){ factor.with.colon <- c(factor.with.colon, any(grep(":",model$xlevels[i]))) } factor.with.colon <- any(factor.with.colon) if((length(grep(":", attr(model$terms, "term.labels"))) > 1) | factor.with.colon){ simplified <- TRUE; crude <- TRUE }} if(simplified){ coeff <- summary(model)$coefficients table1 <- cbind(coeff[,1], (coeff[,1] - qt((1 - alpha/2), summary(model)$df[2]) * coeff[,2]), (coeff[,1] + qt((1 - alpha/2), summary(model)$df[2]) * coeff[,2]), coeff[,4]) colnames(table1) <- c("Coeff", paste("lower0", 100 - 100 * alpha, "ci", sep = ""), paste("upper0", 100 - 100 * alpha, "ci", sep = ""), "Pr>|t|") }else{ if(length(class(model))==2){ if (class(model)[1] != "glm" | class(model)[2] != "lm" | model$family$family != "gaussian") { stop("Model not from linear regression") }}else{ if(length(class(model))==1){ if (class(model) != "lm" ) { stop("Model not from linear regression") }}} var.names <- attr(model$terms, "term.labels") # Independent vars if(length(var.names)==1){crude <- FALSE} if(crude){ reg.ci0 <- NULL for(i in 1:length(var.names)){ formula0 <- as.formula(paste(names(model$model)[1], "~", var.names[i])) if(any(class(model)=="glm")){ model0 <- glm(formula0, weights=model$prior.weights, family=model$family, data=model$model) }else{ model0 <- lm(formula0, weights=model$prior.weights, data=model$model) } coeff.matrix <- (summary(model0))$coefficients[-1,] if(length(grep(":", var.names[i]))>0){ var.name.interact <- unlist(strsplit(var.names[i], ":")) if(any(names(model$xlevels)==var.name.interact[1])){ level1 <- length(unlist(model$xlevels[var.name.interact[1]]))-1 }else{ level1 <- 1 } if(any(names(model$xlevels)==var.name.interact[2])){ level2 <- length(unlist(model$xlevels[var.name.interact[2]]))-1 }else{ level2 <- 1 } dim.coeff <- dim((summary(model0))$coefficients[-1,, drop=FALSE]) coeff.matrix <- matrix(rep(NA, dim.coeff[1]*dim.coeff[2]), dim.coeff[1], dim.coeff[2]) coeff.matrix <- coeff.matrix[1:(level1*level2), ,drop=FALSE] } reg.ci0 <- rbind(reg.ci0, coeff.matrix) } reg.ci0 <- rbind(matrix(rep(0,4),1,4), reg.ci0) colnames(reg.ci0) <- c("crude.Coeff", paste("lower0", 100 - 100 * alpha, "ci", sep = ""), paste("upper0", 100 - 100 * alpha, "ci", sep = ""), "crude P value") reg.ci0[, 3] <- (reg.ci0[, 1] + qt((1 - alpha/2), summary(model0)$df[2]) * reg.ci0[, 2]) reg.ci0[, 2] <- (reg.ci0[, 1] - qt((1 - alpha/2), summary(model0)$df[2]) * reg.ci0[, 2]) } s1 <- summary(model) reg.ci <- s1$coefficients colnames(reg.ci) <- c("Coeff", paste("lower", 100 - 100 * alpha, "ci", sep = ""), paste("upper", 100 - 100 * alpha, "ci", sep = ""), "P(t-test)") reg.ci[, 3] <- (reg.ci[, 1] + qt((1 - alpha/2), summary(model)$df[2]) * reg.ci[, 2]) reg.ci[, 2] <- (reg.ci[, 1] - qt((1 - alpha/2), summary(model)$df[2]) * reg.ci[, 2]) decimal1 <- ifelse(abs(reg.ci[,1]-1) < .01, 4, decimal) a <- cbind(paste(round(reg.ci[,1], decimal1)," (",round(reg.ci[,2], decimal1),",", round(reg.ci[,3], decimal1),") ", sep=""), ifelse(reg.ci[,4] < .001, "< 0.001",round(reg.ci[,4],decimal+1))) colnames(a) <- c(paste("adj. coeff.(",100 - 100 * alpha, "%CI)",sep=""),"P(t-test)") if(length(var.names)==1){ colnames(a) <- c(paste("Coeff.(",100 - 100 * alpha, "%CI)",sep=""),"P(t-test)") } rownames.a <- rownames(a) if(crude){ decimal0 <- ifelse(abs(reg.ci0[,1]-1) < .01, 4, decimal) if(crude.p.value){ a0 <- cbind(paste(round(reg.ci0[,1], decimal0)," (",round(reg.ci0[,2], decimal0),",", round(reg.ci0[,3], decimal0),") ", sep=""), ifelse(reg.ci0[,4] < .001, "< 0.001",round(reg.ci0[,4],decimal+1))) a <- cbind(a0,a) rownames(a) <- rownames.a colnames(a) <- c(paste("crude coeff.(",100 - 100 * alpha, "%CI)",sep="") ,"crude P value", paste("adj. coeff.(",100 - 100 * alpha, "%CI)",sep=""),"P(t-test)") a[grep(":",rownames(a)) ,1:2] <- "-" }else{ a <- cbind(paste(round(reg.ci0[,1], decimal1)," (",round(reg.ci0[,2], decimal1),",", round(reg.ci0[,3], decimal1),") ", sep=""), a) colnames(a) <- c(paste("crude coeff.(",100 - 100 * alpha, "%CI)",sep="") , paste("adj. coeff.(",100 - 100 * alpha, "%CI)",sep=""),"P(t-test)") a[grep(":",rownames(a)) ,1] <- "-" } } modified.coeff.array <- a tableGlm(model, modified.coeff.array, decimal) -> table1 } if(simplified) { first.line <- NULL last.lines <- NULL }else{ outcome.name <- names(model$model)[1] if(!is.null(attr(model$data, "var.labels"))){ outcome.name <- attr(model$data, "var.labels")[attr(model$data, "names")==names(model$model)[1]] }else{ if(!is.null(attributes(get(as.character(model$call)[3]))$var.labels)){ var.labels <- attributes(get(as.character(model$call)[3]))$var.labels outcome.name <- var.labels[names(get(as.character(model$call)[3]))==outcome.name] }else{ outcome.name <- names(model$model)[1] }} outcome.name <- ifelse(outcome.name == "", names(model$model)[1], outcome.name) first.line <- paste("Linear regression predicting ",outcome.name, sep="", "\n") if(any(class(model)=="glm")){ last.lines <- paste("Log-likelihood = ", round(logLik(model), decimal + 2), "\n", "No. of observations = ", length(model$y), "\n", "AIC value = ", round(s1$aic, decimal + 2), "\n","\n", sep = "") }else{ last.lines <- paste("No. of observations = ", nrow(model$model), "\n","\n", sep = "") } } results <- list(first.line=first.line, table=table1, last.lines=last.lines) class(results) <- c("display", "list") results } #### Conditional logistic regression display clogistic.display <- function (clogit.model, alpha = 0.05, crude=TRUE, crude.p.value=FALSE, decimal = 2, simplified = FALSE) { model <- clogit.model if(!any(class(model)=="clogit")){stop("Model not from conditional logisitic regression")} if(length(grep("[$]", attr(model$term, "term.labels")[-length(attr(model$term, "term.labels"))])) > 0 | length(grep(")", attr(model$term, "term.labels")[-length(attr(model$term, "term.labels"))])) > 0 | length(model$userCall) < 3){ simplified <- TRUE; crude <- TRUE }else{ factor.with.colon <- NULL for(i in 1:(length(attr(model$term, "term.labels"))-1)){ factor.with.colon <- c(factor.with.colon, any(grep(pattern=":",levels(get(as.character(model$call)[3])[,attr(model$term,"term.labels")[i]])))) } factor.with.colon <- any(factor.with.colon) if(length(grep(":", attr(model$terms, "term.labels")))> 1 | factor.with.colon){ simplified <- TRUE; crude <- TRUE }} if(simplified){ table1 <- summary(model)$conf.int[,-2] colnames(table1)[1] <- "Adj. OR" }else{ var.names0 <- attr(model$terms, "term.labels") # Independent vars var.names <- var.names0[-grep(pattern="strata", var.names0)] if(length(var.names)==1){crude <- FALSE} if(crude){ orci0 <- NULL for(i in 1:(length(var.names))){ formula0 <- as.formula(paste( rownames(attr(model$terms,"factor"))[1], "~", paste(c(var.names[i], var.names0[grep(pattern="strata", var.names0)]), collapse="+"))) model0 <- coxph(formula0, data=get(as.character(model$call)[3]) ) coeff.matrix <- summary(model0)$coef[,c(1,3:5), drop=FALSE] if(length(grep(":", var.names[i]))>0){ var.name.interact <- unlist(strsplit(var.names[i], ":")) if(is.factor(get(as.character(model$call)[3])[,var.name.interact[1]])){ level1 <- length(levels(get(as.character(model$call)[3])[,var.name.interact[1]]))-1 }else{ level1 <- 1 } if(is.factor(get(as.character(model$call)[3])[,var.name.interact[2]])){ level2 <- length(levels(get(as.character(model$call)[3])[,var.name.interact[2]]))-1 }else{ level2 <- 1 } dim.coeff <- dim((summary(model0))$coef[,c(1,3:5), drop=FALSE]) coeff.matrix <- matrix(rep(NA, dim.coeff[1]*dim.coeff[2]), dim.coeff[1], dim.coeff[2]) coeff.matrix <- coeff.matrix[1:(level1*level2), ,drop=FALSE] } orci0 <- rbind(orci0, coeff.matrix) } colnames(orci0) <- c("crudeOR", paste("lower0", 100 - 100 * alpha, "ci", sep = ""), paste("upper0", 100 - 100 * alpha, "ci", sep = ""), "crude P value") orci0[, 3] <- exp(orci0[, 1] + qnorm(1 - alpha/2) * orci0[, 2]) orci0[, 2] <- exp(orci0[, 1] - qnorm(1 - alpha/2) * orci0[, 2]) orci0[, 1] <- exp(orci0[, 1]) } s1 <- summary(model) orci <- s1$coef[, c(1,3:5), drop=FALSE] colnames(orci) <- c("OR", paste("lower", 100 - 100 * alpha, "ci", sep = ""), paste("upper", 100 - 100 * alpha, "ci", sep = ""), "P(Wald's test)") orci[, 3] <- exp(orci[, 1] + qnorm(1 - alpha/2) * orci[, 2]) orci[, 2] <- exp(orci[, 1] - qnorm(1 - alpha/2) * orci[, 2]) orci[, 1] <- exp(orci[, 1]) decimal1 <- ifelse(abs(orci[,1]-1) < .01, 4, decimal) a <- cbind(paste(round(orci[,1], decimal1)," (",round(orci[,2], decimal1),",", round(orci[,3], decimal1),") ", sep=""), ifelse(orci[,4] < .001, "< 0.001",round(orci[,4],decimal+1))) colnames(a) <- c(paste("adj. OR(",100 - 100 * alpha, "%CI)",sep=""),"P(Wald's test)") if(length(var.names)==2){ colnames(a) <- c(paste("OR(",100 - 100 * alpha, "%CI)",sep=""),"P(Wald's test)") } if(length(var.names)==1){ colnames(a) <- c(paste("OR(",100 - 100 * alpha, "%CI)",sep=""),"P(Wald's test)") } rownames.a <- rownames(a) if(crude){ decimal0 <- ifelse(abs(orci0[,1]-1) < .01, 4, decimal) if(crude.p.value){ a0 <- cbind(paste(round(orci0[,1,drop=FALSE], decimal0)," (",round(orci0[,2,drop=FALSE], decimal0),",", round(orci0[,3, drop=FALSE], decimal0),") ", sep=""), ifelse(orci0[,4, drop=FALSE] < .001, "< 0.001",round(orci0[,4, drop=FALSE],decimal+1))) a <- cbind(a0,a) rownames(a) <- rownames.a colnames(a) <- c(paste("crude OR(",100 - 100 * alpha, "%CI)",sep="") ,"crude P value", paste("adj. OR(",100 - 100 * alpha, "%CI)",sep=""),"P(Wald's test)") a[grep(":",rownames(a)) , 1:2] <- "-" }else{ a <- cbind(paste(round(orci0[,1, drop=FALSE], decimal1)," (",round(orci0[,2, drop=FALSE], decimal1),",", round(orci0[,3, drop=FALSE], decimal1),") ", sep=""), a) colnames(a) <- c(paste("crude OR(",100 - 100 * alpha, "%CI)",sep="") , paste("adj. OR(",100 - 100 * alpha, "%CI)",sep=""),"P(Wald's test)") a[grep(":",rownames(a)) , 1] <- "-" } } modified.coeff.array <- a tableGlm(model, modified.coeff.array, decimal) -> table1 } if(simplified) { first.line <- NULL last.lines <- NULL }else{ outcome.name <- substr(as.character(model$userCall)[2], 1, regexpr(" ", as.character(model$userCall)[2])-1) outcome <- get(as.character(model$userCall)[3])[,outcome.name] outcome.class <- class(outcome) if(outcome.class=="logical"){ outocme.lab <- paste(outcome.name, "yes vs no","\n") }else{ if(outcome.class=="numeric" | outcome.class=="integer"){ outcome.levels <- levels(factor(outcome)) outcome.lab <- paste(outcome.name, ":", outcome.levels[2], "vs", outcome.levels[1],"\n") }else{ if(outcome.class=="factor"){ outcome.lab <- paste(outcome.name, ":", levels(outcome)[2], "vs", levels(outcome)[1],"\n") }else{ outcome.lab <- outcome.name }}} first.line <- paste("Conditional logistic regression predicting ",outcome.lab, sep="", "\n") last.lines <- paste("No. of observations = ", model$n, "\n") } results <- list(first.line=first.line, table=table1, last.lines=last.lines) class(results) <- c("display", "list") results } ####### Cox's regression display cox.display <- function (cox.model, alpha = 0.05, crude=TRUE, crude.p.value=FALSE, decimal = 2, simplified = FALSE) { model <- cox.model if(!any(class(model)=="coxph")){stop("Model not from conditional logisitic regression")} if(length(grep("[$]", attr(model$term, "term.labels"))) > 0 | length(grep(")", attr(model$term, "term.labels"))) > 0 | length(model$call) < 3){ simplified <- TRUE; crude <- TRUE }else{ factor.with.colon <- NULL for(i in 1:(length(attr(model$term, "term.labels"))-1)){ factor.with.colon <- c(factor.with.colon, any(grep(pattern=":",levels(get(as.character(model$call)[3])[,attr(model$term,"term.labels")[i]])))) } factor.with.colon <- any(factor.with.colon) if(length(grep(":", attr(model$terms, "term.labels")))> 1 | factor.with.colon){ simplified <- TRUE; crude <- TRUE }} if(simplified){ table1 <- summary(model)$conf.int[,-2] colnames(table1)[1] <- "Adj. OR" }else{ var.names <- attr(model$terms, "term.labels") # Independent vars if(length(grep("strata", var.names)) > 0){ var.names <- var.names[-grep("strata",var.names)] } if(length(var.names)==1){crude <- FALSE} if(crude){ orci0 <- NULL for(i in 1:(length(var.names))){ formula0 <- as.formula(paste( rownames(attr(model$terms,"factor"))[1], "~", var.names[i])) suppressWarnings(model0 <- coxph(formula0, data=get(as.character(model$call)[3]) )) coeff.matrix <- summary(model0)$coef[,c(1,3:5), drop=FALSE] if(length(grep(":", var.names[i]))>0){ var.name.interact <- unlist(strsplit(var.names[i], ":")) if(is.factor(get(as.character(model$call)[3])[,var.name.interact[1]])){ level1 <- length(levels(get(as.character(model$call)[3])[,var.name.interact[1]]))-1 }else{ level1 <- 1 } if(is.factor(get(as.character(model$call)[3])[,var.name.interact[2]])){ level2 <- length(levels(get(as.character(model$call)[3])[,var.name.interact[2]]))-1 }else{ level2 <- 1 } dim.coeff <- dim((summary(model0))$coef[,c(1,3:5), drop=FALSE]) coeff.matrix <- matrix(rep(NA, dim.coeff[1]*dim.coeff[2]), dim.coeff[1], dim.coeff[2]) coeff.matrix <- coeff.matrix[1:(level1*level2), ,drop=FALSE] } orci0 <- rbind(orci0, coeff.matrix) } colnames(orci0) <- c("crudeOR", paste("lower0", 100 - 100 * alpha, "ci", sep = ""), paste("upper0", 100 - 100 * alpha, "ci", sep = ""), "crude P value") orci0[, 3] <- exp(orci0[, 1] + qnorm(1 - alpha/2) * orci0[, 2]) orci0[, 2] <- exp(orci0[, 1] - qnorm(1 - alpha/2) * orci0[, 2]) orci0[, 1] <- exp(orci0[, 1]) } s1 <- summary(model) orci <- s1$coef[, c(1,3:5), drop=FALSE] colnames(orci) <- c("OR", paste("lower", 100 - 100 * alpha, "ci", sep = ""), paste("upper", 100 - 100 * alpha, "ci", sep = ""), "P(Wald's test)") orci[, 3] <- exp(orci[, 1] + qnorm(1 - alpha/2) * orci[, 2]) orci[, 2] <- exp(orci[, 1] - qnorm(1 - alpha/2) * orci[, 2]) orci[, 1] <- exp(orci[, 1]) decimal1 <- ifelse(abs(orci[,1]-1) < .01, 4, decimal) a <- cbind(paste(round(orci[,1], decimal1)," (",round(orci[,2], decimal1),",", round(orci[,3], decimal1),") ", sep=""), ifelse(orci[,4] < .001, "< 0.001",round(orci[,4],decimal+1))) colnames(a) <- c(paste("adj. HR(",100 - 100 * alpha, "%CI)",sep=""),"P(Wald's test)") if(length(var.names)==2){ colnames(a) <- c(paste("HR(",100 - 100 * alpha, "%CI)",sep=""),"P(Wald's test)") } if(length(var.names)==1){ colnames(a) <- c(paste("HR(",100 - 100 * alpha, "%CI)",sep=""),"P(Wald's test)") } rownames.a <- rownames(a) if(crude){ decimal0 <- ifelse(abs(orci0[,1]-1) < .01, 4, decimal) if(crude.p.value){ a0 <- cbind(paste(round(orci0[,1,drop=FALSE], decimal0)," (",round(orci0[,2,drop=FALSE], decimal0),",", round(orci0[,3, drop=FALSE], decimal0),") ", sep=""), ifelse(orci0[,4, drop=FALSE] < .001, "< 0.001",round(orci0[,4, drop=FALSE],decimal+1))) a <- cbind(a0,a) rownames(a) <- rownames.a colnames(a) <- c(paste("crude HR(",100 - 100 * alpha, "%CI)",sep="") ,"crude P value", paste("adj. HR(",100 - 100 * alpha, "%CI)",sep=""),"P(Wald's test)") a[grep(":",rownames(a)) ,1:2] <- "-" }else{ a <- cbind(paste(round(orci0[,1, drop=FALSE], decimal1)," (",round(orci0[,2, drop=FALSE], decimal1),",", round(orci0[,3, drop=FALSE], decimal1),") ", sep=""), a) colnames(a) <- c(paste("crude HR(",100 - 100 * alpha, "%CI)",sep="") , paste("adj. HR(",100 - 100 * alpha, "%CI)",sep=""),"P(Wald's test)") a[grep(":",rownames(a)) ,1] <- "-" } } modified.coeff.array <- a tableGlm(model, modified.coeff.array, decimal) -> table1 } if(simplified) { first.line <- NULL last.lines <- NULL }else{ surv.string <- as.character(model$formula)[2] if(length(grep(",", surv.string)) > 0){ time.var.name <- substr(unlist(strsplit(surv.string, ","))[1], 6, nchar(unlist(strsplit(surv.string, ","))[1])) status.var.name <- substr(unlist(strsplit(surv.string, " "))[2], 1, nchar(unlist(strsplit(surv.string, " "))[2])-1) intro <- paste("Cox's proportional hazard model on time ('", time.var.name, "') to event ('", status.var.name, "')",sep="") }else{ intro <- paste("Cox's proportional hazard model on '", surv.string, "'", sep="") } var.names0 <- attr(model$terms, "term.labels") if(length(grep("strata", var.names0))>0) {intro <- paste(intro, " with '", var.names0[grep("strata", var.names0)], "'", sep="" )} first.line <- paste(intro, "\n") last.lines <- paste("No. of observations = ", model$n, "\n") } results <- list(first.line=first.line, table=table1, last.lines=last.lines) class(results) <- c("display", "list") results } ####### Table for GLM and lm tableGlm <- function (model, modified.coeff.array, decimal) { ########## Nice row definition starts from here ## What we need here is the glm model object and 'modified.coeff.array' var.names <- attr(model$terms, "term.labels") # Independent vars if(any(class(model)=="coxph")){ var.names0 <- var.names if(length(grep("strata", var.names)) > 0){ var.names <- var.names[-grep(pattern="strata", var.names)] } if(any(class(model)=="clogit")){ data <- na.omit((get(as.character(model$call)[3]))[,c(as.character(model$term[[2]][3]),var.names, as.character(model$term[[3]][[length(model$call)-1]][2]))]) }else{ data <- na.omit(get(as.character(model$call)[3])[,c(as.character(model$call[[2]][[2]][c(2,3)]) ,as.character(attr(model$terms, "variables")[-c(1:2)]))]) }} table1 <- NULL if(any(class(model)=="glm") | any(class(model)=="lm")) { coeff.names <- names(model$coefficients) }else{ if(any(class(model)=="coxph")){ coeff.names <- names(model$coef) } } label.row0 <- rep("", ncol(modified.coeff.array)) label.row0 <- t(label.row0) blank.row <- rep("", ncol(modified.coeff.array)) blank.row <- t(blank.row) rownames(blank.row) <- "" if(any(class(model)=="glm")){ if(any(model$family=="gaussian")){ unlist(summary(aov(model))) -> array.summ.aov dim(array.summ.aov) <- c(length(array.summ.aov)/5,5) F.p.value <- array.summ.aov[-nrow(array.summ.aov),5] F.p.value <- ifelse(F.p.value < .001, "< 0.001",round(F.p.value,decimal+1)) } }else{ if(any(class(model)=="lm")){ unlist(summary(aov(model))) -> array.summ.aov dim(array.summ.aov) <- c(length(array.summ.aov)/5,5) F.p.value <- array.summ.aov[-nrow(array.summ.aov),5] F.p.value <- ifelse(F.p.value < .001, "< 0.001",round(F.p.value,decimal+1)) }} for(i in 1:length(var.names)){ # i is the variable order in model # Define variable class and levels if(any(class(model)=="lm")){ if(length(grep(pattern=":", var.names[i])) < 1){ variable <- model$model[,i+1] var.name.class <- attr(model$terms, "dataClasses")[names(attr(model$terms, "dataClasses"))==var.names[i]] if(var.name.class=="factor"){ var.name.levels <- unlist(unlist(model$xlevels))[substr(names(unlist(model$xlevels)),1,nchar(var.names[i]))==var.names[i]] } } }else{ if(any(class(model)=="coxph")){ if(length(grep(pattern=":", var.names[i])) < 1){ variable <- data[,var.names[i]] var.name.class <- class(data[,var.names[i]]) if(var.name.class=="factor"){ var.name.levels <- levels(data[,var.names[i]]) }}}} # Define variable labels if(any(class(model)=="glm")){ var.labels <- attr(model$data, "var.labels")[attr(model$data, "names")==var.names[i]] if(any(class(model)=="negbin")){ var.labels <- attributes(get(as.character(model$call)[3]))$var.labels[names(get(as.character(model$call)[3]))==var.names[i]] } }else{ if(any(class(model)=="coxph")){ var.labels <- attributes(get(as.character(model$call)[3]))$var.labels[names(get(as.character(model$call)[3]))==var.names[i]] } if(any(class(model)=="lm")){ var.labels <- attributes(get(as.character(model$call)[3]))$var.labels[names(get(as.character(model$call)[3]))==var.names[i]] } } # Define model1 for lr test if(any(class(model)=="glm")){ if(any(model$family=="binomial") |any(model$family=="poisson") | any(class(model)=="negbin")){ if(length(var.names)==1){ formula1 <- as.formula(paste(names(model$model)[1], "~", "1")) }else{ formula1 <- as.formula(paste(names(model$model)[1], "~", paste(var.names[-i], collapse="+"))) if(names(model$coefficients)[1] != "(Intercept)"){ formula1 <- as.formula(paste(names(model$model)[1], "~", paste(var.names[-i], "-1", collapse="+"))) }} if(length(grep("cbind", names(model$model)[1])) > 0){ model1 <- glm(formula1, family=model$family, weights=model$prior.weights, data = get(as.character(model$call)[4])) }else{ model1 <- glm(formula1, family=model$family, weights=model$prior.weights, offset=model$offset, data=model$model) } if(any(class(model)=="negbin")){ model1 <- glm.nb (as.formula(paste(names(model$model)[1], "~", ifelse(length(var.names)==1,"1",paste(var.names[-i], collapse="+"))))) } if((length(var.names)==1 & names(model$coefficients)[1] != "(Intercept)")){ lr.p.value <- "-" }else{ lr.p.value <- suppressWarnings(lrtest(model1, model)$p.value) lr.p.value <- ifelse(lr.p.value < .001, "< 0.001",round(lr.p.value,decimal+1)) } } }else{ if(any(class(model)=="coxph")){ if(length(var.names)==1){ lr.p.value <- summary(model)$logtest[3] }else{ b <- as.character(model$formula) if(any(class(model)=="clogit")){ formula.full.coxph <- as.formula(paste(as.character(model$term[[2]][3]), "~", paste(var.names0, collapse="+"))) model.full.coxph <- clogit(formula.full.coxph, data=data) }else{ formula.full.coxph <- as.formula(paste(b[2], "~", paste(var.names, collapse="+"))) model.full.coxph <- coxph(formula.full.coxph, data=data) } if(any(class(model)=="clogit")){ formula.coxph.i <- as.formula(paste(as.character(model$term[[2]][3]), "~", paste(c(var.names[-i], var.names0[grep("strata", var.names0)]), collapse="+"))) model.coxph.i <- clogit(formula.coxph.i, data=data) }else{ formula.coxph.i <- as.formula(paste(b[2], "~", paste(var.names[-i], collapse="+"))) model.coxph.i <- coxph(formula.coxph.i, data=data) } lr.p.value <- suppressWarnings(lrtest(model.full.coxph, model.coxph.i)$p.value) } lr.p.value <- ifelse(lr.p.value < .001, "< 0.001",round(lr.p.value,decimal+1)) } } # Define table0 if(length(var.names)==1){ if((any(class(model)=="glm") | any(class(model)=="lm")) & names(model$coefficients)[1]=="(Intercept)"){ table0 <- modified.coeff.array[-1,] }else( table0 <- modified.coeff.array ) }else{ if(length(grep(":", var.names[i])) > 0){ table0 <- modified.coeff.array[grep(":", rownames(modified.coeff.array)),] }else{ if((any(class(model)=="lm") & (var.name.class=="factor"| var.name.class=="logical"))|any(class(model)=="coxph")){ table0 <- modified.coeff.array[setdiff(which(substr(rownames(modified.coeff.array),1, nchar(var.names[i]))==var.names[i]), grep(":", rownames(modified.coeff.array))) ,] }else{ table0 <- modified.coeff.array[rownames(modified.coeff.array)==var.names[i],] } }} if(is.null(nrow(table0))) table0 <- t(table0) # Define column names and row names if(nrow(table0)==1){ # table0 with only a single row if(any(class(model)=="glm" | any(class(model)=="coxph"))){ if(any(model$family=="binomial") |any(model$family=="poisson") |any(class(model)=="coxph")){ table0 <- cbind(table0, lr.p.value) colnames(table0) <- c(colnames(modified.coeff.array),"P(LR-test)") } if(any(model$family=="gaussian")){ table0 <- cbind(table0, F.p.value[i]) colnames(table0) <- c(colnames(modified.coeff.array),"P(F-test)") } }else{ table0 <- cbind(table0, F.p.value[i]) colnames(table0) <- c(colnames(modified.coeff.array),"P(F-test)") } if(!is.null(var.labels)){ rownames(table0) <- var.labels }else{ rownames(table0) <- var.names[i] } rownames(table0) <- ifelse(rownames(table0) == "", var.names[i], rownames(table0)) if(length(grep(":", var.names[i]))==0) { if(length(table(variable))==2){ if(var.name.class=="factor"){ chosen.level <- var.name.levels[2] ref.level <- var.name.levels[1] rownames(table0) <- paste(rownames(table0),": ",chosen.level," vs ", ref.level, sep="") }else{ if((var.name.class=="numeric")| (var.name.class=="integer")){ if(names(table(variable))[1]=="0" & names(table(variable))[2]=="1"){ chosen.level <- "1" ref.level <- "0 " rownames(table0) <- paste(rownames(table0),": ",chosen.level," vs ", ref.level, sep="") }else{ rownames(table0) <- paste(rownames(table0),"(cont. var.)") } }else{ if(var.name.class=="logical"){rownames(table0) <- rownames(table0)} else{ rownames(table0) <- paste(rownames(table0),"(cont. var.)") }} } }else{ if((var.name.class=="numeric")| (var.name.class=="integer")){ rownames(table0) <- paste(rownames(table0),"(cont. var.)") } } }else{ rownames(table0) <- rownames(modified.coeff.array)[grep(":", rownames(modified.coeff.array))] } table1 <- rbind(table1, cbind(table0), cbind(blank.row,"")) }else{ # table0 with multiple rows if(any(class(model)=="glm") | any(class(model)=="coxph")){ if(any(model$family=="binomial") |any(model$family=="poisson") | any(class(model)=="coxph") | any(class(model)=="negbin")){ label.row <- cbind(label.row0, lr.p.value) colnames(label.row) <- c(colnames(modified.coeff.array),"P(LR-test)") } if(any(model$family=="gaussian")){ label.row <- cbind(label.row0, F.p.value[i]) colnames(label.row) <- c(colnames(modified.coeff.array),"P(F-test)") } }else{ label.row <- cbind(label.row0, F.p.value[i]) colnames(label.row) <- c(colnames(modified.coeff.array),"P(F-test)") } if(!is.null(var.labels)){ rownames(label.row) <- var.labels }else{ rownames(label.row) <- var.names[i] } rownames(label.row) <- ifelse(rownames(label.row) == "" | is.null(rownames(label.row)), var.names[i], rownames(label.row)) if(length(grep(":", var.names[i])) > 0){ rownames(label.row) <- var.names[i] } if(length(grep(":", var.names[i])) > 0){ first.var <- unlist(strsplit(var.names[i],":"))[1] second.var <- unlist(strsplit(var.names[i],":"))[2] splited.old.rownames <- unlist(strsplit(rownames(table0),":")) dim(splited.old.rownames) <- c(2, length(splited.old.rownames)/2) splited.old.rownames <- t(splited.old.rownames) new.rownames1 <- substr(splited.old.rownames[,1], nchar(first.var)+1, nchar(splited.old.rownames[,1]) ) new.rownames2 <- substr(splited.old.rownames[,2], nchar(second.var)+1, nchar(splited.old.rownames[,2])) rownames(table0) <- paste(new.rownames1,":",new.rownames2,sep="") if(any(class(model)=="lm")){ all.level1 <- unlist(model$xlevels[names(model$xlevels)==first.var]) all.level2 <- unlist(model$xlevels[names(model$xlevels)==second.var]) }else{ all.level1 <- levels(get(as.character(model$call)[3])[,first.var]) all.level2 <- levels(get(as.character(model$call)[3])[,second.var]) } non.interact <- rownames(modified.coeff.array)[-grep(":", rownames(modified.coeff.array))] non.interact1 <- non.interact[substr(non.interact, 1, nchar(first.var))== first.var] used.levels1 <- substr(non.interact1, nchar(first.var)+1, nchar(non.interact1)) ref.level1 <- setdiff(all.level1, used.levels1) non.interact2 <- non.interact[substr(non.interact, 1, nchar(second.var))== second.var] used.levels2 <- substr(non.interact2, nchar(second.var)+1 , nchar(non.interact2)) ref.level2 <- setdiff(all.level2, used.levels2) ref.level <- paste(ref.level1,":",ref.level2,sep="") }else{ rownames(table0) <- substr(rownames(table0), nchar(var.names[i])+1, nchar(rownames(table0))) if(any(class(model)=="lm")){ all.levels <- unlist(unlist(model$xlevels))[substr(names(unlist(model$xlevels)),1,nchar(var.names[i]))==var.names[i]] }else{ if(any(class(model)=="coxph")){ all.levels <-levels(get(as.character(model$call)[3])[,var.names[i]]) } } ref.level <- setdiff(all.levels, rownames(table0)) } rownames(label.row) <- paste(rownames(label.row), ": ref.=", ref.level, sep="") rownames(table0) <- paste(" ", rownames(table0)) table1 <- rbind(table1, label.row, cbind(table0, ""), cbind(blank.row,"")) } } table1 } #### Likelihood ratio test lrtest <- function (model1, model2) { if (any(class(model1) != class(model2))) { stop("Two models have different classes") } if (any(class(model1) == "coxph") & any(class(model2) == "coxph")) { if (model1$n != model2$n) { stop("Two models has different sample sizes") } cat("\n") df1 <- length(model1$coefficients) df2 <- length(model2$coefficients) lrt <- 2 * (model2$loglik[2] - model1$loglik[2]) diff.df <- df2 - df1 if (lrt < 0) { lrt <- -lrt diff.df <- -diff.df } if (lrt * diff.df < 0) { stop("Likelihood gets worse with more variables. Test not executed") } } if (any(class(model1) == "multinom") & any(class(model2) == "multinom")) { if (any(dim(model1$residuals) != dim(model2$residuals))) { stop("Two models have different outcomes or different sample sizes") } cat("\n") df1 <- model1$edf df2 <- model2$edf lrt <- model2$deviance - model1$deviance diff.df <- df1 - df2 if (lrt < 0) { lrt <- -lrt diff.df <- -diff.df } if (lrt * diff.df < 0) { stop("Likelihood gets worse with more variables. Test not executed") } } if (any(class(model1) == "polr") & any(class(model2) == "polr")) { if (model1$n != model2$n) { stop("Two models have different outcomes or different sample sizes") } cat("\n") df1 <- model1$edf df2 <- model2$edf lrt <- model2$deviance - model1$deviance diff.df <- df1 - df2 if (lrt < 0) { lrt <- -lrt diff.df <- -diff.df } if (lrt * diff.df < 0) { stop("Likelihood gets worse with more variables. Test not executed") } } if (suppressWarnings((all(class(model1) == c("glm", "lm")) & all(class(model2) == c("glm", "lm"))) | (any(class(model1) == "negbin") & any(class(model2) == "negbin")))) { if (sum(model1$df.null) != sum(model2$df.null)) stop("Number of observation not equal!!") df1 <- attributes(logLik(model1))$df df2 <- attributes(logLik(model2))$df lrt <- 2 * (as.numeric(logLik(model2) - logLik(model1))) diff.df <- df2 - df1 if (lrt < 0) { lrt <- -lrt diff.df <- -diff.df } if (lrt * diff.df < 0) { stop("Likelihood gets worse with more variables. Test not executed") } } output <- list(model1 = model1$call, model2 = model2$call, model.class =class(model1), Chisquared = lrt, df = diff.df, p.value = pchisq(lrt, diff.df, lower.tail = FALSE)) class(output) <- "lrtest" output } # print.lrtest print.lrtest <- function(x, ...) { if(any(x$model.class == "coxph")){ cat("Likelihood ratio test for Cox regression & conditional logistic regression", "\n") cat("Chi-squared", x$df, "d.f. = ", x$Chisquared, ",", "P value = ", x$p.value, "\n") cat("\n") } if(any(x$model.class == "multinom")){ cat("Likelihood ratio test for multinomial logistic regression", "\n") cat("Chi-squared", x$df, "d.f. = ", x$Chisquared, ",", "P value = ", x$p.value, "\n") cat("\n") } if(any(x$model.class == "polr")){ cat("Likelihood ratio test for ordinal regression", "\n") cat("Chi-squared", x$df, "d.f. = ", x$Chisquared, ",", "P value = ", x$p.value, "\n") cat("\n") } if (suppressWarnings((all(x$model.class == c("glm", "lm"))) | (any(x$model.class == "negbin")))){ cat("Likelihood ratio test for MLE method", "\n") cat("Chi-squared", x$df, "d.f. = ", x$Chisquared, ",", "P value = ", x$p.value, "\n") cat("\n") } } ### List objects excluding function lsNoFunction <- function() { setdiff(ls(envir= .GlobalEnv), as.character(lsf.str()[]) ) } ### Ordinal odds ratio display ordinal.or.display <- function(ordinal.model, decimal=3, alpha=.05){ model <- ordinal.model if(class(model) !="polr") stop("The model is not an ordinal logistic regression model") s1 <- summary(model) t <- s1$coefficients[,3] df <- s1$df.residual p.value <- pt(abs(t), df, lower.tail=FALSE) coeff <- t(t(model$coefficients)) coeff.95ci <- cbind(coeff, confint(model, level=1-alpha)) oor.95ci <- round(exp(coeff.95ci),decimal) len.p <- length(p.value) oor.95ci <- cbind(oor.95ci, format(p.value[-(len.p:(len.p-1))],digits=decimal)) colnames(oor.95ci) <- c("Ordinal OR", paste("lower",100-100*alpha,"ci",sep=""), paste("upper",100-100*alpha,"ci",sep=""),"P value") print.noquote(oor.95ci) } ### Summarize continous variable in the loaded data set summ <- function (x = .data, by = NULL, graph = TRUE, box = FALSE, pch = 18, ylab = "auto", main = "auto", cex.X.axis = 1, cex.Y.axis = 1, dot.col = "auto", ...) { if (!is.null(by)) { if (length(dot.col) > 1 & length(table(factor(by))) != length(dot.col)) { stop(paste("The argument 'dot.col' must either be \"auto\"", "\n", " or number of colours equals to number of categories of 'by'.")) } } else { if (dot.col == "auto") dot.col <- "blue" } if (all(is.na(x))) { stop("All elements of ", substitute(x), " have a missing value") } if (!is.atomic(x)) { graph = FALSE } if (typeof(x) == "character") { stop(paste(deparse(substitute(x)), "is a character vector")) } if (graph) { var1 <- deparse(substitute(x)) if (length(var1) > 1) { string2 <- var1[length(var1)] } else if (substring(search()[2], first = 1, last = 8) != "package:") { string2 <- attr(get(search()[2]), "var.labels")[attr(get(search()[2]), "names") == deparse(substitute(x))] if (length(string2) == 0) { string2 <- deparse(substitute(x)) } if (string2 == "") { string2 <- deparse(substitute(x)) } } else { string2 <- deparse(substitute(x)) } string3 <- paste(titleString()$distribution.of, string2) if (substring(search()[2], first = 1, last = 8) != "package:") { string4 <- attr(get(search()[2]), "var.labels")[attr(get(search()[2]), "names") == deparse(substitute(by))] if (length(string4) == 0) { string4 <- deparse(substitute(by)) } else { if (string4 == "") { string4 <- deparse(substitute(by)) } } } else { string4 <- deparse(substitute(by)) } string5 <- paste(string3, titleString()$by, string4) if (nchar(string5) > 45) { string5 <- paste(string3, "\n", titleString()$by, string4) } if (any(class(x) == "Date")) { range.date <- difftime(summary(x)[6], summary(x)[1]) numdate <- as.numeric(range.date) if (numdate < 1) { date.pretty <- seq(from = summary(x)[1] - 1, to = summary(x)[6] + 1, by = "day") format.time <- "%a%d%b" } if (numdate >= 1 & numdate < 10) { date.pretty <- seq(from = summary(x)[1], to = summary(x)[6], by = "day") format.time <- "%a%d%b" } if (numdate >= 10 & numdate < 60) { date.pretty <- seq(from = summary(x)[1], to = summary(x)[6], by = "week") format.time <- "%d%b" } if (numdate >= 60 & numdate < 700) { date.pretty <- seq(from = (summary(x)[1] - as.numeric(substr(as.character(summary(x)[1]), 9, 10)) + 1), to = summary(x)[6], by = "month") format.time <- "%b%y" } } if (any(class(x) == "POSIXt")) { range.time <- difftime(summary(x)[6], summary(x)[1]) numeric.time <- as.numeric(range.time) units <- attr(range.time, "units") if (units == "secs") { step <- "sec" format.time <- "%M:%S" scale.unit <- "min:sec" } if (units == "mins") { step <- "min" format.time <- "%H:%M" scale.unit <- "HH:MM" } if (units == "hours") { step <- ifelse(numeric.time < 2, "20 mins", "hour") format.time <- "%H:%M" scale.unit <- "HH:MM" } if (units == "days") { if (numeric.time < 2) { step <- "6 hour" format.time <- "%a %H:%M" scale.unit <- "HH:MM" } else { step <- "day" format.time <- "%d%b%y" scale.unit <- "Date" } } if (units == "weeks") { step <- "week" format.time <- "%b%y" scale.unit <- " " } time.pretty <- seq(from = summary(x)[1], to = summary(x)[6], by = step) } if (!is.null(by)) { x1 <- x[order(by, as.numeric(x))] by1 <- by[order(by, as.numeric(x))] by2 <- factor(by1, exclude = NULL) character.length <- ifelse(max(nchar(levels(by2))) > 8, max(nchar(levels(by2))) * (60 - max(nchar(levels(by2))))/60, max(nchar(levels(by2))) * 1.2) left.offset <- max(c(0.76875 + 0.2, 0.1 + par()$cin[1] * character.length)) par(mai = c(0.95625, left.offset, 0.76875, 0.39375)) by3 <- as.numeric(by2) if (any(dot.col == "auto")) { dot.col1 <- as.numeric(by2) } else { tx <- cbind(1:length(dot.col), dot.col) dot.col1 <- lookup(as.numeric(by2), tx) } if (any(dot.col == "auto")) { col1 <- by3 } else { col1 <- dot.col1 } y0 <- 1:length(x1) y <- suppressWarnings(y0 + as.numeric(by2) - 1) if (is.factor(x)) { plot(as.numeric(x1), y, pch = pch, col = col1, main = ifelse(main == "auto", string5, main), ylim = c(-1, max(y)), xlab = " ", ylab = ifelse(ylab == "auto", " ", ylab), yaxt = "n", xaxt = "n", ...) axis(1, at = 1:length(levels(x1)), labels = levels(x1), cex.axis = cex.X.axis) } else if (any(class(x) == "POSIXt")) { plot(x1, y, pch = pch, col = col1, main = ifelse(main == "auto", string5, main), ylim = c(-1, max(y)), xlab = " ", ylab = ifelse(ylab == "auto", " ", ylab), yaxt = "n", xaxt = "n", ...) axis(1, at = time.pretty, labels = as.character(time.pretty, format = format.time), cex.axis = cex.X.axis) } else if (any(class(x) == "Date")) { if (numdate < 700) { plot(x1, y, pch = pch, col = col1, main = ifelse(main == "auto", string5, main), ylim = c(-1, max(y)), xlab = " ", ylab = ifelse(ylab == "auto", " ", ylab), yaxt = "n", xaxt = "n", ...) axis(1, at = date.pretty, labels = as.character(date.pretty, format = format.time), cex.axis = cex.X.axis) } else { plot(x1, y, pch = pch, col = col1, main = ifelse(main == "auto", string5, main), ylim = c(-1, (summary(y))[6]), xlab = " ", ylab = ifelse(ylab == "auto", " ", ylab), yaxt = "n", cex.axis = cex.X.axis, ...) } } else { plot(x1, y, pch = pch, col = col1, main = ifelse(main == "auto", string5, main), ylim = c(-1, max(y)), xlab = " ", ylab = ifelse(ylab == "auto", " ", ylab), yaxt = "n", cex.axis = cex.X.axis, ...) if (any(class(x) == "difftime")) { unit <- attr(x, "unit") } else { unit <- " " } title(xlab = unit) } if (length(x1) < 20) { abline(h = y, lty = 3) } yline <- NULL if (any(is.na(levels(by2)))) { levels(by2)[length(levels(by2))] <- "missing" } for (i in 1:length(levels(by2))) { yline <- c(yline, sum(as.numeric(by2) == i)) } yline <- c(0, cumsum(yline)[1:(length(yline) - 1)]) + (0:(length(yline) - 1)) abline(h = yline, col = "blue") axis(2, at = yline, labels = levels(by2), padj = 0, las = 1, cex.axis = cex.Y.axis) par(mai = c(0.95625, 0.76875, 0.76875, 0.39375)) } else { x1 <- x[order(x)] y <- 1:length(x1) if (is.factor(x1)) { plot(as.numeric(x1), y, pch = pch, col = ifelse(dot.col == "auto", "blue", dot.col), main = ifelse(main == "auto", string3, main), xlab = " ", ylab = ifelse(ylab == "auto", .ylab.for.summ, ylab), xaxt = "n", cex.axis = cex.Y.axis, ...) axis(1, at = 1:length(levels(x1)), labels = levels(x1), cex.axis = cex.X.axis) } else if (any(class(x) == "POSIXt")) { plot(x1, y, pch = pch, col = ifelse(dot.col == "auto", "blue", dot.col), main = ifelse(main == "auto", string3, main), xlab = " ", ylab = ifelse(ylab == "auto", .ylab.for.summ, ylab), xaxt = "n", cex.axis = cex.Y.axis, ...) axis(1, at = time.pretty, labels = as.character(time.pretty, format = format.time), cex.axis = cex.X.axis) } else if (any(class(x) == "Date")) { if (numdate < 700) { plot(x1, y, pch = pch, col = ifelse(dot.col == "auto", "blue", dot.col), main = ifelse(main == "auto", string3, main), xlab = " ", ylab = ifelse(ylab == "auto", .ylab.for.summ, ylab), yaxt = "n", xaxt = "n", ...) axis(1, at = date.pretty, labels = as.character(date.pretty, format = format.time), cex.axis = cex.X.axis) } else { plot(x1, y, pch = pch, col = ifelse(dot.col == "auto", "blue", dot.col), main = ifelse(main == "auto", string3, main), xlab = " ", ylab = ifelse(ylab == "auto", .ylab.for.summ, ylab), yaxt = "n", cex.axis = cex.X.axis, ...) } } else { plot(x1, y, pch = pch, col = ifelse(dot.col == "auto", "blue", dot.col), main = ifelse(main == "auto", string3, main), xlab = " ", ylab = ifelse(ylab == "auto", .ylab.for.summ, ylab), yaxt = "n", cex.axis = cex.X.axis, ...) if (any(class(x) == "difftime")) { unit <- attr(x, "unit") } else { unit <- " " } title(xlab = unit) } if (length(x1) < 30) { abline(h = y, lty = 3) } if (box == TRUE) { boxplot(unclass(x1), add = TRUE, horizontal = TRUE, axes = FALSE, at = 0.8 * length(sort(x1)), boxwex = 0.2 * length(sort(x1))) } } } if (is.numeric(x) | is.integer(x)) { attributes(x) <- NULL } if (is.data.frame(x)) { heading <- paste(attr(x, "datalabel"), "\n", .No.of.observations, nrow(x), "\n", "\n", sep = "") } if (is.vector(x) | is.vector(unclass(x)) | (is.factor(x)) | any(class(x) == "POSIXt" | class(x) == "difftime")) { if (typeof(x) == "character") { stop(paste(deparse(substitute(x)), "is a character vector")) } if (is.factor(x)) { x <- na.omit(as.numeric(x)) } if (!is.null(by)) { by1 <- factor(by, exclude = NULL) if (any(is.na(levels(by1)))) { levels(by1)[length(levels(by1))] <- "missing" } lev <- levels(by1) multiple.a <- NULL for (i in 1:length(lev)) { x1 <- subset(x, by1 == lev[i]) if (any(class(x1) == "POSIXt")) { a <- format((summary(x1))[c(1, 3, 4, 6)], "%Y-%m-%d %H:%M") } else { a <- rep("", 6) dim(a) <- c(1, 6) if (any(class(x1) == "Date")) { a[1, ] <- c(length(x1), format(c(summary(x1)[4], summary(x1)[3], NA, summary(x1)[1], summary(x1)[6]), "%Y-%m-%d")) } else if (any(class(x) == "logical")) { a[1, ] <- round(c(length(na.omit(x1)), mean(na.omit(x1)), quantile(na.omit(x1), 0.5), ifelse(is.na(mean(na.omit(x1))), NA, round(sd(na.omit(x1)), 2)), min(na.omit(x1)), max(na.omit(x1))), 3) } else if (any(class(x) == "difftime")) { a[1, ] <- round(c(length(na.omit(x1)), mean(na.omit(as.numeric(x1))), quantile(na.omit(as.numeric(x1)), 0.5), ifelse(is.na(mean(na.omit(as.numeric(x1)))), NA, round(sd(na.omit(as.numeric(x1))), 2)), min(na.omit(as.numeric(x1))), max(na.omit(as.numeric(x1)))), 3) } else { a[1, ] <- round(c(length(na.omit(x1)), summary(x1)[4], summary(x1)[3], ifelse(is.na(mean(na.omit(x1))), NA, sd(na.omit(x1))), summary(x1)[1], summary(x1)[6]), 3) } colnames(a) <- c(.obs, .mean, .median, .sd, .min, .max) rownames(a) <- " " } multiple.a <- rbind(multiple.a, a) row.names(multiple.a) <- rep("", nrow(multiple.a)) } } else { if (any(class(x) == "POSIXt")) { a <- (format((summary(x))[c(1, 3, 4, 6)], "%Y-%m-%d %H:%M")) } else { a <- rep("", 6) dim(a) <- c(1, 6) if (any(class(x) == "Date")) { a[1, ] <- c(length(na.omit(x)), format(c(summary(x)[4], summary(x)[3], NA, summary(x)[1], summary(x)[6]), "%Y-%m-%d")) } else if (any(class(x) == "difftime")) { a[1, ] <- c(length(na.omit(x)), summary(as.numeric(x))[4], summary(as.numeric(x))[3], ifelse(is.na(mean(na.omit(x1))), NA, round(sd(na.omit(x1)), 2)), summary(as.numeric(x))[1], summary(as.numeric(x))[6]) } else { a[1, ] <- round(c(length(na.omit(x)), mean(na.omit(x)), quantile(na.omit(x), 0.5), ifelse(is.na(mean(na.omit(x))), NA, round(sd(na.omit(x)), 2)), min(na.omit(x)), max(na.omit(x))), 3) } colnames(a) <- c(.obs, .mean, .median, .sd, .min, .max) rownames(a) <- " " } } } else if (is.recursive(x) && length(x) == 1) { a <- summary(x) } else if (!is.recursive(x) && !is.vector(x) && !is.factor(x)) a <- summary(x) else { a <- rep("", (dim(x)[2]) * 7) dim(a) <- c(dim(x)[2], 7) colnames(a) <- c(.var.name, .obs, .mean, .median, .sd, .min, .max) a[, 1] <- attr(x, "names") rownames(a) <- 1:nrow(a) for (i in 1:(dim(x)[2])) { if ((typeof(x[i][1, ]) == "character") || is.na(mean(na.omit(as.numeric(x[[i]]))))) { a[i, 3:7] <- "" } else { if (any(class(x[[i]]) == "Date")) { a[i, c(3, 4, 6, 7)] <- format(c(summary(x[[i]])[4], summary(x[[i]])[3], summary(x[[i]])[1], summary(x[[i]])[6]), "%Y-%m-%d") a[i, 5] <- NA a[i, 2] <- length((x[[i]])[!is.na(x[[i]])]) } else if (any(class(x[[i]]) == "POSIXt")) { a[i, c(3, 4, 6, 7)] <- format(c(summary(x[[i]])[4], summary(x[[i]])[3], summary(x[[i]])[1], summary(x[[i]])[6]), "%Y-%m-%d %H:%M") a[i, 5] <- NA a[i, 2] <- length((x[[i]])[!is.na(x[[i]])]) } else if (any(class(x[[i]]) == "difftime")) { a[i, c(3, 4, 6, 7)] <- c(summary(as.numeric(x[[i]]))[c(4, 3, 1, 6)]) a[i, 5] <- round(sd(x[[i]], na.rm = TRUE), 2) a[i, 2] <- length((x[[i]])[!is.na(x[[i]])]) } else if (suppressWarnings(is.integer(x[[i]]) || is.numeric(x[[i]]) | (is.logical(x[[i]]) & !is.na(mean(na.omit(as.numeric(x[[i]]))))))) { a[i, 3:7] <- round(c(mean(na.omit(x[[i]])), quantile(na.omit(x[[i]]), 0.5), sd(na.omit(x[[i]])), min(na.omit(x[[i]])), max(na.omit(x[[i]]))), 2) a[i, 2] <- as.character(length(na.omit(as.numeric(x[[i]])))) } else if (is.null(class(x[[i]]))) { a[i, 3:7] <- round(c(mean(na.omit(as.numeric(x[[i]]))), quantile(na.omit(as.numeric(x[[i]])), 0.5), sd(na.omit(as.numeric(x[[i]]))), min(na.omit(as.numeric(x[[i]]))), max(na.omit(as.numeric(x[[i]])))), 2) a[i, 2] <- as.character(length(na.omit(x[[i]]))) } else if (is.factor(x[i][2, ])) { a[i, 2] <- as.character(length(na.omit(x[[i]]))) a[i, 3:7] <- round(c(mean(na.omit(unclass(x[i][, ]))), median(na.omit(unclass(x[i][, ]))), sd(na.omit(unclass(x[i][, ]))), min(na.omit(unclass(x[i][, ]))), max(na.omit(unclass(x[i][, ])))), 3) } } } } if (is.data.frame(x)) { results <- list(heading = heading, table = a) class(results) <- c("summ", "table") results } else { if (is.null(by)) { if (class(a) == "matrix") { results <- list(table = a) class(results) <- c("summ", "matrix") results } else { results <- list(object = a) class(results) <- c("summ", class(a)) results } } else { results <- list(byname = deparse(substitute(by)), levels = levels(factor(by)), table = multiple.a) class(results) <- c("summ", "list") results } } } #### Print summ result print.summ <- function(x, ...) { if(any(class(x)=="table")){ cat("\n") cat(x$heading) print.noquote(x$table) cat("\n") }else{ if(any(class(x)=="list")){ for(i in 1:length(x$levels)) { cat(paste("For",x$byname,"=",x$levels[i]),"\n") print.noquote(x$table[i,,drop=FALSE]) cat("\n") } }else{ if(any(class(x)=="matrix")){ print.noquote(x$table) }else{ print(x$object) }}}} #### ROC curve from Logistic Regression lroc <- function (logistic.model, graph = TRUE, add = FALSE, title = FALSE, line.col = "red", auc.coords = NULL, grid = TRUE, grid.col = "blue", ...) { if (add) { title <- FALSE } if (length(grep("cbind", names(model.frame(logistic.model)))) > 0) { firsttable1 <- cbind(logistic.model$fitted.values, model.frame(logistic.model)[, 1][, 2:1]) firsttable1 <- firsttable1[order(firsttable1[, 1]), ] } else { if (length(grep("(weights)", names(model.frame(logistic.model)))) > 0) { firsttable <- xtabs(as.vector(model.frame(logistic.model)[, ncol(model.frame(logistic.model))]) ~ logistic.model$fitted.values + logistic.model$y) } else { firsttable <- table(logistic.model$fitted.values, logistic.model$y) } colnames(firsttable) <- c("Non-diseased", "Diseased") rownames(firsttable) <- substr(rownames(firsttable), 1, 6) firsttable1 <- cbind(as.numeric(rownames(firsttable)), firsttable) } rownames(firsttable1) <- rep("", nrow(firsttable1)) colnames(firsttable1)[1] <- "predicted.prob" firsttable <- firsttable1[, 2:3] secondtable <- firsttable for (i in 1:length(secondtable[, 1])) { secondtable[i, 1] <- (sum(firsttable[, 1]) - sum(firsttable[(1:i), 1]))/sum(firsttable[, 1]) secondtable[i, 2] <- (sum(firsttable[, 2]) - sum(firsttable[(1:i), 2]))/sum(firsttable[, 2]) rownames(secondtable)[i] <- paste(">", rownames(secondtable)[i]) } secondtable <- rbind((c(1, 1)), secondtable) colnames(secondtable) <- c("1-Specificity", "Sensitivity") model.des <- deparse(logistic.model$formula) auc <- 0 for (i in 1:(nrow(secondtable) - 1)) { auc <- auc + (secondtable[i, 1] - secondtable[(i + 1), 1]) * 0.5 * (secondtable[i, 2] + secondtable[(i + 1), 2]) } if (graph) { if (!add) { plot(secondtable[, 1], secondtable[, 2], xlab = "1-Specificity", ylab = "Sensitivity", xlim = (c(0, 1)), ylim = (c(0, 1)), asp = 1, col = line.col, type = "l", ...) if (title) { title(main = model.des, ...) } lines(x = c(0, 1), y = c(0, 1), lty = 2, col = "blue") if(grid){ abline(v = 0, lty = 2, col = grid.col) abline(v = 0.2, lty = 2, col = grid.col) abline(v = 0.4, lty = 2, col = grid.col) abline(v = 0.6, lty = 2, col = grid.col) abline(v = 0.8, lty = 2, col = grid.col) abline(v = 1, lty = 2, col = grid.col) abline(h = 0, lty = 2, col = grid.col) abline(h = 0.2, lty = 2, col = grid.col) abline(h = 0.4, lty = 2, col = grid.col) abline(h = 0.6, lty = 2, col = grid.col) abline(h = 0.8, lty = 2, col = grid.col) abline(h = 1, lty = 2, col = grid.col) } auclabel <- paste("Area under the curve =", round(auc, 3)) if (!is.null(auc.coords)) { text(x = auc.coords[1], y = auc.coords[2], pos = 4, labels = auclabel, ...) } } else { lines(secondtable[, 1], secondtable[, 2], col = line.col, ...) } } list(model.description = model.des, auc = auc, predicted.table = firsttable1, diagnostic.table = secondtable) } ### ROC curve from a table roc.from.table <- function (table, graph = TRUE, add = FALSE, title = FALSE, line.col = "red", auc.coords = NULL, grid = TRUE, grid.col = "blue", ...) { if (dim(table)[2] != 2) stop("There must be 2 columns") if (table[1, 1]/table[1, 2] < table[nrow(table), 1]/table[nrow(table), 2]) { stop("At higher cut-off point, there should be more non-diseased") } firsttable <- table colnames(firsttable) <- c("Non-diseased", "Diseased") if (length(rownames(firsttable)) == 0) { rownames(firsttable) <- rep("", times = nrow(firsttable)) } secondtable <- firsttable for (i in 1:length(secondtable[, 1])) { secondtable[i, 1] <- (sum(firsttable[, 1]) - sum(firsttable[(1:i), 1]))/sum(firsttable[, 1]) secondtable[i, 2] <- (sum(firsttable[, 2]) - sum(firsttable[(1:i), 2]))/sum(firsttable[, 2]) rownames(secondtable)[i] <- paste(">", rownames(secondtable)[i]) } secondtable <- rbind((c(1, 1)), secondtable) colnames(secondtable) <- c("1-Specificity", "Sensitivity") auc <- 0 for (i in 1:(nrow(secondtable) - 1)) { auc <- auc + (secondtable[i, 1] - secondtable[(i + 1), 1]) * 0.5 * (secondtable[i, 2] + secondtable[(i + 1), 2]) } if (graph) { if (!add) { plot(secondtable[, 1], secondtable[, 2], xlab = "1-Specificity", ylab = "Sensitivity", xlim = (c(0, 1)), ylim = (c(0, 1)), asp = 1, col = line.col, type = "l", ...) if (title) { title(main = "ROC curve of the diagnostic table", ...) } lines(x = c(0, 1), y = c(0, 1), lty = 2, col = "blue") if(grid) { abline(v = 0, lty = 2, col = grid.col) abline(v = 0.2, lty = 2, col = grid.col) abline(v = 0.4, lty = 2, col = grid.col) abline(v = 0.6, lty = 2, col = grid.col) abline(v = 0.8, lty = 2, col = grid.col) abline(v = 1, lty = 2, col = grid.col) abline(h = 0, lty = 2, col = grid.col) abline(h = 0.2, lty = 2, col = grid.col) abline(h = 0.4, lty = 2, col = grid.col) abline(h = 0.6, lty = 2, col = grid.col) abline(h = 0.8, lty = 2, col = grid.col) abline(h = 1, lty = 2, col = grid.col) } auclabel <- paste("Area under the curve =", round(auc, 3)) } else { lines(secondtable[, 1], secondtable[, 2], col = line.col, ...) } if (!is.null(auc.coords)) { text(x = auc.coords[1], y = auc.coords[2], pos = 4, labels = auclabel, ...) } } list(auc = auc, original.table = firsttable, diagnostic.table = secondtable) } ### Kappa statistics kap <- function(x,...){ UseMethod("kap") } kap.default <- function(x, ...){ if (is.table(x)){ kap.table(x, decimal=3,...) } } ### Kappa statistics from a table cross-tab ratings of 2 raters kap.table <- function (x, decimal =3, wttable = c(NULL, "w", "w2"), print.wttable = FALSE, ...) { kaptable <- x if (ncol(kaptable) != nrow(kaptable)) stop("Column & row not equal length") if (is.null(wttable) | (is.character(wttable) & length(wttable) == 2)) { wttable <- kaptable wttable[] <- 0 for (i in 1:nrow(kaptable)) wttable[i, i] <- 1 } else { if (!is.matrix(wttable)) { if (wttable == "w" | wttable == "w2") { wttable1 <- kaptable wttable1[] <- 0 for (i in 1:nrow(kaptable)) { for (j in 1:ncol(kaptable)) { if (wttable == "w") { wttable1[i, j] <- 1 - abs(i - j)/(ncol(kaptable) - 1) } if (wttable == "w2") { wttable1[i, j] <- 1 - (abs(i - j)/(ncol(kaptable) - 1))^2 } } } wttable <- wttable1 } } } po <- 0 pe <- 0 exptable <- kaptable bigbracket <- 0 wbari <- rep(0, ncol(kaptable)) wbarj <- rep(0, nrow(kaptable)) for (i in 1:nrow(kaptable)) { for (j in 1:ncol(kaptable)) { wbari[i] <- wbari[i] + wttable[i, j] * sum(kaptable[, j])/sum(kaptable) } } for (j in 1:ncol(kaptable)) { for (i in 1:nrow(kaptable)) { wbarj[j] <- wbarj[j] + wttable[i, j] * sum(kaptable[i, ])/sum(kaptable) } } for (i in 1:nrow(kaptable)) { for (j in 1:ncol(kaptable)) { po <- po + wttable[i, j] * kaptable[i, j]/sum(kaptable) exptable[i, j] <- sum(kaptable[i, ]) * sum(kaptable[, j])/sum(kaptable)/sum(kaptable) pe <- pe + wttable[i, j] * exptable[i, j] bigbracket <- bigbracket + exptable[i, j] * (wttable[i, j] - (wbari[i] + wbarj[j]))^2 } } kap <- (po - pe)/(1 - pe) if (length(colnames(kaptable)) == 0) { rownames(kaptable) <- paste("Group", as.character(1:nrow(kaptable)), sep = "") colnames(kaptable) <- rownames(kaptable) attr(attr(kaptable, "dimnames"), "names") <- c("Rater A", "Rater B") } sekap <- 1/(1 - pe)/sqrt(sum(kaptable)) * sqrt(bigbracket - pe^2) z <- kap/sekap p.value <- pnorm(z, lower.tail = FALSE) results <- list(table = kaptable, wttable = wttable, print.wttable = print.wttable, decimal = decimal, po = po, pe = pe, kappa = kap, std.error = sekap, z = z, p.value = p.value) class(results) <- "kap.table" results } ### Print kap.table print.kap.table <- function(x, ...) { cat("\n","Table for calculation of kappa"); cat("\n") print(x$table) if(x$print.wttable & nrow(x$table)>2){ cat("\n") cat("Weighting scheme", "\n") print(x$wttable) } cat("\n") cat("Observed agreement =", round(x$po * 100, x$decimal-1), "%", "\n") cat("Expected agreement =", round(x$pe * 100, x$decimal-1), "%", "\n") cat("Kappa =", round(x$kap, x$decimal), "\n") cat("Standard error =", round(x$std.error, x$decimal), ", Z =", round(x$z, x$decimal), ", P value =", ifelse(x$p.value <0.001, "< 0.001",round(x$p.value, x$decimal)), "\n", "\n") } ## Kappa statistics with two raters kap.2.raters <- function (x, rater2, decimal =3, ...) { rater1 <- x kaptable <- table(rater1, rater2) if (any(rownames(kaptable) != colnames(kaptable))) { stop("Table to use for kappa calculation must be symmetrical") } kap.table(kaptable, decimal=decimal) } ## Kappa statistics with more than two raters kap.m.raters <- function (x, decimal =3, ...) { category.levels <- NULL for (i in 1:ncol(x)) { category.levels <- c(category.levels, names(table(x[, i]))) } category.levels <- unique(category.levels) category.counts <- rep(0, times = nrow(x) * length(category.levels)) dim(category.counts) <- c(nrow(x), length(category.levels)) for (j in 1:length(category.levels)) { if (is.factor(x[, 1])) { for (i in 1:nrow(x)) { category.counts[i, j] <- sum(x[i, ][!is.na(x[i, ])] == category.levels[j]) } } else { for (i in 1:nrow(x)) { category.counts[i, j] <- sum(x[i, ][!is.na(x[i, ])] == as.numeric(category.levels[j])) } } colnames(category.counts) <- category.levels } kap.ByCategory( as.data.frame(category.counts), decimal=decimal) } ## Kappa statistics with id of the ratee and counts of rated categories kap.ByCategory <- function (x, decimal =3, ...) { n <- nrow(x) mi <- rowSums(x) mbar <- sum(mi/n) pbar <- NULL qbar <- NULL kapp <- NULL z <- NULL sekap <- NULL p.value <- NULL for (j in 1:ncol(x)) { xi <- x[, j] last.pbar <- sum(xi/(n * mbar)) pbar <- c(pbar, last.pbar) last.qbar <- 1 - last.pbar qbar <- c(qbar, last.qbar) B <- 1/n * sum((xi - mi * last.pbar)^2/mi) W <- 1/(n * (mbar - 1)) * sum(xi * (mi - xi)/mi) mbarH <- 1/(mean(1/mi)) kapp <- c(kapp, (B - W)/(B + (mbar - 1) * W)) if (ncol(x) == 2 | var(mi) == 0) { last.sekap <- 1/((mbar - 1) * sqrt(n * mbarH)) * sqrt(2 * (mbarH - 1) + (mbar - mbarH) * (1 - 4 * last.pbar * last.qbar)/(mbar * last.pbar * last.qbar)) sekap <- c(sekap, last.sekap) last.z <- (B - W)/(B + (mbar - 1) * W)/last.sekap z <- c(z, last.z) last.p.value <- pnorm(last.z, lower.tail = FALSE) p.value <- c(p.value, last.p.value) } } if (ncol(x) == 2) { results <- list(Each.category=NULL, Overall = data.frame(kappa = kapp[1], std.error = last.sekap, z = last.z, p.value = last.p.value, row.names = ""), decimal = decimal) } else { if (var(mi) == 0) { each.category <- data.frame(kappa = kapp, std.error = sekap, z = z, p.value = p.value, row.names = colnames(x)) } else { each.category <- data.frame(kappa = kapp, std.error = ".", z = ".", p.value = ".", row.names = colnames(x)) } kapp.bar <- sum(pbar * qbar * kapp)/sum(pbar * qbar) if (ncol(x) == 2 | var(mi) == 0) { m <- mi[1] sekap.bar <- sqrt(2)/(sum(pbar * qbar) * sqrt(n * m * (m - 1))) * sqrt((sum(pbar * qbar))^2 - sum(pbar * qbar * (qbar - pbar))) z.bar <- kapp.bar/sekap.bar p.value.bar <- pnorm(z.bar, lower.tail = FALSE) row.names.overall <- "" for (i in 1:max(nchar(colnames(x)))) { row.names.overall <- paste(row.names.overall, " ", sep = "") } Overall <- data.frame(kappa = kapp.bar, std.error = sekap.bar, z = z.bar, p.value = p.value.bar, row.names = row.names.overall) list(Each.category = each.category, Overall = Overall) } else { row.names.overall <- "" for (i in 1:max(nchar(colnames(x)))) { row.names.overall <- paste(row.names.overall, " ", sep = "") } Overall <- data.frame(kappa = kapp.bar, std.error = ".", z = ".", p.value = ".", row.names = row.names.overall) } results <- list(Each.category = each.category, Overall = Overall, decimal = decimal) } class(results) <- "kap.ByCategory" results } ## Print kap.ByCategory print.kap.ByCategory <- function(x, ...) { if(!is.null(x$Each.category)){ cat("Each category:", "\n") dataA <- x$Each.category if(class(dataA$std.error)!="numeric"){ print(data.frame(kappa=round(dataA$kappa,x$decimal), std.error=".", z = ".", p.value = ".", row.names=row.names(dataA))) }else{ print(data.frame(kappa=round(dataA$kappa,x$decimal), std.error=round(dataA$std.error, x$decimal), z = round(dataA$z, x$decimal-1), p.value = ifelse(dataA$p.value < 0.001,"< 0.001", round(dataA$p.value, x$decimal)), row.names=row.names(dataA))) } cat("\n") cat("Overall:", "\n") dataB <- x$Overall if(class(dataA$std.error)!="numeric"){ print(data.frame(kappa=round(dataB$kappa, x$decimal), std.error=".", z = ".", p.value = ".", row.names=paste(rep(" ",max(nchar(row.names(dataB)))),collapse=""))) }else{ print(data.frame(kappa=round(dataB$kappa, x$decimal), std.error=round(dataB$std.error, x$decima), z = round(dataB$z, x$decimal-1), p.value = ifelse(dataB$p.value < 0.001,"< 0.001", round(dataB$p.value, x$decimal)), row.names=paste(rep(" ",max(nchar(row.names(dataB)))),collapse=""))) } }else{ dataC <- x$Overall print(data.frame(kappa=round(dataC$kappa, x$decimal), std.error=round(dataC$std.error, x$decima), z = round(dataC$z, x$decimal-1), p.value = ifelse(dataC$p.value < 0.001,"< 0.001", round(dataC$p.value, x$decimal)), row.names=" ")) } } ### Make 2 x 2 table make2x2 <- function (caseexp, controlex, casenonex, controlnonex) { table1 <- c(controlnonex, casenonex, controlex, caseexp) dim(table1) <- c(2, 2) rownames(table1) <- c("Non-diseased", "Diseased") colnames(table1) <- c("Non-exposed", "Exposed") attr(attr(table1, "dimnames"), "names") <- c("Outcome", "Exposure") table1 } ### Sample size calculation n.for.2p <- function (p1, p2, alpha=0.05, power=.8, ratio=1) { if (any(p1 <1) & any(p2 <1)) { r1 <- ratio +1 pbar <- (p1+ratio*p2)/r1 sqrt1 <- sqrt(r1 * pbar * (1-pbar)) sqrt2 <- sqrt(ratio * (p1 * (1-p1))+ p2*(1-p2) ) n0 <- (((qnorm(1-alpha/2)*sqrt1) - (qnorm(1-power)*sqrt2))^2)/ (ratio*((p2-p1)^2)) n1 <- (n0/4)* (1+sqrt(1+2*r1/(n0*ratio*abs(p1-p2))))^2 n1 <- trunc(n1) +1 n2 <- trunc(ratio * n1) }else{ stop("Both p1 and p2 must be less than 1") } if(length(alpha) > 1 ) {alpha1 <- alpha }else {alpha1 <- NULL} if(length(power) > 1 ) {power1 <- power }else {power1 <- NULL} if(length(ratio) > 1 ) {ratio1 <- ratio }else {ratio1 <- NULL} table1 <- cbind(p1, p2, n1, n2, alpha1, power1, ratio1) colnames(table1)[colnames(table1)=="alpha1"] <- "alpha" colnames(table1)[colnames(table1)=="power1"] <- "power" colnames(table1)[colnames(table1)=="ratio1"] <- "n2/n1" returns <- list(p1=p1, p2=p2, n1=n1, n2=n2, alpha=alpha, power=power, ratio=ratio, table = as.data.frame(table1)) class(returns) <- c("n.for.2p", "list") returns } ### print n.for.2p print.n.for.2p <- function(x, ...){ if(nrow(x$table) < 6){ cat("\n") cat("Estimation of sample size for testing Ho: p1==p2", "\n") cat("Assumptions:", "\n", "\n") cat(" alpha =", x$alpha, "\n") cat(" power =", x$power, "\n") cat(" p1 =", x$p1, "\n") cat(" p2 =", x$p2, "\n") cat(" n2/n1 =", x$ratio, "\n", "\n") cat("Estimated required sample size:", "\n", "\n") cat(" n1 =",x$n1,"\n") cat(" n2 =",x$n2,"\n") cat(" n1 + n2 =",x$n1+x$n2,"\n","\n") }else{ cat("Assumptions:", "\n", "\n") if(length(x$alpha)==1) cat(" alpha =", x$alpha, "\n") if(length(x$power)==1) cat(" power =", x$power, "\n") if(length(x$ratio)==1) cat(" n2/n1 =", x$ratio, "\n") cat("\n") print(x$table) }} ### n for Cluster RCT n.for.cluster.2p <- function (p1, p2, alpha = 0.05, power = 0.8, ratio = 1, mean.cluster.size = 10, previous.mean.cluster.size = NULL, previous.sd.cluster.size = NULL, max.cluster.size = NULL, min.cluster.size = NULL, icc = 0.1) { if (any(p1 < 1) & any(p2 < 1)) { r1 <- ratio + 1 pbar <- (p1 + ratio * p2)/r1 sqrt1 <- sqrt(r1 * pbar * (1 - pbar)) sqrt2 <- sqrt(ratio * (p1 * (1 - p1)) + p2 * (1 - p2)) n0 <- (((qnorm(1 - alpha/2) * sqrt1) - (qnorm(1 - power) * sqrt2))^2)/(ratio * ((p2 - p1)^2)) n1 <- (n0/4) * (1 + sqrt(1 + 2 * r1/(n0 * ratio * abs(p1 - p2))))^2 n1 <- trunc(n1) + 1 n2 <- trunc(ratio * n1) } else { stop("Both p1 and p2 must be less than 1") } if (length(alpha) > 1) { alpha1 <- alpha } else { alpha1 <- NULL } if (length(power) > 1) { power1 <- power } else { power1 <- NULL } if (length(ratio) > 1) { ratio1 <- ratio } else { ratio1 <- NULL } ########## Adjustment for unequal cluster size if (icc <= 0 | icc >= 1 ){ stop("Intracluster correlation value must be between zero and one") } if (is.null(previous.mean.cluster.size) + is.null(previous.sd.cluster.size) + is.null(max.cluster.size) + is.null(min.cluster.size) > 2){ stop("Choose (previous.mean.cluster.size and previous.sd.cluster.size) OR (max.cluster.size and min.cluster.size)") } if (!is.null(previous.mean.cluster.size) + !is.null(previous.sd.cluster.size) + !is.null(max.cluster.size) + !is.null(min.cluster.size) == FALSE){ stop("Choose (previous.mean.cluster.size and previous.sd.cluster.size) or (max.cluster.size and min.cluster.size)") } cv1 <- previous.sd.cluster.size/previous.mean.cluster.size cv3 <- ((max.cluster.size - min.cluster.size)/4)/mean.cluster.size if ((is.null(max.cluster.size)) & is.null(min.cluster.size)) { cv3 <- NULL } if (is.null(previous.mean.cluster.size) & is.null(previous.sd.cluster.size)){ cv1 <- NULL } if (((is.null(previous.mean.cluster.size)) + (is.null(previous.sd.cluster.size))) == 1){ stop("Both previous.mean.cluster.size and previous.sd.cluster.size are required") } if (((is.null(max.cluster.size)) + (is.null(min.cluster.size))) == 1){ stop("Both max.cluster.size and min.cluster.size are required") } else { deff.unadjusted <- (1 + (mean.cluster.size - 1) * icc) deff.adj1 <- 1 + (((1 + cv1^2) * mean.cluster.size) - 1) * icc deff.adj3 <- 1 + (((1 + cv3^2) * mean.cluster.size) - 1) * icc } if (n1 == n2){ n.unadjusted <- round(deff.unadjusted * n1) n.unadjusted.clus.no <- round(n.unadjusted/mean.cluster.size) n.adj1 <- round(deff.adj1 * n1) n.adj1.clus.no <- round(n.adj1/mean.cluster.size) n.adj3 <- round(deff.adj3 * n1) n.adj3.clus.no <- round(n.adj3/mean.cluster.size) n1.unadjusted <- NULL n1.unadjusted.clus.no <- NULL n1.adj1 <- NULL n1.adj1.clus.no <- NULL n1.adj3 <- NULL n1.adj3.clus.no <- NULL n2.unadjusted <- NULL n2.unadjusted.clus.no <- NULL n2.adj1 <- NULL n2.adj1.clus.no <- NULL n2.adj3 <- NULL n2.adj3.clus.no <- NULL } else { n1.unadjusted <- round(deff.unadjusted * n1) n1.unadjusted.clus.no <- round(n1.unadjusted/mean.cluster.size) n1.adj1 <- round(deff.adj1 * n1) n1.adj1.clus.no <- round(n1.adj1/mean.cluster.size) n1.adj3 <- round(deff.adj3 * n1) n1.adj3.clus.no <- round(n1.adj3/mean.cluster.size) n2.unadjusted <- round(deff.unadjusted * n2) n2.unadjusted.clus.no <- round(n2.unadjusted/mean.cluster.size) n2.adj1 <- round(deff.adj1 * n2) n2.adj1.clus.no <- round(n2.adj1/mean.cluster.size) n2.adj3 <- round(deff.adj3 * n2) n2.adj3.clus.no <- round(n2.adj3/mean.cluster.size) n.unadjusted <- NULL n.unadjusted.clus.no <- NULL n.adj1 <- NULL n.adj1.clus.no <- NULL n.adj3 <- NULL n.adj3.clus.no <- NULL } ####To create output table table1 <- rbind(p1, p2, n1, n2, alpha, power, ratio, mean.cluster.size, previous.mean.cluster.size,previous.sd.cluster.size, max.cluster.size, min.cluster.size, icc, deff.unadjusted, n.unadjusted, n.unadjusted.clus.no, deff.adj1, n.adj1, n.adj1.clus.no, deff.adj3, n.adj3,n.adj3.clus.no, n1.unadjusted, n1.unadjusted.clus.no, n1.adj1, n1.adj1.clus.no, n1.adj3, n1.adj3.clus.no,n2.unadjusted, n2.unadjusted.clus.no, n2.adj1,n2.adj1.clus.no, n2.adj3, n2.adj3.clus.no) rownames(table1)[rownames(table1) == "alpha1"] <- "alpha" rownames(table1)[rownames(table1) == "power1"] <- "power" rownames(table1)[rownames(table1) == "ratio1"] <- "n2/n1" rownames(table1)[rownames(table1) == "ratio"] <- "n2/n1" returns <- list( p1 = p1, p2 = p2, n1 = n1, n2 = n2, alpha = alpha, power = power, ratio = n2/n1, previous.mean.cluster.size = previous.mean.cluster.size, previous.sd.cluster.size = previous.sd.cluster.size, mean.cluster.size = mean.cluster.size, max.cluster.size = max.cluster.size, min.cluster.size = min.cluster.size, icc = icc, deff.unadjusted = deff.unadjusted, n.unadjusted = n.unadjusted, n.unadjusted.clus.no = n.unadjusted.clus.no, deff.adj1 = deff.adj1, n.adj1 = n.adj1, n.adj1.clus.no = n.adj1.clus.no, deff.adj3 = deff.adj3, n.adj3 = n.adj3, n.adj3.clus.no = n.adj3.clus.no, n1.unadjusted = n1.unadjusted, n1.unadjusted.clus.no = n1.unadjusted.clus.no, n1.adj1 = n1.adj1, n1.adj1.clus.no = n1.adj1.clus.no, n1.adj3 = n1.adj3, n1.adj3.clus.no = n1.adj3.clus.no, n2.unadjusted = n2.unadjusted, n2.unadjusted.clus.no = n2.unadjusted.clus.no, n2.adj1 = n2.adj1, n2.adj1.clus.no = n2.adj1.clus.no, n2.adj3 = n2.adj3, n2.adj3.clus.no = n2.adj3.clus.no, table = as.data.frame(table1)) class(returns) <- c("n.for.cluster.2p", "list") returns } # Print n.for.cluster.2p print.n.for.cluster.2p <- function (x, ...) { if (nrow(x$table) < 22) { cat("\n") #Print source of literature used for this sample size calculation #Print assumptions #Assumptions for alpha,power,p1,p2,n2/n1,mean cluster size and icc cat(" Estimation of sample size in a cluster radomized controlled trial", "\n") cat(" for testing Ho: p1==p2", "\n", "\n") cat(" Assumptions:", "\n", "\n") cat(" alpha =", x$alpha, "\n") cat(" power =", x$power, "\n") cat(" p1 =", x$p1, "\n") cat(" p2 =", x$p2, "\n") cat(" n2/n1(ratio) =", x$ratio, "\n") cat(" Current mean cluster size =", x$mean.cluster.size, "\n") cat("Intra-cluster correlation coefficient =", x$icc, "\n") #Assumptions - mean(sd) of cluster size from previous study for design effect if(!is.null(x$previous.mean.cluster.size)){ cat(" Cluster size of previous study:Mean =", x$previous.mean.cluster.size, "\n") cat(" Cluster size of previous study:SD =", x$previous.sd.cluster.size, "\n") cat(" Design Effect:Unadjusted =", x$deff.unadjusted,"\n") cat(" Design Effect:Adjusted =", x$deff.adj1,"\n","\n") } #Assumptions - expected max and min cluster size for design effect else{ cat(" Maximum expected cluster size =", x$max.cluster.size, "\n") cat(" Minimum expected cluster size =", x$min.cluster.size, "\n") cat(" Design Effect:Unadjusted =", x$deff.unadjusted,"\n") cat(" Design Effect:Adjusted =", x$deff.adj3, "\n","\n") } #Print results #Results for equal ratio (n2/n1) if (x$ratio == 1){ cat(" Estimated required sample size:", "\n", "\n") cat(" When design effect is unadjusted for unequal cluster sizes", "\n") cat(" n1 =", x$n.unadjusted, "\n") cat(" Number of clusters for n1 =", x$n.unadjusted.clus.no, "\n") cat(" n2 =", x$n.unadjusted, "\n") cat(" Number of clusters for n2 =", x$n.unadjusted.clus.no,"\n") cat(" n1 + n2 =", x$n.unadjusted + x$n.unadjusted,"\n") cat(" Total number of clusters =", x$n.unadjusted.clus.no + x$n.unadjusted.clus.no,"\n", "\n") cat(" When design effect is adjusted for unequal cluster sizes", "\n") if(is.null(x$max.cluster.size)){ cat(" n1 =", x$n.adj1, "\n") cat(" Number of clusters for n1 =", x$n.adj1.clus.no, "\n") cat(" n2 =", x$n.adj1, "\n") cat(" Number of clusters for n2 =", x$n.adj1.clus.no,"\n") cat(" n1 + n2 =", x$n.adj1 + x$n.adj1, "\n") cat(" Total number of clusters =", x$n.adj1.clus.no + x$n.adj1.clus.no,"\n", "\n") } else{ cat(" n1 =", x$n.adj3, "\n") cat(" Number of clusters for n1 =", x$n.adj3.clus.no, "\n") cat(" n2 =", x$n.adj3, "\n") cat(" Number of clusters for n2 =", x$n.adj3.clus.no,"\n") cat(" n1 + n2 =", x$n.adj3 + x$n.adj3, "\n") cat(" Total number of clusters =", x$n.adj3.clus.no + x$n.adj3.clus.no,"\n", "\n") } } #Results for unequal ratio (ratio!=1) else{ cat(" Estimated required sample size:", "\n", "\n") cat(" When design effect is unadjusted for unequal cluster sizes", "\n") cat(" n1 =", x$n1.unadjusted, "\n") cat(" Number of clusters for n1 =", x$n1.unadjusted.clus.no, "\n") cat(" n2 =", x$n2.unadjusted, "\n") cat(" Number of clusters for n2 =", x$n2.unadjusted.clus.no,"\n") cat(" n1 + n2 =", x$n1.unadjusted + x$n2.unadjusted,"\n") cat(" Total number of clusters =", x$n1.unadjusted.clus.no + x$n2.unadjusted.clus.no,"\n", "\n") cat(" When design effect is adjusted for unequal cluster sizes", "\n") if(is.null(x$max.cluster.size)){ cat(" n1 =", x$n1.adj1, "\n") cat(" Number of clusters for n1 =", x$n1.adj1.clus.no, "\n") cat(" n2 =", x$n2.adj1, "\n") cat(" Number of clusters for n2 =", x$n2.adj1.clus.no,"\n") cat(" n1 + n2 =", x$n1.adj1 + x$n2.adj1, "\n") cat(" Total number of clusters =", x$n1.adj1.clus.no + x$n2.adj1.clus.no,"\n", "\n") } else{ cat(" n1 =", x$n1.adj3, "\n") cat(" Number of clusters for n1 =", x$n1.adj3.clus.no, "\n") cat(" n2 =", x$n2.adj3, "\n") cat(" Number of clusters for n2 =", x$n2.adj3.clus.no,"\n") cat(" n1 + n2 =", x$n1.adj3+ x$n2.adj3, "\n") cat(" Total number of clusters =", x$n1.adj3.clus.no + x$n2.adj3.clus.no,"\n", "\n") } } } #If nrow of xtable is not less than 22 else { cat(" Assumptions:", "\n", "\n") if (length(x$alpha) == 1) cat(" alpha =", x$alpha, "\n") if (length(x$power) == 1) cat(" power =", x$power, "\n") if (length(x$ratio) == 1) cat(" n2/n1 =", x$ratio, "\n") cat("\n") print(x$table) } } ## n.for.cluster.2means n.for.cluster.2means <- function (mu1, mu2, sd1, sd2, alpha = 0.05, power = 0.8, ratio = 1, mean.cluster.size = 10, previous.mean.cluster.size = NULL, previous.sd.cluster.size = NULL, max.cluster.size = NULL, min.cluster.size = NULL, icc = 0.1) { n1 <- (sd1^2 + sd2^2/ratio) * (qnorm(1 - alpha/2) - qnorm(1 - power))^2/(mu1 - mu2)^2 n1 <- round(n1) n2 <- ratio * n1 if (length(alpha) == 1) { alpha1 <- NULL } else { alpha1 <- alpha } if (length(power) == 1) { power1 <- NULL } else { power1 <- power } if (length(ratio) == 1) { ratio1 <- NULL } else { ratio1 <- ratio } ########## Adjustment for unequal cluster size if (icc <= 0 | icc >= 1 ){ stop("Intracluster correlation value must be between zero and one") } if (is.null(previous.mean.cluster.size) + is.null(previous.sd.cluster.size) + is.null(max.cluster.size) + is.null(min.cluster.size) > 2){ stop("Choose (previous.mean.cluster.size and previous.sd.cluster.size) OR (max.cluster.size and min.cluster.size)") } if (!is.null(previous.mean.cluster.size) + !is.null(previous.sd.cluster.size) + !is.null(max.cluster.size) + !is.null(min.cluster.size) == FALSE){ stop("Choose (previous.mean.cluster.size and previous.sd.cluster.size) or (max.cluster.size and min.cluster.size)") } cv1 <- previous.sd.cluster.size/previous.mean.cluster.size cv3 <- ((max.cluster.size - min.cluster.size)/4)/mean.cluster.size if ((is.null(max.cluster.size)) & is.null(min.cluster.size)) { cv3 <- NULL } if (is.null(previous.mean.cluster.size) & is.null(previous.sd.cluster.size)){ cv1 <- NULL } if (((is.null(previous.mean.cluster.size)) + (is.null(previous.sd.cluster.size))) == 1){ stop("Both previous.mean.cluster.size and previous.sd.cluster.size are required") } if (((is.null(max.cluster.size)) + (is.null(min.cluster.size))) == 1){ stop("Both max.cluster.size and min.cluster.size are required") } else { deff.unadjusted <- (1 + (mean.cluster.size - 1) * icc) deff.adj1 <- 1 + (((1 + cv1^2) * mean.cluster.size) - 1) * icc deff.adj3 <- 1 + (((1 + cv3^2) * mean.cluster.size) - 1) * icc } if (n1 == n2){ n.unadjusted <- round(deff.unadjusted * n1) n.unadjusted.clus.no <- round(n.unadjusted/mean.cluster.size) n.adj1 <- round(deff.adj1 * n1) n.adj1.clus.no <- round(n.adj1/mean.cluster.size) n.adj3 <- round(deff.adj3 * n1) n.adj3.clus.no <- round(n.adj3/mean.cluster.size) n1.unadjusted <- NULL n1.unadjusted.clus.no <- NULL n1.adj1 <- NULL n1.adj1.clus.no <- NULL n1.adj3 <- NULL n1.adj3.clus.no <- NULL n2.unadjusted <- NULL n2.unadjusted.clus.no <- NULL n2.adj1 <- NULL n2.adj1.clus.no <- NULL n2.adj3 <- NULL n2.adj3.clus.no <- NULL } else { n1.unadjusted <- round(deff.unadjusted * n1) n1.unadjusted.clus.no <- round(n1.unadjusted/mean.cluster.size) n1.adj1 <- round(deff.adj1 * n1) n1.adj1.clus.no <- round(n1.adj1/mean.cluster.size) n1.adj3 <- round(deff.adj3 * n1) n1.adj3.clus.no <- round(n1.adj3/mean.cluster.size) n2.unadjusted <- round(deff.unadjusted * n2) n2.unadjusted.clus.no <- round(n2.unadjusted/mean.cluster.size) n2.adj1 <- round(deff.adj1 * n2) n2.adj1.clus.no <- round(n2.adj1/mean.cluster.size) n2.adj3 <- round(deff.adj3 * n2) n2.adj3.clus.no <- round(n2.adj3/mean.cluster.size) n.unadjusted <- NULL n.unadjusted.clus.no <- NULL n.adj1 <- NULL n.adj1.clus.no <- NULL n.adj3 <- NULL n.adj3.clus.no <- NULL } ####To create output table table1 <- rbind(mu1, mu2, sd1, sd2, n1, n2, alpha, power, ratio, mean.cluster.size, previous.mean.cluster.size,previous.sd.cluster.size, max.cluster.size, min.cluster.size, icc, deff.unadjusted, n.unadjusted, n.unadjusted.clus.no, deff.adj1, n.adj1, n.adj1.clus.no, deff.adj3, n.adj3,n.adj3.clus.no, n1.unadjusted, n1.unadjusted.clus.no, n1.adj1, n1.adj1.clus.no, n1.adj3, n1.adj3.clus.no,n2.unadjusted, n2.unadjusted.clus.no, n2.adj1,n2.adj1.clus.no, n2.adj3, n2.adj3.clus.no) rownames(table1)[rownames(table1) == "alpha1"] <- "alpha" rownames(table1)[rownames(table1) == "power1"] <- "power" rownames(table1)[rownames(table1) == "ratio1"] <- "n2/n1" rownames(table1)[rownames(table1) == "ratio"] <- "n2/n1" returns <- list( mu1 = mu1, mu2 = mu2, sd1 = sd1, sd2 = sd2, n1 = n1, n2 = n2, alpha = alpha, power = power, ratio = n2/n1, previous.mean.cluster.size = previous.mean.cluster.size, previous.sd.cluster.size = previous.sd.cluster.size, mean.cluster.size = mean.cluster.size, max.cluster.size = max.cluster.size, min.cluster.size = min.cluster.size, icc = icc, deff.unadjusted = deff.unadjusted, n.unadjusted = n.unadjusted, n.unadjusted.clus.no = n.unadjusted.clus.no, deff.adj1 = deff.adj1, n.adj1 = n.adj1, n.adj1.clus.no = n.adj1.clus.no, deff.adj3 = deff.adj3, n.adj3 = n.adj3, n.adj3.clus.no = n.adj3.clus.no, n1.unadjusted = n1.unadjusted, n1.unadjusted.clus.no = n1.unadjusted.clus.no, n1.adj1 = n1.adj1, n1.adj1.clus.no = n1.adj1.clus.no, n1.adj3 = n1.adj3, n1.adj3.clus.no = n1.adj3.clus.no, n2.unadjusted = n2.unadjusted, n2.unadjusted.clus.no = n2.unadjusted.clus.no, n2.adj1 = n2.adj1, n2.adj1.clus.no = n2.adj1.clus.no, n2.adj3 = n2.adj3, n2.adj3.clus.no = n2.adj3.clus.no, table = as.data.frame(table1)) class(returns) <- c("n.for.2means.cluster.RCT", "list") returns } # Print n.for.cluster.2means print.n.for.cluster.2means <- function (x, ...) { if (nrow(x$table) < 39) { cat("\n") #Print assumptions #Assumptions for alpha,power,p1,p2,n2/n1,mean cluster size and icc cat(" Estimation of sample size in a cluster radomized controlled trial", "\n") cat(" for testing Ho: mu1==mu2", "\n", "\n") cat(" Assumptions:", "\n", "\n") if (length(x$alpha) == 1) cat(" alpha =", x$alpha, "\n") if (length(x$power) == 1) cat(" power =", x$power, "\n") cat(" mu1 =", x$mu1, "\n") cat(" mu2 =", x$mu2, "\n") cat(" sd1 =", x$sd1, "\n") cat(" sd2 =", x$sd2, "\n") if (length(x$ratio) == 1) cat(" n2/n1(ratio) =", x$ratio, "\n") cat(" Expected mean cluster size =", x$mean.cluster.size, "\n") cat("Intra-cluster correlation coefficient =", x$icc, "\n") #Assumptions - mean(sd) of cluster size from previous study for design effect if(!is.null(x$previous.mean.cluster.size)){ cat(" Cluster size of previous study:Mean =", x$previous.mean.cluster.size, "\n") cat(" Cluster size of previous study:SD =", x$previous.sd.cluster.size, "\n") cat(" Design Effect:Unadjusted =", x$deff.unadjusted,"\n") cat(" Design Effect:Adjusted =", x$deff.adj1,"\n","\n") } #Assumptions - expected max and min cluster size for design effect else{ cat(" Maximum expected cluster size =", x$max.cluster.size, "\n") cat(" Minimum expected cluster size =", x$min.cluster.size, "\n") cat(" Design Effect:Unadjusted =", x$deff.unadjusted,"\n") cat(" Design Effect:Adjusted =", x$deff.adj3, "\n","\n") } #Print results #Results for equal ratio (n2/n1) if (x$ratio == 1){ cat(" Estimated required sample size:", "\n", "\n") cat(" When design effect is unadjusted for unequal cluster sizes", "\n") cat(" n1 =", x$n.unadjusted, "\n") cat(" Number of clusters for n1 =", x$n.unadjusted.clus.no, "\n") cat(" n2 =", x$n.unadjusted, "\n") cat(" Number of clusters for n2 =", x$n.unadjusted.clus.no,"\n") cat(" n1 + n2 =", x$n.unadjusted + x$n.unadjusted,"\n") cat(" Total number of clusters =", x$n.unadjusted.clus.no + x$n.unadjusted.clus.no,"\n", "\n") cat(" When design effect is adjusted for unequal cluster sizes", "\n") if(is.null(x$max.cluster.size)){ cat(" n1 =", x$n.adj1, "\n") cat(" Number of clusters for n1 =", x$n.adj1.clus.no, "\n") cat(" n2 =", x$n.adj1, "\n") cat(" Number of clusters for n2 =", x$n.adj1.clus.no,"\n") cat(" n1 + n2 =", x$n.adj1 + x$n.adj1, "\n") cat(" Total number of clusters =", x$n.adj1.clus.no + x$n.adj1.clus.no,"\n", "\n") } else{ cat(" n1 =", x$n.adj3, "\n") cat(" Number of clusters for n1 =", x$n.adj3.clus.no, "\n") cat(" n2 =", x$n.adj3, "\n") cat(" Number of clusters for n2 =", x$n.adj3.clus.no,"\n") cat(" n1 + n2 =", x$n.adj3 + x$n.adj3, "\n") cat(" Total number of clusters =", x$n.adj3.clus.no + x$n.adj3.clus.no,"\n", "\n") } } #Results for unequal ratio (ratio!=1) else{ cat(" Estimated required sample size:", "\n", "\n") cat(" When design effect is unadjusted for unequal cluster sizes", "\n") cat(" n1 =", x$n1.unadjusted, "\n") cat(" Number of clusters for n1 =", x$n1.unadjusted.clus.no, "\n") cat(" n2 =", x$n2.unadjusted, "\n") cat(" Number of clusters for n2 =", x$n2.unadjusted.clus.no,"\n") cat(" n1 + n2 =", x$n1.unadjusted + x$n2.unadjusted,"\n") cat(" Total number of clusters =", x$n1.unadjusted.clus.no + x$n2.unadjusted.clus.no,"\n", "\n") cat(" When design effect is adjusted for unequal cluster sizes", "\n") if(is.null(x$max.cluster.size)){ cat(" n1 =", x$n1.adj1, "\n") cat(" Number of clusters for n1 =", x$n1.adj1.clus.no, "\n") cat(" n2 =", x$n2.adj1, "\n") cat(" Number of clusters for n2 =", x$n2.adj1.clus.no,"\n") cat(" n1 + n2 =", x$n1.adj1 + x$n2.adj1, "\n") cat(" Total number of clusters =", x$n1.adj1.clus.no + x$n2.adj1.clus.no,"\n", "\n") } else{ cat(" n1 =", x$n1.adj3, "\n") cat(" Number of clusters for n1 =", x$n1.adj3.clus.no, "\n") cat(" n2 =", x$n2.adj3, "\n") cat(" Number of clusters for n2 =", x$n2.adj3.clus.no,"\n") cat(" n1 + n2 =", x$n1.adj3+ x$n2.adj3, "\n", "\n") cat(" Total number of clusters =", x$n1.adj3.clus.no + x$n2.adj3.clus.no,"\n", "\n") } } } #If nrow of xtable is not less than 39 else { cat("\n") print(x$table) } } ### sample size for survey n.for.survey <- function(p, delta = "auto", popsize=NULL, deff=1, alpha = .05){ q <- 1-p pq <- cbind(p, q) minpq <- apply(pq, 1, min) if(any(delta=="auto")){ delta <- ifelse(minpq >= .3, 0.1, ifelse(minpq >= .1, .05, minpq/2)) } if(any(p >= 1) | any(delta >= 1) | any(popsize < 2) ) stop("Proportion and delta both must < 1. Popsize must be >=2") else { n1 <- qnorm(1-alpha/2)^2*p*(1-p)/delta^2 if (!is.null(popsize)){ n1 = n1/(1+n1/popsize) } if (deff != 1) { n1 = n1*deff } } deff1 <- deff if(deff==1) deff1 <- NULL table1 <- cbind(p, popsize, deff1, delta, round(n1)) colnames(table1)[colnames(table1)=="deff1"] <- "deff" colnames(table1)[ncol(table1)] <- "n" returns <- list(p = p, delta=delta, popsize=popsize, deff=deff, alpha = alpha, n1=n1, minpq=minpq, table = as.data.frame(table1)) class(returns) <- c("n.for.survey", "list") returns } ### print n.for.survey print.n.for.survey <- function(x, ...) { if(nrow(x$table) < 6){ cat("\n") cat("Sample size for survey.","\n") cat("Assumptions:", "\n") cat(" Proportion =", x$p, "\n") cat(" Confidence limit =", round((1-x$alpha)*100), "%","\n") cat(" Delta =", x$delta, "from the estimate.", "\n") if (!is.null(x$popsize)){ cat(" Population size =", x$popsize, "\n") } if (x$deff != 1) { cat(" Design effect =", x$deff, "\n") } cat("\n") cat(" Sample size =", round(x$n1), "\n") cat("\n") }else{ cat("Sample size for survey.","\n") cat("Assumptions:", "\n") if(length(x$alpha) == 1) cat(" Confidence limit =", round((1-x$alpha)*100), "%","\n") if(length(x$delta) == 1) cat(" Delta =", x$delta, "from the estimate.", "\n") cat("\n") print(x$table, rownames=FALSE) } } ### Sample size for lot quality assurance sampling n.for.lqas <- function(p0, q=0, N=10000, alpha=.05, exact=FALSE){ maxi <- nrow(cbind(p0,q,N)) if(length(p0)==1 & maxi >1) p0 <- rep(p0, maxi) if(length(q)==1 & maxi >1) q <- rep(q, maxi) if(length(N)==1 & maxi >1) N <- rep(N, maxi) n <- N alpha.i <- alpha if(length(alpha)==1 & maxi > 1) alpha.i <- rep(alpha, maxi) if (exact) { # Hypergeometric distribution 2-by-2 table : See `help("Hypergeometric")' # # q n-x n # k-q m-(k-q) m # k N-k N # where N = population # n = sample size # q = positive among sample # k = total positive in the population m <- rep(1, maxi) k <- rep(1, maxi) for(i in 1:maxi){ for(j in N[i]:1){ m[i] <- N[i]-j k[i] <- trunc(p0[i]*N[i]) if (dhyper(q[i], j, m[i], k[i]) > alpha.i[i]) break n[i] <- j } } method <- "Exact" } else { # For normal approximation calculation # Formula: d=n*p0-z*sqrt(n*p0*(1-p0)*(N-n)/(N-1)) for(i in 1:maxi){ for (j in N[i]:1){ if ((j*p0[i]-(qnorm(p=1-alpha.i[i]))*sqrt(j*p0[i]*(1-p0[i])*(N[i]-j)/(N[i]-1))- q[i]) < .001) break n[i] <- j } method <- "Normal approximation" } } n <- round(n) if(length(alpha) > 1 ) {alpha1 <- alpha }else {alpha1 <- NULL} if(length(N) > 1 ) {N1 <- N }else {N1 <- NULL} table1 <- cbind(p0, q, N, n, alpha1) colnames(table1)[colnames(table1)=="alpha1"] <- "alpha" table1 <- as.data.frame(table1) returns <- list(p0=p0, q=q, N=N, alpha=alpha, method=method, n=n, table=table1) class(returns) <- c("n.for.lqas","list") returns } ### Print n.for.lqas print.n.for.lqas <- function(x, ...){ if(nrow(x$table) < 6){ cat("\n") cat(" Lot quality assurance sampling","\n","\n") cat(c(" Method =", x$method, "\n")) cat(c(" Population size =", x$N,"\n")) cat(" Maximum defective sample accepted =", x$q, "\n") cat(" Probability of defect accepted =", x$p0,"\n") cat(" Alpha =", x$alpha, "\n") cat(c(" Sample size required =", x$n, "\n","\n")) }else{ cat("\n") cat(" Lot quality assurance sampling","\n") cat(c(" Method =", x$method, "\n")) if(length(table(x$N))==1) cat(c(" Population size =", unique(x$N),"\n")) if(length(x$alpha)==1) cat(" Alpha =", x$alpha, "\n") cat("\n") print(x$table) }} ### Sample size for test of two means n.for.2means <- function (mu1, mu2, sd1, sd2, ratio=1, alpha=.05, power=.8) { n1 <- (sd1^2+sd2^2/ratio)*(qnorm(1-alpha/2)-qnorm(1-power))^2/(mu1-mu2)^2 n1 <- round(n1) n2 <- ratio * n1 if(length(alpha)==1) {alpha1 <- NULL}else{alpha1 <- alpha} if(length(power)==1) {power1 <- NULL}else{power1 <- power} if(length(ratio)==1) {ratio1 <- NULL}else{ratio1 <- ratio} table1 <- cbind(mu1, mu2, sd1, sd2, n1, n2, alpha1, power1, ratio1) colnames(table1)[colnames(table1)=="alpha1"] <- "alpha" colnames(table1)[colnames(table1)=="power1"] <-"power" colnames(table1)[colnames(table1)=="ratio1"] <-"n2/n1" table1 <- as.data.frame(table1) returns <- list(mu1=mu1, mu2=mu2, sd1=sd1, sd2=sd2, alpha=alpha, n1=n1, n2=n2, power=power, ratio= ratio, table = table1) class(returns) <- c("n.for.2means","list") returns } # Print n.for.2means print.n.for.2means <- function(x, ...) { cat("\n") cat("Estimation of sample size for testing Ho: mu1==mu2", "\n") cat("Assumptions:", "\n", "\n") if(length(x$alpha)==1) cat(" alpha =", x$alpha, "\n") if(length(x$power)==1) cat(" power =", x$power, "\n") if(length(x$ratio)==1) cat(" n2/n1 =", x$ratio, "\n") if(nrow(x$table) < 6){ cat(" mu1 =", x$mu1, "\n") cat(" mu2 =", x$mu2, "\n") cat(" sd1 =", x$sd1, "\n") cat(" sd2 =", x$sd2, "\n", "\n") cat("Estimated required sample size:", "\n", "\n") cat(" n1 =",x$n1+1,"\n") cat(" n2 =",x$n2+1,"\n") cat(" n1 + n2 =",x$n1+x$n2+2,"\n","\n") }else{ cat("\n") print(x$table) }} ## Sample size for equivalent trial n.for.equi.2p <- function (p, sig.diff, alpha=.05, power=.8 ) { n <- (qnorm(alpha/2) + qnorm(1-power))^2 * 2*p*(1-p)/sig.diff^2 n <- trunc(n) + 1 table1 <- cbind(p, n, sig.diff, alpha, power) colnames(table1)[colnames(table1)=="alpha"] <- "alpha" colnames(table1)[colnames(table1)=="power"] <- "power" colnames(table1)[colnames(table1)=="sig.diff"] <- "sig.diff" returns <- list(p=p, n=n, sig.diff=sig.diff, alpha=alpha, power=power, table = as.data.frame(table1)) class(returns) <- c("n.for.equi.2p", "list") returns } ## print n.for.equi.2p print.n.for.equi.2p <- function(x, ...){ if(nrow(x$table) < 6){ cat("\n") cat("Estimation of sample size for testing Ho: p1==p2==p", "\n") cat("Assumptions:", "\n", "\n") cat(" alpha =", x$alpha, "\n") cat(" power =", x$power, "\n") cat(" p =", x$p, "\n") cat(" sig.diff =", x$sig.diff, "\n", "\n") cat("Estimated required sample size:", "\n", "\n") cat(" n =",x$n,"\n") cat(" Total n =",x$n*2,"\n","\n") }else{ cat("Assumptions:", "\n", "\n") if(length(x$alpha)==1) cat(" alpha =", x$alpha, "\n") if(length(x$power)==1) cat(" power =", x$power, "\n") if(length(x$ratio)==1) cat(" n2/n1 =", x$ratio, "\n") cat("\n") print(x$table) } } # n.for.noninferior.2p n.for.noninferior.2p <- function (p, sig.inferior, alpha=.05, power=.8 ) { n <- (qnorm(alpha) + qnorm(1-power))^2 * 2*p*(1-p)/sig.inferior^2 n <- trunc(n) + 1 table1 <- cbind(p, n, sig.inferior, alpha, power) colnames(table1)[colnames(table1)=="alpha"] <- "alpha" colnames(table1)[colnames(table1)=="power"] <- "power" colnames(table1)[colnames(table1)=="sig.inferior"] <- "sig.inferior" returns <- list(p=p, n=n, sig.inferior=sig.inferior, alpha=alpha, power=power, table = as.data.frame(table1)) class(returns) <- c("n.for.noninferior.2p", "list") returns } ## print n.for.noninferior.2p print.n.for.noninferior.2p <- function(x, ...){ if(nrow(x$table) < 6){ cat("\n") cat("Estimation of sample size for testing Ho: p1==p2 == p", "\n") cat("Assumptions:", "\n", "\n") cat(" alpha =", x$alpha, "\n") cat(" power =", x$power, "\n") cat(" p =", x$p, "\n") cat(" sig.inferior =", x$sig.inferior, "\n", "\n") cat("Estimated required sample size:", "\n", "\n") cat(" n =",x$n,"\n") cat(" Total n =",x$n*2,"\n","\n") }else{ cat("Assumptions:", "\n", "\n") if(length(x$alpha)==1) cat(" alpha =", x$alpha, "\n") if(length(x$power)==1) cat(" power =", x$power, "\n") if(length(x$ratio)==1) cat(" n2/n1 =", x$ratio, "\n") cat("\n") print(x$table) } } ### Pack all related variables into the existing .data pack <- function (dataFrame = .data) { data1 <- dataFrame j <- NULL k <- attr(data1, "var.labels") candidate.objects <- setdiff(lsNoFunction(), as.character(ls.str(mode = "list")[])) if (length(candidate.objects) == 0) stop("No related vector outside the default data frame") for (i in 1:length(candidate.objects)) { if (length(get(candidate.objects[i])) == nrow(data1)) { if (any(names(data1) == candidate.objects[i])) { data1[, names(data1) == candidate.objects[i]] <- get(candidate.objects[i]) j <- c(j, i) } else { data1 <- data.frame(data1, get(candidate.objects[i])) names(data1)[ncol(data1)] <- candidate.objects[i] j <- c(j, i) if (!is.null(k)) { k <- c(k, "") } } } } attr(data1, "var.labels") <- k rm(list = candidate.objects[j], pos = 1) assign(as.character(substitute(dataFrame)), data1, pos=1) if(is.element(as.character(substitute(dataFrame)), search())){ detach(pos=which(search() %in% as.character(substitute(dataFrame)))) attach(data1, name=as.character(substitute(dataFrame)), warn.conflicts = FALSE) } } ### Power calcuation power.for.2means <- function (mu1, mu2, n1, n2, sd1, sd2, alpha = 0.05) { mu3 <- mu1 mu4 <- mu2 n3 <- n1 n4 <- n2 sd3 <- sd1 sd4 <- sd2 mu1 <- ifelse (mu3 > mu4, mu4, mu3) mu2 <- ifelse (mu3 > mu4, mu3, mu4) n1 <- ifelse (mu3 > mu4, n4, n3) n2 <- ifelse (mu3 > mu4, n3, n4) sd1 <- ifelse(mu3 > mu4, sd4, sd3) sd2 <- ifelse(mu3 > mu4, sd3, sd4) ratio <- n2/n1 pooled.sd <- sqrt(sd1^2/n1 + sd2^2/n2) power <- pnorm((mu2 - mu1)/pooled.sd - qnorm(1 - alpha/2)) if(length(power) ==1){ diffmu <- seq(-2 * pooled.sd, 2 * pooled.sd + (mu2 - mu1), by = 0.01 * (mu2 - mu1)) h0 <- dnorm(diffmu, mean = 0, sd = pooled.sd) ha <- dnorm(diffmu, mean = (mu2 - mu1), sd = pooled.sd) plot(diffmu, h0, type = "l", xlim = c(-2 * pooled.sd, 2 * pooled.sd + (mu2 - mu1)), main = paste("Power =", round(power, 4)), ylab = "", xlab = "mu2-mu1") lines(diffmu, ha, type = "l") check.point <- qnorm(1 - alpha/2) * pooled.sd for (i in seq(from = check.point, to = 2 * pooled.sd + (mu2 - mu1), by = (max(diffmu) - min(diffmu))/50)) { lines(c(i, i), c(0, dnorm(i, mean = (mu2 - mu1), sd = pooled.sd)), col = "blue") } text(max(diffmu), max(h0), paste("mu1 = ", mu1, ", mu2 = ", mu2, sep = ""), pos = 2) text(max(diffmu), 0.9 * max(h0), paste("sd1 = ", sd1, ", sd2 = ", sd2, sep = ""), pos = 2) text(max(diffmu), 0.8 * max(h0), paste("n1 = ", n1, ", n2 = ", n2, sep = ""), pos = 2) text(0, 0.5 * max(h0), paste("Ho: mu2-mu1=0"), col = "brown", font = 4) text(mu2 - mu1, 0.4 * max(h0), paste("Ha: mu2 - mu1 =", mu2 - mu1), col = "brown", font = 4) } table1 <- cbind(mu3, mu4, n3, n4, sd3, sd3, alpha, round(power, 2)) colnames(table1)[1:6] <- c("mu1","mu2","n1","n2","sd1","sd2") colnames(table1)[8] <- "power" returns <- list(mu1 = mu3, mu2 = mu4, n1 = n3, n2=n4, sd1 = sd3, sd2=sd4, power=power, alpha=alpha, table = as.data.frame(table1)) class(returns) <- c("power.for.2means", "list") returns } print.power.for.2means <- function (x, ...) { cat("\n") cat("Power for comparison of 2 means.", "\n") if (nrow(x$table) < 6) { cat(" mu1 =", x$mu1, "\n") cat(" mu2 =", x$mu2, "\n") cat(" sd1 =", x$sd1, "\n") cat(" sd2 =", x$sd2, "\n") cat(" n1 =", x$n1 , "\n") cat(" n2 =", x$n2, "\n") cat(" alpha =", x$alpha, "\n") cat(" power =", round(x$power,3), "\n") } else { print(x$table, rownames = FALSE) } } power.for.2p <- function (p1, p2, n1, n2, alpha = 0.05) { p3 <- p1 p4 <- p2 n3 <- n1 n4 <- n2 p1 <- ifelse (p3 > p4, p4, p3) p2 <- ifelse (p3 > p4, p3, p4) n1 <- ifelse (p3 > p4, n4, n3) n2 <- ifelse (p3 > p4, n3, n4) ratio <- n2/n1 r1 <- ratio + 1 pbar <- (p1 + ratio * p2)/r1 n0 <- (n1 - r1/(2 * ratio * (p2 - p1)))^2/n1 zb <- ((p2 - p1) * sqrt(ratio * n0) - qnorm(1 - alpha/2) * sqrt(r1 * pbar * (1 - pbar)))/sqrt(ratio * p1 * (1 - p1) + p2 * (1 - p2)) power <- pnorm(zb) table1 <- cbind(p3, p4, n3, n4, alpha, round(power, 3)) colnames(table1)[1:4] <- c("p1","p2","n1","n2") colnames(table1)[6] <- "power" returns <- list(p1 = p3, p2 = p4, n1 = n3, n2 = n4, power=power, alpha=alpha, table = as.data.frame(table1)) class(returns) <- c("power.for.2p", "list") returns } print.power.for.2p <- function (x, ...) { cat("\n") cat("Power for comparison of 2 proportions.", "\n") if (nrow(x$table) < 6) { cat(" p1 =", x$p1, "\n") cat(" p2 =", x$p2, "\n") cat(" n1 =", x$n1 , "\n") cat(" n2 =", x$n2, "\n") cat(" alpha =", x$alpha, "\n") cat(" power =", round(x$power, 3), "\n") } else { print(x$table, rownames = FALSE) } } ### Quantile normal plot with Shapiro-Wilk test result shapiro.qqnorm <- function(x, ...){ shapiro <-shapiro.test(x) if(shapiro$p.value<.001) {shapvalue<-"Shapiro-Wilk test P value <.001"} else {shapvalue <-paste( "Shapiro-Wilk test P value = ", round(shapiro$p.value, 4), sep="")} qqnorm(x, plot.it = FALSE) -> q qqnorm(x, main= paste("Normal Q-Q plot of ",deparse(substitute(x)), sep=""), ...) text(min(q$x, na.rm=TRUE), max(q$y, na.rm=TRUE), pos=4, shapvalue, col="brown", font=3) qqline(x, col="blue", lty=2) } ### Match tabulation matchTab <- function(case, exposed, strata) { cat("\n") if((length(table(case))!=2)){ stop("Case variable not binary") } if(any(is.na(case))){ stop("There should not be any missing outcome")} if(length(table(exposed))!=2){ stop("Exposure variable not binary") } exposed1 <- exposed if(is.factor(exposed)){ cat(paste("Exposure status:", as.character(substitute(exposed)), "=", levels(exposed)[2],"\n")) }else{ cat(paste("Exposure status:", as.character(substitute(exposed)), "=", max(exposed, na.rm=TRUE),"\n")) } cat("\n") if(is.factor(exposed1)){ exposed1 <- exposed1==levels(exposed1)[2] } control <- 1-case aggregate.data.frame(control, list(strata=strata), sum) -> a colnames(a)[2] <- "ncontrols" case.exposed <- case*exposed1 aggregate.data.frame(case.exposed, list(strata=strata), sum) -> b colnames(b)[2] <- "ncase.exposed" control.exposed <- control*exposed1 aggregate.data.frame(control.exposed, list(strata=strata), sum) -> c colnames(c)[2] <- "ncontrol.exposed" aggregate.data.frame(case, list(strata=strata), length) -> d colnames(d)[2] <- "all.subjects" aggregate.data.frame(exposed1, list(strata=strata), sum) -> e colnames(e)[2] <- "all.exposed" merge(a,b,by.x="strata", by.y="strata") -> f merge(f,c,by.x="strata", by.y="strata") -> g merge(g,d,by.x="strata", by.y="strata") -> h merge(h,e,by.x="strata", by.y="strata") -> ii sum.ii <- rowSums(ii[,2:6]) rowi0 <- nrow(ii) ii <- subset(ii, !is.na(sum.ii)) rowi1 <- nrow(ii) if(rowi1 < rowi0){ cat (rowi0-rowi1,"match sets with incomplete information omitted from tabulation.","\n") } cat ("Total number of match sets in the tabulation =", rowi1,"\n") all.unexposed <- ii$all.subjects-ii$all.exposed ii$ncontrol.exposed1 <- factor(ii$ncontrol.exposed, levels=as.character(0:max(ii$ncontrols))) ii$ncase.exposed1 <- factor(ii$ncase.exposed, levels=as.character(0:max(ii$ncase.exposed))) table(ii$ncase.exposed1, ii$ncontrol.exposed1, ii$ncontrols, dnn=c("No. of cases exposed","No. of controls exposed","No. of controls per case"))->matchTable cat("\n") for(i in 1:max(ii$ncontrols)){ cat(paste("Number of controls =",i,"\n")) print(matchTable[1:max(c(2,max(which(rowSums(matchTable[,,i])>0)))),1:(i+1),i]) cat("\n") } numerator <- (ii$ncontrols-ii$ncontrol.exposed)*ii$ncase.exposed/(ii$ncontrols+1) denominator <- ii$ncontrol.exposed*(1-ii$ncase.exposed)/(ii$ncontrols+1) if(sum(denominator) <1){ cat("Inadequate discordant pairs. Odds ratio not computed"); cat("\n") }else{ if(any(ii$ncase.exposed>1)){ cat(paste(c("More than one cases exposed in strata # ", as.character(ii$strata[ii$ncase.exposed > 1]), ". M-H odds ratio not computed."), sep="")) cat("\n", "\n") }else{ mhor <- sum(numerator)/sum(denominator) cat(paste("Odds ratio by Mantel-Haenszel method =", round(mhor,3), "\n", "\n")) ### computing MLE-OR using clogit } library(survival) model <- clogit(case ~ exposed + strata(strata)) clogitor <- exp(model$coefficients) lnci95 <- c(model$coefficients-qnorm(0.975)*sqrt(model$var),model$coefficients+qnorm(0.975)*sqrt(model$var)) ci95.mleor <- exp(lnci95) cat(paste("Odds ratio by maximum likelihood estimate (MLE) method =", round(clogitor,3),"\n","95%CI=",round(ci95.mleor[1],3),",",round(ci95.mleor[2],3), "\n")) cat("\n") }} ### Goodness-of-fit test for poisson assumption after regression poisgof <- function(model) { if (model$family$family != "poisson" & substr(model$family$family,1,12)!="Negative Bin") stop("Not from Poisson regression!") chisq <- model$deviance df <- model$df.residual p.value <- pchisq(chisq, df, lower.tail=FALSE) return(list(results="Goodness-of-fit test for Poisson assumption",chisq=chisq, df=df, p.value=p.value)) } ### Sort data set and related vector sortBy <- function(..., dataFrame = .data, inclusive=TRUE) { data1 <- dataFrame data1 <- data1[order(...),] if(inclusive){ y <- setdiff(lsNoFunction(), as.character(ls.str(mode="list")[])) if (length(y)>0){ for(i in 1:length(y)){ if(length(get(y[i]))==nrow(data1)){ nam <- y[i] assign (nam, (get(y[i]))[order(...)], envir = .GlobalEnv) } } } } detachAllData() assign(as.character(substitute(dataFrame)), data1, pos=1) attach(data1, name=as.character(substitute(dataFrame)), warn.conflicts = FALSE) } ### One-way tabulation tab1 <- function (x0, decimal = 1, sort.group = c(FALSE, "decreasing", "increasing"), cum.percent = !any(is.na(x0)), graph = TRUE, missing = TRUE, bar.values = c("frequency", "percent", "none"), horiz = FALSE, cex = 1, cex.names = 1, main = "auto", xlab = "auto", ylab = "auto", col = "auto", gen.ind.vars = FALSE, ...) { if (graph) { var1 <- deparse(substitute(x0)) if (length(var1) > 1) { string2 <- var1[length(var1)] } else if (substring(search()[2], first = 1, last = 8) != "package:") { string2 <- attr(get(search()[2]), "var.labels")[attr(get(search()[2]), "names") == deparse(substitute(x0))] if (length(string2) == 0) { string2 <- deparse(substitute(x0)) } if (string2 == "") { string2 <- deparse(substitute(x0)) } } else { string2 <- deparse(substitute(x0)) } string3 <- paste(titleString()$distribution.of, string2) table.to.plot <- table(x0) if (missing == TRUE) { table.to.plot <- table(x0, exclude = NULL) if (is.factor(x0)) { table.to.plot <- as.table(summary(x0)) } if (is.na(names(table.to.plot)[length(names(table.to.plot))]) | names(table.to.plot)[length(names(table.to.plot))] == "NA's") names(table.to.plot)[length(names(table.to.plot))] <- "Missing" } scale.label <- as.character(titleString()$frequency) suppressWarnings(if (bar.values == "percent") { table.to.plot <- round(table.to.plot/sum(table.to.plot) * 100, decimal) scale.label <- "%" }) suppressWarnings(if (sort.group == "decreasing") { table.to.plot <- table.to.plot[order(table.to.plot, names(table.to.plot), decreasing = TRUE)] if (max(nchar(names(table.to.plot))) > 8 & length(table.to.plot) > 6) { table.to.plot <- table.to.plot[order(table.to.plot, names(table.to.plot), decreasing = FALSE)] } }) suppressWarnings(if (sort.group == "increasing") { table.to.plot <- table.to.plot[order(table.to.plot, names(table.to.plot), decreasing = FALSE)] if (max(nchar(names(table.to.plot))) > 8 & length(table.to.plot) > 6) { table.to.plot <- table.to.plot[order(table.to.plot, names(table.to.plot), decreasing = TRUE)] } }) if(any(col == "auto")){ if (length(names(table.to.plot)) < 3){ colours <- "grey" }else{ colours <- c("white",2:length(names(table.to.plot))) } }else{ colours <- col } if ((max(nchar(names(table.to.plot))) > 8 & length(table.to.plot) > 6) | horiz == TRUE) { par(mai = c(0.95625, 0.1, 0.76875, 0.39375) + 0.1 + c(0, par()$cin[1] * max(nchar(names(table.to.plot))) * 0.75 * cex.names, 0, 0)) y.coordinates <- barplot(table.to.plot, main = ifelse(main == "auto", string3, main), horiz = TRUE, las = 1, xlim = c(0, max(table.to.plot) * 1.2), xlab = ifelse(xlab == "auto", scale.label, xlab), cex.names = cex.names, col=colours, ...) suppressWarnings(if (bar.values == "frequency" | bar.values == "percent" | length(bar.values) == 3) { text(table.to.plot, y.coordinates, as.character(table.to.plot), pos = 4, offset = 0.3, cex = cex) }) par(mai = c(0.95625, 0.76875, 0.76875, 0.39375)) } else { x.coordinates <- barplot(table.to.plot, main = ifelse(main == "auto", string3, main), ylab = ifelse(ylab == "auto", scale.label, ylab), cex.names = cex.names, ylim = c(0, max(table.to.plot) * 1.1), col=colours, ...) suppressWarnings(if (bar.values == "frequency" | bar.values == "percent" | length(bar.values) == 3) { text(x.coordinates, table.to.plot, as.character(table.to.plot), pos = 3, cex = cex) }) } } if (any(is.na(x0))) { if (is.factor(x0)) { output0 <- t(t(as.table(summary(x0)))) output1 <- (t(t(table(x0)))) } else { output0 <- t(t(table(x0, exclude = NULL))) output1 <- (t(t(table(x0)))) } percent0 <- output0[, 1]/sum(output0) * 100 percent1 <- output1[, 1]/sum(output1[, 1], na.rm = TRUE) * 100 if (cum.percent) { output <- cbind(output0, round(percent0, decimal), round(cumsum(percent0), decimal), c(round(percent1, decimal), as.integer(0)), round(cumsum(c(percent1, as.integer(0))), decimal)) } else { output <- cbind(output0, round(percent0, decimal), c(round(percent1, decimal), as.integer(0))) } suppressWarnings(if (sort.group == "decreasing") { output <- output[order(output[, 1], decreasing = TRUE), ] }) suppressWarnings(if (sort.group == "increasing") { output <- output[order(output[, 1], decreasing = FALSE), ] }) if (cum.percent) { output <- rbind(output, c(sum(as.integer(output[, 1])), 100, 100, 100, 100)) colnames(output) <- c(.frequency, " %(NA+)", "cum.%(NA+)", " %(NA-)", "cum.%(NA-)") } else { output <- rbind(output, c(sum(as.integer(output[, 1])), 100, 100)) colnames(output) <- c(.frequency, " %(NA+)", " %(NA-)") } rownames(output)[nrow(output)] <- " Total" } else { output <- (t(t(table(x0)))) suppressWarnings(if (sort.group == "decreasing") { output <- output[order(table(x0), names(table(x0)), decreasing = TRUE), ] }) suppressWarnings(if (sort.group == "increasing") { output <- output[order(table(x0), names(table(x0)), decreasing = FALSE), ] }) percent <- output/sum(output) * 100 if (cum.percent) { output <- cbind(output, round(percent, decimal), round(cumsum(percent), decimal)) output <- rbind(output, c(sum(output[, 1]), 100, 100)) colnames(output) <- c(.frequency1, .percent, .cum.percent) } else { output <- cbind(output, round(percent, decimal)) output <- rbind(output, c(sum(output[, 1]), 100)) colnames(output) <- c(.frequency1, .percent) } rownames(output)[length(rownames(output))] <- " Total" } if (substring(search()[2], first = 1, last = 8) != "package:") { options(warn = -1) first.line <- paste(deparse(substitute(x0)), ":", attr(get(search()[2]), "var.labels")[attr(get(search()[2]), "names") == deparse(substitute(x0))], "\n") options(warn = TRUE) } else { first.line <- paste(deparse(substitute(x0)), ":", "\n") } if (gen.ind.vars) { if(!is.factor(x0)) { warning(paste(as.character(substitute(x0)),"is not factor. Indicator variables have not been generated!")) }else{ mod.mat <- model.matrix (~ x0 -1) for (i in 1:ncol(mod.mat)) { assign (paste(deparse(substitute(x0)),substr(colnames(mod.mat)[i],3,nchar(colnames(mod.mat)[i])), sep=""), mod.mat[,i], pos=1) }} } returns <- list(first.line = first.line, output.table = output) class(returns) <- c("tab1", "list") returns } ### Print tab1 results print.tab1 <- function(x, ...) { cat(x$first.line) print(x$output.table, justify="right") } ### recode values of a vector from a lookup array lookup <- function (x, lookup.array) { if (any(table(lookup.array[, 1]) > 1)) { stop("Index value in lookup array not unique!!") } else{ b <- rep("", length(x)) for (i in 1:nrow(lookup.array)) { if(is.na(lookup.array[i,1]) & !is.na(lookup.array[i,2])){ b[is.na(x)] <- lookup.array[i,2] }else{ b[x == lookup.array[i, 1]] <- as.character(lookup.array[i, 2]) } } if(is.numeric(lookup.array)){ x[b != "" & !is.na(b)] <- as.numeric(b[b != "" & !is.na(b)]) }else{ x[b != "" & !is.na(b)] <- (b[b != "" & !is.na(b)]) } x[is.na(b)] <- as.numeric(b[is.na(b)]) xreturn <- x return(xreturn) } } ### Use various file formats use <- function (filename, dataFrame = .data, clear = TRUE, spss.missing = TRUE, tolower = TRUE) { if (clear) { detachAllData() } library(foreign) if (is.character(filename)) { ext <- tolower(substring(filename, first = nchar(filename) - 3, last = nchar(filename))) if (ext == ".dta") { data1 <- read.dta(filename) } else { if (ext == ".dbf") { data1 <- read.dbf(filename) if (tolower) names(data1) <- tolower(names(data1)) } else { if (ext == ".rec") { data1 <- read.epiinfo(filename) if (tolower) names(data1) <- tolower(names(data1)) } else { if (ext == ".sav") { data0 <- read.spss(filename) var.labels <- attr(data0, "variable.labels") data1 <- read.spss(filename, to.data.frame=TRUE, trim.factor.names=TRUE) data1 <- data1[1:nrow(data1), 1:ncol(data1)] attr(data1, "var.labels") <- var.labels if(spss.missing){ for(i in 1:ncol(data1)){ if(!is.null(attr(data0, "missing")[[i]]$value)){ data1[,i] <- ifelse((data1[,i] %in% attr(data0, "missing")[[i]]$value),NA,data1[,i]) } if(!is.null(attributes(data0[[i]])$value.labels)){ data1[,i] <- ifelse((data1[,i] %in% attributes(data0[[i]])$value.labels),NA,data1[,i]) } } } if (tolower) names(data1) <- tolower(names(data1)) } else { if (substring(filename, first = nchar(filename) - 3, last = nchar(filename)) == ".csv") { data1 <- read.csv(filename, header = TRUE, sep = ",") } else { stop("This type of file cannot be 'use'd.") } } } } } } else { if (is.data.frame(filename)) { data1 <- filename } else { stop("The argument is not a data frame or no such file") } } assign(as.character(substitute(dataFrame)), data1, pos = 1) attach(data1, name = as.character(substitute(dataFrame)), warn.conflicts = FALSE) } ### Dot plot dotplot <- function(x, bin="auto", by=NULL, xmin=NULL, xmax=NULL, time.format=NULL, time.step=NULL, pch=18, dot.col="auto", main="auto", ylab="auto", cex.X.axis=1, cex.Y.axis=1, ...){ if(!is.null(by)){ if(length(dot.col)>1 & length(table(factor(by)))!=length(dot.col)){ stop(paste("The argument 'dot.col' must either be \"auto\"","\n"," or number of colours equals to number of categories of 'by'.")) }} if (bin=="auto"){ if(!is.null(attr(max(x, na.rm=TRUE)-min(x, na.rm=TRUE), "units")) & !any(class(x)=="difftime")){ unit1 <- "weeks" bin <- as.numeric(difftime(max(x, na.rm=TRUE), min(x,na.rm=TRUE), units=unit1))+1 while(bin!=trunc(bin)){ if(unit1=="weeks"){ unit1 <- "days" }else if(unit1=="days"){ unit1 <- "hours" }else if(unit1=="hours"){ unit1 <- "mins" }else if(unit1=="mins") unit1 <- "secs" bin <- as.numeric(difftime(max(x, na.rm=TRUE), min(x,na.rm=TRUE), units=unit1))+1 } }else{ if(is.integer(x)){ bin <- as.integer(max(x, na.rm=TRUE)- min(x, na.rm=TRUE) +1) }else{ if(any(class(x)=="Date")){ bin <- as.numeric(difftime(max(x, na.rm=TRUE), min(x,na.rm=TRUE), units=unit1))+1 }else{ bin <- 40 }}}} character.x <- deparse(substitute(x)) if (is.null(by)){ value <- subset(x, !is.na(x)) }else{ data1 <- data.frame(by) data1$x <- x data2 <- subset(data1,!is.na(x) & !is.na(by)) value <- data2$x by0 <- data2$by rm(data1, data2) } if (any(class(x)=="difftime")){ unit.value <- attr(x, "units") value <- as.numeric(value) } if(any(class(x)=="POSIXt")){ value <- as.numeric(value) } if(any(class(x)=="Date")){ value <- as.numeric(value) } if(is.integer(x)) { xgr <- value }else{ xgr <- cut(value, breaks=bin, labels=FALSE, include.lowest=TRUE) } if(!is.null(xmax) & !is.null(xmin)){ original.lim <- c(min(value), max(value)) xgr.lim <- c(min(xgr), max(xgr)) lm00 <- lm(xgr.lim ~ original.lim) newdata <- data.frame(original.lim=as.numeric(c(xmin, xmax))) xgr1 <- predict.lm(lm00, newdata ) } xgr <- as.numeric(xgr) string2 <- ifelse ((character.x[1]=="$" | character.x[1]==":"),paste(character.x[2],character.x[1],character.x[3],sep=""), character.x) byname <- deparse(substitute(by)) if(substring(search()[2],first=1,last=8)!="package:"){ string2 <- attr(.data, "var.labels")[attr(.data,"names")==string2] byname <- attr(.data, "var.labels")[attr(.data, "names")==deparse(substitute(by))] if(length(string2)==0){ string2 <- ifelse ((character.x[1]=="$" | character.x[1]==":"),paste(character.x[2],character.x[1],character.x[3],sep=""), character.x) } if(length(byname)==0){ byname <- deparse(substitute(by)) }else{ if(byname==""){byname <- deparse(substitute(by))} } if(string2==""){ string2 <- ifelse ((character.x[1]=="$" | character.x[1]==":"),paste(character.x[2],character.x[1],character.x[3],sep=""), character.x) } } string3 <- paste(titleString()$distribution.of,string2) value.pretty <- pretty(value) if(exists("xgr1")){ value.pretty <- pretty(c(xmin,xmax)) } if(any(class(x)=="Date")) { range.date <- difftime(summary(x)[6], summary(x)[1]) if(exists("xgr1")) {range.date <- difftime(xmax, xmin)} min.date <- summary(x)[1] if(exists("xgr1")) {min.date <- xmin} max.date <- summary(x)[6] if(exists("xgr1")) {max.date <- xmax} numdate <- (range.date) if(numdate <1){stop(paste("Only one day ie.",format(x,"%Y-%m-%d"),"not suitable for plotting"))} if(numdate <10){date.pretty <- seq(from=min.date,to=max.date,by="day"); format.time <- "%a%d%b"} if(numdate >=10 & numdate <30){date.pretty <- seq(from=min.date,to=max.date,by="2 day"); format.time <- "%d%b"} if(numdate >=30 & numdate <60){date.pretty <- seq(from=min.date,to=max.date,by="week"); format.time <- "%a %d"} if(numdate >=60 & numdate <700){date.pretty <- seq(from=min.date,to=max.date,by="month"); format.time <- "%d%b'%y"} if(numdate >=700){date.pretty <- seq(from=min.date,to=max.date,by="year") format.time <- "%d%b'%y"} if(!is.null(time.format)){format.time <- time.format} if(!is.null(time.step)){date.pretty <- seq(from=min.date,to=max.date,by=time.step)} value.pretty <- as.numeric(date.pretty) } if(any(class(x)=="POSIXt")){ range.time <- difftime(summary(x)[6],summary(x)[1]) if(exists("xgr1")) {range.time <- difftime(xmax, xmin)} min.time <- summary(x)[1] if(exists("xgr1")) {min.time <- xmin} max.time <- summary(x)[6] if(exists("xgr1")) {max.time <- xmax} numeric.time <- as.numeric(range.time) units <- attr(range.time, "units") if(units=="secs") {step <- "sec"; format.time <- "%M:%S"; scale.unit <- "min:sec"} if(units=="mins") {step <- "min"; format.time <- "%H:%M"; scale.unit <- "HH:MM"} if(units=="hours") {step <- ifelse(numeric.time<2,"20 mins","hour");format.time <- "%H:%M"; scale.unit <- "HH:MM"} if(units=="days") { if(numeric.time <2){ step <- "6 hour"; format.time <- "%a %H:%M"; scale.unit <- "HH:MM" }else{ step <- "day"; format.time <- "%d%b%y"; scale.unit <- "Date" } } if(units=="weeks") {step <- "week";format.time <- "%b%y"; scale.unit <- " "} if(!is.null(time.format)){format.time <- time.format} if(!is.null(time.step)){step <- time.step} time.pretty <- seq(from=min.time,to=max.time,by=step) value.pretty <- as.numeric(time.pretty) } xlim <- c(min(xgr),max(xgr)) value.lim <- c(min(value), max(value)) if(exists("xgr1")) { xlim <- c(min(xgr1),max(xgr1)) value.lim <- as.numeric(c(xmin, xmax)) } glm(xlim~value.lim)->model1 xgr.pretty <- model1$coefficient[1] + model1$coefficient[2]*value.pretty if(is.null(by)){ if(dot.col=="auto") dot.col <- "black" xgr <- sort(xgr) freq <- rep(1, length(value)) for(i in min(xgr):max(xgr)){ freq[xgr==i] <- 1:sum(xgr==i) } if(max(freq)<20){ plot(xgr,freq, xaxt="n", xlab=" ",main=ifelse(main=="auto",string3,main), ylab=ifelse(ylab=="auto",titleString()$frequency, ylab), ylim=c(0,20), xlim = xlim, pch=pch, col=dot.col[1], ...) }else{ plot(xgr,freq, xaxt="n", xlab=" ",main=ifelse(main=="auto",string3,main), ylab=ifelse(ylab=="auto",titleString()$frequency, ylab), xlim = xlim, pch=pch, col=dot.col[1], ...) } }else{ order1 <- order(by0,value) xgr <- xgr[order1] value <-value[order1] by1 <- factor(by0) by1 <- by1[order1] if(is.factor(by0)){ character.length <- ifelse(max(nchar(levels(by0)))>8, max(nchar(levels(by0)))*(60-max(nchar(levels(by0))))/60, max(nchar(levels(by0)))*1.2) left.offset <- max(c(0.76875+.2, .1+par()$cin[1]*character.length)) par(mai=c(0.95625, left.offset, 0.76875, 0.39375)) } y <- rep(0, length(value)) add.i <- 0 yline <- NULL for(i in 1:length(levels(by1))){ yline <- c(yline, add.i) col.j <- NULL for(j in min(xgr[by1==levels(by1)[i]]):max(xgr[by1==levels(by1)[i]])){ y[xgr==j & by1==(levels(by1))[i]] <- (1:sum(xgr==j & by1==(levels(by1))[i])) + add.i } add.i <- max(y, na.rm=TRUE) +2 } main.lab <- ifelse(main=="auto",paste(string3,titleString()$by,byname), main) if(nchar(main.lab)>45){main.lab <- paste(string3,"\n",titleString()$by,byname)} if(any(dot.col=="auto")){ dot.col1 <- as.numeric(by1) }else{ tx <- cbind(1:length(dot.col), dot.col) dot.col1 <- lookup(as.numeric(by1), tx) } if(max(y)<20){ plot(xgr,y, xaxt="n", yaxt="n", xlab=" ",main=main.lab, ylim=c(-1,20), ylab=" ", col=dot.col1, pch=pch, xlim=xlim, ...) }else{ plot(xgr,y, xaxt="n", yaxt="n", xlab=" ",main=main.lab, ylim=c(-1,max(y)), ylab=" ", col=dot.col1, pch=pch, xlim=xlim, ...) } abline(h=yline, col="blue") axis(2,at=yline, labels=levels(by1), padj=0, las=1, cex.axis=cex.Y.axis) par(mai=c(0.95625, 0.76875, 0.76875, 0.39375)) } if(any(class(x)=="POSIXct")){ axis(side=1, at=xgr.pretty, labels=as.character(time.pretty,format=format.time), cex.axis=cex.X.axis) title(xlab=scale.unit) } if(any(class(x)=="difftime")){ axis(side=1,at=xgr.pretty, labels=value.pretty, cex.axis=cex.X.axis) title(xlab=unit.value) } if(any(class(x)=="Date")){ axis(side=1,at=xgr.pretty, labels=as.character(format(value.pretty+as.Date("1970-01-01"), format.time)), cex.axis=cex.X.axis) } if(any(class(x)=="numeric") || any(class(x)=="integer")){ axis(side=1,at=xgr.pretty, labels=value.pretty, cex.axis=cex.X.axis) } } ### Labeling variables label.var <-function(var, label, pack=TRUE, dataFrame = .data){ # Store list of variable labels, #if exist, in a temporary vector data1 <- dataFrame if(any(names(data1)==as.character(substitute(var)))){ if(is.null(attributes(data1)$var.labels)){ attributes(data1)$var.labels <- rep("", length(names(data1))) } attributes(data1)$var.labels[names(data1)==as.character(substitute(var))] <- label }else{ if(length(var) != nrow(dataFrame)){ stop(paste("The length of", as.character(substitute(var)), "is not equal to number of rows of", as.character(substitute(dataFrame)))) } old.labels <-attributes(data1)$var.labels data1[,ncol(data1)+1]<- var names(data1)[length(names(data1))] <- as.character(substitute(var)) if(is.null(old.labels)){ attributes(data1)$var.labels <- c(rep("", length(names(data1))-1),label) }else{ attributes(data1)$var.labels <- c(old.labels,label) } } if(exists(as.character(substitute(var)))){ if(!is.atomic(var)){ stop(paste("A non-variable object", as.character(substitute( var)),"exists in the environment and cannot be labelled.","\n", " If this variable in the data frame is to be labelled,","\n", " either the non-variable object of this name must be removed before labelling","\n", "\n", paste(" rm(",as.character(substitute( var)),")","; ", " label.var(", as.character(substitute(var)),", \"", as.character(substitute(label)),"\")",sep=""),"\n", "\n", " or the variable in the data frame must be prior renamed","\n", "\n", paste(" ren(", as.character(substitute( var)),", newname)", "; ", " label.var(newname,\"", as.character(substitute(label)),"\")", sep=""), "\n")) } if(length(var)==nrow(dataFrame)){ data1[,names(data1)==as.character(substitute(var))] <- var }else{ stop(paste("The length of", as.character(substitute(var)), "is not equal to number of rows of", as.character(substitute(dataFrame)))) } } if(pack){ suppressWarnings(rm(list=as.character(substitute(var)), pos=1)) } assign(as.character(substitute(dataFrame)), data1, pos=1) if(is.element(as.character(substitute(dataFrame)), search())){ if(length(which(search() %in% as.character(substitute(dataFrame))))>1){ warning(paste("\n","There are more than one '", as.character(substitute(dataFrame)),"' attached!","\n", sep="")) } detach(pos=which(search() %in% as.character(substitute(dataFrame)))[1]) attach(data1, name=as.character(substitute(dataFrame)), warn.conflicts = FALSE) } } ### Recoding a variable or set of variables for the same final value recode <- function(vars, ...){ UseMethod("recode") } recode.default <- function (vars, old.value, new.value, dataFrame = .data, ...) { data1 <- dataFrame nl <- as.list(1:ncol(data1)) names(nl) <- names(data1) var.order <- eval(substitute(vars), nl, parent.frame()) if(all(var.order < 0)) var.order <- (1:ncol(dataFrame))[var.order] if (exists(names(data1)[var.order], where = 1, inherits = FALSE)) warning("Name(s) of vars duplicates with an object outside the dataFrame.") tx <- cbind(old.value, new.value) if (is.numeric(old.value) | is.integer(old.value) | any(class(data1[, var.order]) == "POSIXt")) { if (length(old.value) == 1) { if(all(is.integer(data1[, var.order]))){ data1[, var.order][data1[, var.order] == old.value] <- as.integer(new.value) }else{ data1[, var.order][data1[, var.order] == old.value] <- new.value } } else { if (length(old.value) != length(new.value) & length(new.value) != 1) stop("Lengths of old and new values are not equal") for (i in var.order) { if(is.integer(data1[,i])){ data1[, i] <- as.integer(lookup(data1[, i, drop = TRUE], tx)) }else{ data1[, i] <- lookup(data1[, i, drop = TRUE], tx) } } } } else for (i in var.order) { if (is.factor(data1[, i])) { if (length(old.value) != length(new.value) & length(new.value) != 1) stop("Lengths of old.value and new.value are not equal") if (is.character(old.value)) { if (any(!is.element(old.value, levels(data1[, i])))) warning(paste("The old.value is/are not element of levels of '", names(data1)[i], "'", sep = "")) for (j in 1:nrow(tx)) { levels(data1[, i])[levels(data1[, i]) == tx[j, 1]] <- tx[j, 2] } } } if (is.character(data1[, i])) { if (length(old.value) == 1) { data1[, var.order][data1[, var.order] == old.value] <- new.value } else { if (length(old.value) != length(new.value) & length(new.value) != 1) stop("Lengths of old and new values are not equal") data1[, i] <- lookup(data1[, i, drop = TRUE], tx) } } } if (length(old.value) == nrow(data1)) { if (length(var.order) == 1) { data1[, var.order] <- replace(data1[, var.order], old.value, new.value) } else { for (i in 1:length(var.order)) { data1[, var.order[i]] <- replace(data1[, var.order[i]], old.value, new.value) } } } assign(as.character(substitute(dataFrame)), data1, pos = 1) if (is.element(as.character(substitute(dataFrame)), search())) { detach(pos = which(search() %in% as.character(substitute(dataFrame)))) attach(data1, name = as.character(substitute(dataFrame)), warn.conflicts = FALSE) } } # For 'recode'ing missing values of one or more variables into a new value recode.is.na <- function (vars, new.value=0, dataFrame = .data, ...){ data1 <- dataFrame nl <- as.list(1:ncol(data1)) names(nl) <- names(data1) var.order <- eval(substitute(vars), nl, parent.frame()) if (exists(names(data1)[var.order], where = 1, inherits = FALSE)) warning("Name(s) of vars duplicates with an object outside the dataFrame.") for (i in var.order) { temp.vector <- data1[, i, drop=TRUE] if (is.factor(temp.vector)){ levels(temp.vector) <- c(levels(temp.vector), new.value) } temp.vector[is.na(temp.vector)] <- new.value temp.vector -> data1[, i] } assign(as.character(substitute(dataFrame)), data1, pos = 1) if (is.element(as.character(substitute(dataFrame)), search())) { detach(pos = which(search() %in% as.character(substitute(dataFrame)))) attach(data1, name = as.character(substitute(dataFrame)), warn.conflicts = FALSE) } } ### Multinomial summary display mlogit.display <- function(multinom.model, decimal=2, alpha=.05) { s <- summary(multinom.model) z <- s$coefficients/s$standard.errors pnorm.z <- pnorm(z) pgroup <- cut(pnorm.z, c(0,0.0005,0.005,0.025,0.975, 0.995, 0.9995,1)) stars <-c("***","**","*","","*","**","***") x <-paste(round(s$coefficients,decimal),"/",round(s$standard.errors,decimal+1),stars[pgroup], sep="") dim(x) <- dim(z) colnames(x) <- colnames(s$coefficients) rownames(x) <- rownames(s$coefficients) x1 <- t( x) x2 <- t(exp(s$coefficients)) x2 <- round(x2,decimal) x2.1 <- t(exp(s$coefficients-qnorm(1-alpha/2)*s$standard.errors)) x2.1 <- round(x2.1,decimal) x2.2 <- t(exp(s$coefficients+qnorm(1-alpha/2)*s$standard.errors)) x2.2 <- round(x2.2,decimal) x2 <- paste(x2,"(", x2.1, ",", x2.2, ")", sep="") dim(x2) <- dim(x1) x2[1,] <- "-" x3 <- cbind(x1[,1],x2[,1]) for(i in 2: (length(s$lab)-1)){x3 <- cbind(x3, cbind(x1[,i],x2[,i]))} x4 <- rbind(c("Coeff./SE",paste("RRR(",100-100*alpha,"%CI) ",sep=""),"Coeff./SE",paste("RRR(",100-100*alpha,"%CI) ",sep="")),x3) colnames.x4 <- c(s$lab[2],"") for(i in 3:(length(s$lab))){colnames.x4 <- c(colnames.x4,c(s$lab[i],""))} colnames(x4) <- colnames.x4 rownames(x4) <- c("",s$coefnames) cat("\n") cat(paste("Outcome =",as.character(s$term)[2],"; ","Referent group = ",s$lab[1],sep=""), "\n") print.noquote(x4) cat("\n") cat("Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ", "\n") cat("\n") cat(paste("Residual Deviance:", round(s$deviance,decimal), "\n")) cat(paste("AIC =", round(s$AIC,digits=decimal), "\n")) cat("\n") } ### Zap zap <- function () { detachAllData() vector1 <- setdiff(ls(envir = .GlobalEnv), lsf.str(envir = .GlobalEnv)[]) rm(list = vector1, pos = 1) } ### Pyramid of age by sex pyramid <- function (age, sex, binwidth = 5, inputTable = NULL, printTable = FALSE, percent = c("none", "each", "total"), col.gender = NULL, bar.label = "auto", decimal = 1, col = NULL, cex.bar.value = .8, cex.axis =1, main = "auto", cex.main = 1.2,...) { if(!is.null(col.gender)){ if(length(col.gender) != 2) stop("Argument 'col.gender' must be two colours or NULL.") } if(length(percent) == 3) { percent <- "none" if(bar.label == "auto"){ bar.label <- FALSE } } if (is.null(inputTable)) { agegr <- cut(age, br = ((min(age, na.rm = TRUE)%/%binwidth):(max(age, na.rm = TRUE)%/%binwidth + (max(age, na.rm = TRUE)%%binwidth > 0)) * binwidth), include.lowest = TRUE) age.sex.table <- table(agegr, sex, deparse.level = 1, dnn = list(substitute(age), substitute(sex))) if (ncol(table(agegr, sex)) != 2) stop("There must be two genders") age.sex.table.dimnames <- names(attr(age.sex.table, "dimnames")) } else { if (is.matrix(inputTable) | is.table(inputTable)) { age.sex.table <- inputTable age.sex.table.dimnames <- names(attr(inputTable, "dimnames")) } } par(mfrow = c(1, 2)) old.par.mai <- c(0.95625, 0.76875, 0.76875, 0.39375) left.par.mai <- old.par.mai right.par.mai <- c(old.par.mai[1], old.par.mai[4], old.par.mai[3], old.par.mai[2]) column.names <- colnames(age.sex.table) if (percent == "each") { if(bar.label == "auto"){ bar.label <- TRUE } age.sex.table <- cbind(age.sex.table[, 1]/colSums(age.sex.table)[1] * 100, age.sex.table[, 2]/colSums(age.sex.table)[2] * 100) colnames(age.sex.table) <- column.names age.sex.table1 <- round(age.sex.table, digits = decimal) table.header <- "(percentage of each gender)." } if (percent == "total") { if(bar.label == "auto"){ bar.label <- TRUE } age.sex.table <- cbind(age.sex.table[, 1]/sum(age.sex.table), age.sex.table[, 2]/sum(age.sex.table)) * 100 colnames(age.sex.table) <- column.names age.sex.table1 <- round(age.sex.table, digits = decimal) table.header <- "(percentage of total population)." } if(!is.null(col.gender)){ col.1 <- col.gender[1]; col.2 <- col.gender[2] }else{ col.1 <- col ; col.2 <- col } par(mai = left.par.mai) label.points.left <- barplot(-age.sex.table[, 1], horiz = TRUE, yaxt = "n", xlab = colnames(age.sex.table)[1], xlim = c(-max(age.sex.table)*1.3, 0), xaxt = "n", col = col.1, ...) if(bar.label){ if(!any(percent == "none")){ text(y = label.points.left, x = - age.sex.table[,1], labels = round(age.sex.table[,1],1), pos = 2, cex = cex.bar.value) }else{ text(y = label.points.left, x = - age.sex.table[,1], labels = age.sex.table[,1], pos = 2, cex = cex.bar.value) }} axis(side = 1, at = pretty(c(-max(age.sex.table), 0)), labels = -pretty(c(-max(age.sex.table), 0)), cex.axis = cex.axis) par(mai = right.par.mai) label.points.right <- barplot(age.sex.table[, 2], horiz = TRUE, xlab = colnames(age.sex.table)[2], xlim = c(0, max(age.sex.table)*1.3), las = 1, cex.axis = cex.axis, col = col.2, ...) if(bar.label){ if(!any(percent == "none")){ text(y = label.points.right, x = age.sex.table[,2], labels = round(age.sex.table[,2],1), pos = 4, cex = cex.bar.value) }else{ text(y = label.points.right, x = age.sex.table[,2], labels = age.sex.table[,2], pos = 4, cex = cex.bar.value) }} par(mfrow = c(1, 1)) par(mai = old.par.mai) if(!is.null(main)){ if(main=="auto"){ if(percent == "none") main.lab <- "frequency" if(percent == "each") main.lab <- "percentage of each gender" if(percent == "total") main.lab <- "percentage of total population" title(main = paste("Population pyramid in", main.lab), cex.main = cex.main) }else{ title(main = main) }} if (printTable & is.null(inputTable)) { cat("\n", "Tabulation of age by sex ") if (!exists("age.sex.table1")) { table.header <- "(frequency)." age.sex.table1 <- age.sex.table } cat(table.header, "\n") print.noquote(age.sex.table1) cat("\n") } if (is.null(inputTable)) { returns <- list(output.table = age.sex.table, ageGroup = agegr) } } ## Followup plot followup.plot <- function (id, time, outcome, by = NULL, n.of.lines = NULL, legend = TRUE, legend.site = "topright", lty = "auto", line.col = "auto", stress = NULL, stress.labels = FALSE, label.col = 1, stress.col = NULL, stress.width = NULL, stress.type = NULL, lwd = 1, xlab, ylab, ...) { if (missing(xlab)) { xlab <- as.character(substitute(time)) if (any(class(get(search()[2])) == "data.frame")) { if (any(attr(get(search()[2]), "names") == as.character(substitute(xlab)))) { if (!is.null(attr(get(search()[2]), "var.labels")[attr(get(search()[2]), "names") == as.character(substitute(xlab))])) { if(attr(get(search()[2]), "var.labels")[attr(get(search()[2]), "names") == as.character(substitute(xlab))] !="" ){ xlab <- attr(get(search()[2]), "var.labels")[attr(get(search()[2]), "names") == as.character(substitute(xlab))] }} } } } if (missing(ylab)) { ylab <- as.character(substitute(outcome)) if (any (class(get(search()[2])) == "data.frame")) { if (any(attr(get(search()[2]), "names") == as.character(substitute(ylab)))) { if (!is.null(attr(get(search()[2]), "var.labels")[attr(get(search()[2]), "names") == as.character(substitute(ylab))])) { if(attr(get(search()[2]), "var.labels")[attr(get(search()[2]), "names") == as.character(substitute(ylab))] !="" ){ ylab <- attr(get(search()[2]), "var.labels")[attr(get(search()[2]), "names") == as.character(substitute(ylab))] }} } } } plot(time, outcome, xlab = xlab, ylab = ylab, type = "n", lwd = lwd, ...) if (any(lty == "auto")) lty <- rep(1, length(id)) id1 <- id time1 <- time by1 <- by outcome1 <- outcome if (is.null(n.of.lines)) { if (!is.null(by)) { id <- id[order(id1, time1, by1)] id.factor <- factor(id) time <- time[order(id1, time1, by1)] outcome <- outcome[order(id1, time1, by1)] by <- by[order(id1, time1, by1)] by.factor <- factor(by) if (any(line.col == "auto")) { line.col <- 1:length(levels(by.factor)) } for (i in 1:length(levels(by.factor))) { for (j in 1:length(levels(id.factor))) { lines(time[id.factor == levels(id.factor)[j] & by.factor == levels(by.factor)[i]], outcome[id.factor == levels(id.factor)[j] & by.factor == levels(by.factor)[i]], col = line.col[i], lty = i, lwd = lwd) } } if (legend) { legend(x = legend.site, legend = levels(factor(by)), col = line.col, bg = "white", lty = 1:length(levels(factor(by))), lwd = lwd) } } else { id <- id[order(id1, time1)] id.factor <- factor(id) time <- time[order(id1, time1)] outcome <- outcome[order(id1, time1)] if (length(levels(factor(id))) < 8) { if (any(line.col == "auto")) line.col <- 1:length(levels(id.factor)) for (j in 1:length(levels(id.factor))) { lines(time[id.factor == levels(id.factor)[j]], outcome[id.factor == levels(id.factor)[j]], col = line.col[j], lwd = lwd, lty = lty[j]) } if (legend) { legend(x = legend.site, legend = levels(factor(id[order(id1)])), col = line.col[1:length(levels(factor(id)))], bg = "white", lty = lty, lwd = lwd) } } else { for (j in 1:length(levels(id.factor))) { if (any(line.col == "multicolor")) { lines(time[id.factor == levels(id.factor)[j]], outcome[id.factor == levels(id.factor)[j]], col = j, lwd = lwd) } else { if (any(line.col == "auto")) line.col <- "blue" lines(time[id.factor == levels(id.factor)[j]], outcome[id.factor == levels(id.factor)[j]], col = line.col, lwd = lwd) } } } } } else { order.id.selected <- sample(c(rep(TRUE, n.of.lines), rep(FALSE, length(levels(factor(id))) - n.of.lines))) if (!is.null(by)) { id <- id[order(id1, time1, by1)] time <- time[order(id1, time1, by1)] outcome <- outcome[order(id1, time1, by1)] by <- by[order(id1, time1, by1)] id.factor <- factor(id) by.factor <- factor(by) if (any(line.col == "auto")) line.col <- 1:length(levels(by.factor)) for (i in 1:length(levels(by.factor))) { for (j in 1:length(levels(id.factor))) { lines(time[id.factor == levels(id.factor)[j] & by.factor == levels(by.factor)[i]] * order.id.selected[j], outcome[id.factor == levels(id.factor)[j] & by.factor == levels(by.factor)[i]] * order.id.selected[j], col = line.col[i], lty = i, lwd = lwd) } } if (legend) { legend(x = legend.site, legend = levels(factor(by)), col = line.col[1:length(levels(factor(by)))], lty = 1:length(levels(factor(by))), bg = "white", lwd = lwd) } } else { id <- id[order(id1, time1)] id.factor <- factor(id) time <- time[order(id1, time1)] outcome <- outcome[order(id1, time1)] for (j in 1:length(levels(id.factor))) { if (any(line.col == "multicolor")) { lines(time[id.factor == levels(id.factor)[j]] * order.id.selected[j], outcome[id.factor == levels(id.factor)[j]] * order.id.selected[j], col = j, lwd = lwd) } else { if (any(line.col == "auto")) { line.col <- "blue" } lines(time[id.factor == levels(id.factor)[j]] * order.id.selected[j], outcome[id.factor == levels(id.factor)[j]] * order.id.selected[j], col = line.col, lwd = lwd) } } } } for (j in 1:length(levels(id.factor))) { text(time[id.factor == levels(id.factor)[j]], outcome[id.factor == levels(id.factor)[j]], labels = j, col = any(stress.labels * stress %in% j) * label.col) } for (j in 1:length(levels(id.factor))) { lines(time[id.factor == levels(id.factor)[j]], outcome[id.factor == levels(id.factor)[j]], col = any(stress %in% j) * stress.col, lwd = stress.width, lty = stress.type) } } ## Subsetting .data keepData <- function (dataFrame = .data, sample = NULL, exclude = NULL, subset, select, drop = FALSE, refactor = c("subset.vars", "all", "none"), ...) { dataName <- as.character(substitute(dataFrame)) data1 <- dataFrame datalabel <- attr(data1, "datalabel") val.labels <- attr(data1, "val.labels") var.labels <- attr(data1, "var.labels") label.table <- attr(data1, "label.table") if (!is.null(sample)) { if (!is.numeric(sample) | sample <= 0 | length(sample) > 1 | (trunc(sample) != sample) & sample > 1) { stop("Size of sample must be a positive integer") } if (sample < 1) { sample0 <- sample sample <- trunc(sample * nrow(data1)) cat("Keep only ", round(sample0 * 100, 2), "% or ", sample, " of the total ", nrow(data1), " records", "\n", sep = "") } dataFrame <- dataFrame[sample(nrow(dataFrame), sample), ] data1 <- dataFrame attr(data1, "datalabel") <- paste(datalabel, "(subset)") attr(data1, "val.labels") <- val.labels attr(data1, "var.labels") <- var.labels attr(data1, "label.table") <- label.table } if (missing(subset)) r <- TRUE else { e <- substitute(subset) r <- eval(e, dataFrame, parent.frame()) if (!is.logical(r)) stop("'subset' must evaluate to logical") r <- r & !is.na(r) } if (missing(select)) { vars <- TRUE if (suppressWarnings(!is.null(exclude))) { nl <- as.list(1:ncol(dataFrame)) names(nl) <- names(dataFrame) if ((length(grep(pattern = "[*]", as.character(substitute(exclude)))) == 1) | (length(grep(pattern = "[?]", as.character(substitute(exclude)))) == 1)) { vars <- -grep(pattern = glob2rx(as.character(substitute(exclude))), names(dataFrame)) if (length(vars) == 0) { stop(paste(as.character(substitute(exclude)), "not matchable with any variable name.")) } } else { vars <- -eval(substitute(exclude), nl, parent.frame()) } } } else { nl <- as.list(1:ncol(dataFrame)) names(nl) <- names(dataFrame) if ((length(grep(pattern = "[*]", as.character(substitute(select)))) == 1) | (length(grep(pattern = "[?]", as.character(substitute(select)))) == 1)) { vars <- grep(pattern = glob2rx(as.character(substitute(select))), names(dataFrame)) if (length(vars) == 0) { stop(paste(select, "not matchable with any variable name.")) } } else { vars <- eval(substitute(select), nl, parent.frame()) } } data1 <- dataFrame[r, vars, drop = drop] attr(data1, "datalabel") <- paste(datalabel, "(subset)") attr(data1, "val.labels") <- val.labels[vars] attr(data1, "var.labels") <- var.labels[vars] attr(data1, "label.table") <- label.table[is.element(names(label.table), val.labels[vars])] if(length(refactor)==3) refactor <- "subset.vars" if(!missing(subset) & refactor == "all") { for(i in 1:ncol(data1)) { if(class(data1[,i]) == "factor") { data1[,i] <- factor(data1[,i]) } } } if(!missing(subset) & refactor == "subset.vars") { for(i in 1:ncol(data1)) { if(length(grep(names(data1)[i], deparse(substitute(subset)))) >0 & class(data1[,i]) == "factor") { data1[,i] <- factor(data1[,i]) } } } assign(dataName, data1, pos = 1) if (is.element(dataName, search())) { detach(pos = which(search() %in% dataName)) attach(data1, name = dataName, warn.conflicts = FALSE) } } ## Adjusted mean, proportion and rate adjust <- function(adjust = NULL, by, model, standard=NULL, offset=FALSE, type = c("response", "link"), se.fit=TRUE, alpha=.05, ci=FALSE, ...){ if(length(type)==2) type <- "response" if(missing(by)) stop ("'by' variable(s) missing!") if(!any(class(model)=="glm") & !any(class(model)=="lm")) stop("Model must be in class 'lm' or 'glm'") nl <- as.list(1:ncol(model$model)) names(nl) <- names(model$model) by.vars <- as.numeric(eval(substitute(by), envir=nl, enclos=parent.frame())) adjust.vars <- eval(substitute(adjust), nl, parent.frame()) mod <- model.matrix(model) if(length(grep("offset", names(model$model)))> 0 ){ mod <- data.frame(model.matrix(model),model$model[,ncol(model$model)]) names(mod) <- c(colnames(model.matrix(model)),"offset1") } newdata0 <- aggregate.data.frame(mod, by=as.list(model$model)[by.vars], FUN="mean") if(length(grep("offset", names(model$model)))> 0 ){ if(!offset) { newdata0$offset1 <- 0 }else{ persontime <- exp(model$model[,ncol(model$model)]) newdata0$offset1 <- log(aggregate.numeric(persontime,by=as.list(model$model)[by.vars],FUN="mean")$mean.persontime) } } means <- apply(mod,2,mean) if(!is.null(adjust)){ selected.names <- names(model$model)[adjust.vars] for(i in 1:length(selected.names)){ j0 <- grep(selected.names[i], names(newdata0)) j1 <- grep(selected.names[i], names(means)) for(k in 1:length(j0)){ newdata0[,j0[k]] <- means[j1[k]] } } } data.for.new.glm <- data.frame(model$model[,1], model.matrix(model)[,-1]) names(data.for.new.glm)[-1] <- colnames(model.matrix(model))[-1] names(data.for.new.glm)[1] <- "y" offset1 <- model$offset newglm <- glm(y ~., data=data.for.new.glm, family=as.character(model$family)[1]) if(length(grep("offset", names(model$model)))> 0 ){ newglm <- glm(y ~., offset= offset1, family=as.character(model$family)[1],data=data.for.new.glm ) } newdata1 <- newdata0[,(ncol(newdata0)-(ncol(data.for.new.glm)-2)):ncol(newdata0)] if(length(grep("offset", names(model$model)))> 0 ){ newdata1 <- newdata0[,(ncol(newdata0)-(ncol(data.for.new.glm)-1)):ncol(newdata0) ] } if(!is.null(standard)){ if(length(standard)!=length(newglm$coefficient)-1){stop("In appropriate length of standard value(s) for predictor(s)")} for(i in 1:length(standard)){ if(!is.na(standard[i])){newdata1[,i] <- standard[i]} } } result.gold <- as.data.frame(predict.glm(newglm,newdata=newdata1, type="link", se.fit)[c(1,2)]) result0 <- predict.glm(newglm,newdata=newdata1, type, se.fit)[c(1,2)] result <- data.frame(newdata0[,1:length(by.vars)], as.data.frame(result0)) names(result)[1:length(by.vars)] <- names(model$model)[by.vars] if(!se.fit) names(result)[length(names(result))] <- "fit" if(as.character(model$family[1])=="binomial" & type=="response") { result$se.fit <- NULL names(result)[ncol(result)] <- "probability" if(ci){ result$ul <- result.gold[,1] - qnorm(1-alpha/2)* result.gold[,2] result$ul <- exp(result$ul)/(1+exp(result$ul)) result$ll <- result.gold[,1] + qnorm(1-alpha/2)* result.gold[,2] result$ll <- exp(result$ll)/(1+exp(result$ll)) names(result)[c(ncol(result)-1, ncol(result))] <- c(paste("lower",100-100*alpha,"ci",sep=""),paste("upper",100-100*alpha,"ci",sep="")) } } if(as.character(model$family[1])=="poisson" & type=="response") { result$se.fit <- NULL if(!offset){ names(result)[ncol(result)] <- "rate" }else{ names(result)[ncol(result)] <- "count" } if(ci){ result$ul <- result.gold[,1] - qnorm(1-alpha/2)* result.gold[,2] result$ul <- exp(result$ul) result$ll <- result.gold[,1] + qnorm(1-alpha/2)* result.gold[,2] result$ll <- exp(result$ll) names(result)[c(ncol(result)-1, ncol(result))] <- c(paste("lower",100-100*alpha,"ci",sep=""),paste("upper",100-100*alpha,"ci",sep="")) } } if(as.character(model$family[1])=="gaussian" & type=="response") { names(result)[names(result)=="fit"] <- "mean" names(result)[names(result)=="se.fit"] <- "se.mean" } if(ci & (type=="link"| as.character(model$family[1])=="gaussian") & se.fit){ result$ul <- result[,ncol(result)-1] - qnorm(1-alpha/2)* result[,ncol(result)] result$ll <- result[,ncol(result)-2] + qnorm(1-alpha/2)* result[,ncol(result)-1] names(result)[c(ncol(result)-1, ncol(result))] <- c(paste("lower",100-100*alpha,"ci",sep=""),paste("upper",100-100*alpha,"ci",sep="")) } result } ## Aggregate a numeric variable aggregate.numeric <- function (x, by, FUN = c("count", "sum", "mean", "median", "sd", "se", "min", "max"), na.rm = TRUE, length.warning = TRUE, ...) { count <- function(x1) { length(na.omit(x1)) } se <- function(x1) { sd(x1, na.rm = TRUE)/sqrt(count(x1)) } if (length(FUN) == 1 & class(FUN) == "function") { FUN <- as.character(substitute(FUN)) } else { if (any(is.na(x)) & na.rm == FALSE & (is.element("var", FUN) | is.element("sd", FUN))) { cat(paste("\n", " 'FUN = \"var\"' and 'FUN = \"sd\" not computable when 'na.rm=FALSE'", "\n", " and therefore omitted"), "\n", "\n") FUN <- setdiff(FUN, c("sd", "var")) } if (length(FUN) == 0) { stop("Too few FUN's") } if (any(is.na(x)) & length.warning & na.rm) { if (any(FUN == "var") | any(FUN == "sd") | any(FUN == "mean") | any(FUN == "sum")) { cat("\n", "Note:", "\n", " Missing values removed.", "\n") } if (any(FUN == "length")) { cat(" 'length' computed with missing records included.", "\n") } cat("\n") } } if (FUN[1] != "length") { if (FUN[1] == "count") { y <- aggregate.data.frame(x, by, FUN = count) names(y)[length(names(y))] <- paste("count", as.character(deparse(substitute(x))), sep = ".") } else { if (FUN[1] == "sum" | FUN[1] == "mean" | FUN[1] == "median" | FUN[1] == "var" | FUN[1] == "sd" | FUN[1] == "min" | FUN[1] == "max") { y <- aggregate.data.frame(x, by, FUN = FUN[1], na.rm = na.rm) } else { y <- aggregate.data.frame(x, by, FUN = FUN[1]) } names(y)[length(names(y))] <- paste(FUN[1], as.character(deparse(substitute(x))), sep = ".") } } else { y <- aggregate.data.frame(x, by, FUN = length) names(y)[length(names(y))] <- FUN[1] } if (length(FUN) > 1) { for (i in 2:length(FUN)) { if (FUN[i] != "length") { if (FUN[i] == "count") { y1 <- aggregate.data.frame(x, by, FUN = count) y <- data.frame(y, y1[, length(names(y1))]) } else { if (FUN[i] == "sum" | FUN[i] == "mean" | FUN[i] == "median" | FUN[i] == "var" | FUN[i] == "sd" | FUN[i] == "min" | FUN[i] == "max") { y1 <- aggregate.data.frame(x, by, FUN = FUN[i], na.rm = na.rm) } else { y1 <- aggregate.data.frame(x, by, FUN = FUN[i]) } y <- data.frame(y, y1[, length(names(y1))]) } names(y)[length(names(y))] <- paste(FUN[i], as.character(deparse(substitute(x))), sep = ".") } else { y1 <- aggregate.data.frame(x, by, FUN = length) y <- data.frame(y, y1[, length(names(y1))]) names(y)[length(names(y))] <- FUN[i] } } } y } ## Aggregate plot aggregate.plot <- function (x, by, grouping = NULL, FUN = c("mean", "median"), error = c("se", "ci", "sd", "none"), alpha = 0.05, lwd = 1, lty = "auto", line.col = "auto", bin.time = 4, bin.method = c("fixed", "quantile"), legend = "auto", legend.site = "topright", legend.bg = "white", xlim = "auto", ylim = "auto", bar.col = "auto", cap.size = 0.02, lagging = 0.007, main = "auto", return.output = FALSE, ...) { p25 <- function(xx) quantile(xx, prob = 0.25, na.rm = TRUE) p75 <- function(xx) quantile(xx, prob = 0.75, na.rm = TRUE) se <- function(xx) sd(xx, na.rm=TRUE)/sqrt(length(na.omit(xx))) x.is.factor.2.levels <- is.factor(x) & (length(levels(factor(x))) == 2) x.is.01 <- FALSE if (is.integer(x) | is.numeric(x) | is.logical(x)) x.is.01 <- length(table(x)) == 2 & min(x, na.rm = TRUE) == 0 & max(x, na.rm = TRUE) == 1 if (length(FUN) == 2 | any(FUN == "mean")) { FUN1 <- c("mean", "sd", "sum", "count", "se") } else { FUN1 <- c("median", "p25", "p75") } if (is.list(by)) { if (any(bar.col == "auto")) bar.col <- grey.colors(length(levels(factor(by[[1]])))) if (length(by) > 2) stop("The argument 'by' cannot have more than 2 elements!") if (legend == "auto") legend <- TRUE if (any(line.col == "auto")) line.col <- 1 if (length(FUN) == 2) FUN <- "mean" if (length(error) == 4 & error[1] == "se") error <- "se" if (is.factor(x)) { if (length(levels(x)) > 2) { stop("'x' is factor with more than 2 levels, which cannot be aggregated") } else { x1 <- as.numeric(unclass(x) - 1) } } if (is.logical(x)) x1 <- x * 1 if (is.numeric(x)) x1 <- x if (FUN == "mean") { sum.matrix <- tapply(x1, by, FUN = "sum", na.rm = TRUE) mean.matrix <- tapply(x1, by, FUN = "mean", na.rm = TRUE) sd.matrix <- tapply(x1, by, FUN = "sd", na.rm = TRUE) count <- function(x) length(na.omit(x)) count.matrix <- tapply(x1, by, FUN = "count") if (error == "se") { error.matrix <- sd.matrix/sqrt(count.matrix) } if (error == "sd") { error.matrix <- sd.matrix } sum.data.frame <- as.data.frame.table(sum.matrix) means.data.frame <- as.data.frame.table(mean.matrix) sd.data.frame <- as.data.frame.table(sd.matrix) count.data.frame <- as.data.frame.table(count.matrix) if (x.is.01) { ci.data.frame <- ci.binomial(sum.data.frame[, ncol(sum.data.frame)], count.data.frame[, ncol(count.data.frame)], alpha = alpha) se.data.frame <- means.data.frame[, -ncol(means.data.frame), drop = FALSE] se.data.frame$se <- ci.data.frame$se error.matrix <- xtabs(se ~ ., data = se.data.frame) lowerCI.data.frame <- means.data.frame[, -ncol(means.data.frame), drop = FALSE] lowerCI.data.frame$lowerCI <- ci.data.frame[, 5] lowerCI.matrix <- xtabs(lowerCI ~ ., data = lowerCI.data.frame) upperCI.data.frame <- means.data.frame[, -ncol(means.data.frame), drop = FALSE] upperCI.data.frame$upperCI <- ci.data.frame[, 6] upperCI.matrix <- xtabs(upperCI ~ ., data = upperCI.data.frame) } if (error == "ci") { if (x.is.01) { ci.data.frame0 <- ci.binomial(sum.data.frame[, ncol(sum.data.frame)], count.data.frame[, ncol(count.data.frame)], alpha = alpha) } else { ci.data.frame0 <- ci.numeric(means.data.frame[, ncol(means.data.frame)], count.data.frame[, ncol(count.data.frame)], sd.data.frame[, ncol(sd.data.frame)], alpha = alpha) } error.data.frame <- data.frame(count.data.frame[, -ncol(count.data.frame)], (ci.data.frame0[, ncol(ci.data.frame0)] - ci.data.frame0[, ncol(ci.data.frame0) - 1])/2) colnames(error.data.frame) <- c(colnames(sum.data.frame)[1:(ncol(error.data.frame) - 1)], "se") error.matrix <- xtabs(se ~ ., data = error.data.frame) } if (any(ylim == "auto")) ylim <- c(0, 1.01 * max(mean.matrix + error.matrix)) a <- barplot.default(mean.matrix, beside = TRUE, ylim = ylim, col = bar.col, ...) if (x.is.01) { if (error == "ci") { segments(x0 = a, x1 = a, y0 = lowerCI.matrix, y1 = upperCI.matrix, lwd = lwd, col = line.col) segments(x0 = a - 0.2, x1 = a + 0.2, y0 = lowerCI.matrix, y1 = lowerCI.matrix, lwd = lwd, col = line.col) segments(x0 = a - 0.2, x1 = a + 0.2, y0 = upperCI.matrix, y1 = upperCI.matrix, lwd = lwd, col = line.col) } else { segments(x0 = a, x1 = a, y0 = mean.matrix, y1 = mean.matrix + error.matrix, lwd = lwd, col = line.col) segments(x0 = a - 0.2, x1 = a + 0.2, y0 = mean.matrix + error.matrix, y1 = mean.matrix + error.matrix, lwd = lwd, col = line.col) } } else { segments(x0 = a, x1 = a, y0 = mean.matrix, y1 = mean.matrix + error.matrix, lwd = lwd, col = line.col) segments(x0 = a - 0.2, x1 = a + 0.2, y0 = mean.matrix + error.matrix, y1 = mean.matrix + error.matrix, lwd = lwd, col = line.col) if (error == "ci") { segments(x0 = a, x1 = a, y0 = mean.matrix, y1 = mean.matrix - error.matrix, lwd = lwd, col = line.col) segments(x0 = a - 0.2, x1 = a + 0.2, y0 = mean.matrix - error.matrix, y1 = mean.matrix - error.matrix, lwd = lwd, col = line.col) } } } if (FUN == "median") { if (length(levels(factor(x1))) == 2) { stop(paste("There are only two levels of \"", deparse(substitute(x)), "\",", "\n", " The variable is not appropriate to aggregate with \"median\"", sep = "")) } median.matrix <- tapply(x1, by, FUN = "median", na.rm = TRUE) p25.matrix <- tapply(x1, by, FUN = "p25") p75.matrix <- tapply(x1, by, FUN = "p75") midpoints.matrix <- median.matrix if (any(ylim == "auto")) ylim <- c(0, 1.01 * max(p75.matrix)) a <- barplot(median.matrix, beside = TRUE, ylim = ylim, col = bar.col, ...) segments(x0 = a, x1 = a, y0 = median.matrix, y1 = p75.matrix, lwd = lwd, col = line.col) segments(x0 = a - 0.2, x1 = a + 0.2, y0 = p75.matrix, y1 = p75.matrix, lwd = lwd, col = line.col) segments(x0 = a, x1 = a, y0 = median.matrix, y1 = p25.matrix, lwd = lwd, col = line.col) segments(x0 = a - 0.2, x1 = a + 0.2, y0 = p25.matrix, y1 = p25.matrix, lwd = lwd, col = line.col) } if (legend) { legend(x = legend.site, legend = levels(factor(by[[1]])), fill = bar.col, bg = legend.bg) } if (FUN == "median") { output <- as.data.frame.table(median.matrix) names(output)[length(names(output))] <- "median" output$p25 <- as.data.frame.table(p25.matrix)[, ncol(as.data.frame.table(p25.matrix))] output$p75 <- as.data.frame.table(p75.matrix)[, ncol(as.data.frame.table(p75.matrix))] } else { output <- as.data.frame.table(mean.matrix) names(output)[length(names(output))] <- "mean" if (error == "se" | error == "sd") { output$error <- as.data.frame.table(error.matrix)[, ncol(as.data.frame.table(error.matrix))] names(output)[length(names(output))] <- error } else { if (error == "ci") output$lowerCI <- ci.data.frame0[, ncol(ci.data.frame0) - 1] names(output)[ncol(output)] <- names(ci.data.frame0)[ncol(ci.data.frame0) - 1] output$upperCI <- ci.data.frame0[, ncol(ci.data.frame0)] names(output)[ncol(output)] <- names(ci.data.frame0)[ncol(ci.data.frame0)] if (x.is.factor.2.levels | x.is.01 | is.logical(x)) names(output)[ncol(output) - 2] <- paste("prob.", ifelse(x.is.factor.2.levels, name.x, deparse(substitute(x))), sep = "") } } } else { #### Line Aggregate plot starts here if (any(lty == "auto")) lty <- rep(1, length(table(factor(grouping)))) time <- by if (any(xlim == "auto")) xlim <- c(min(by, na.rm = TRUE), max(by, na.rm = TRUE)) xrange <- xlim[2] - xlim[1] if (is.factor(time)) stop("'time' must not be factor") if (is.factor(x)) { if (length(levels(x)) == 2) { name.x <- deparse(substitute(x)) levels.x.2 <- levels(factor(x))[2] x <- as.numeric(unclass(x)) - 1 } else { stop("Not possible to aggregrate.plot factor of more than 2 levels") } } if (length(error) == 1) { if (error != "none" & error !="sd" & error !="se") { error <- "ci" } } if (length(error) == 4) error <- "ci" # Define time bin of not regular if (min(table(time), na.rm = TRUE) > 3) { bin.time <- length(na.omit(table(time))) - 1 time1 <- time } else { if (length(bin.method) == 2 | any(bin.method == "fixed")) { break.points <- seq(from = min(time, na.rm = TRUE), to = max(time, na.rm = TRUE), by = (max(time, na.rm = TRUE) - min(time, na.rm = TRUE))/(bin.time + 1)) } else { break.points <- quantile(time, prob = seq(0, 1, 1/(bin.time + 1)), na.rm = TRUE) } midpoints <- ((break.points + c(NA, break.points[-length(break.points)]))[-1])/2 time.gr <- cut(time, breaks = break.points, include.lowest = TRUE) tx <- cbind(1:(length(break.points) - 1), midpoints) time1 <- lookup(unclass(time.gr), tx) } # Grouping or stratification if (!is.null(grouping)) { if (legend == "auto") { legend <- TRUE } else { legend <- legend } if (any(FUN1 == "median")) { data1 <- aggregate.numeric(x, by = list(grouping = grouping, time = time1), FUN = "median", length.warning = FALSE) data1$p25.x <- as.data.frame.table(tapply(x, list(grouping = grouping, time = time1), FUN = "p25"))[, 3] data1$p75.x <- as.data.frame.table(tapply(x, list(grouping = grouping, time = time1), FUN = "p75"))[, 3] output <- data1 } else { data1 <- aggregate.numeric(x, by = list(grouping = grouping, time = time1), FUN = FUN1, length.warning = FALSE) output <- data1 if(error=="ci") { output <- ci.numeric(x=data1$mean.x, n=data1$count.x, sds=data1$sd.x) } } } else { if (any(FUN1 == "median")) { data1 <- aggregate.numeric(x, by = list(time = time1), FUN = "median", length.warning = FALSE) data1$p25.x <- as.data.frame.table(tapply(x, list(time = time1), FUN = "p25"))[, 2] data1$p75.x <- as.data.frame.table(tapply(x, list(time = time1), FUN = "p75"))[, 2] output <- data1 } else { data1 <- aggregate.numeric(x, by = list(time = time1), FUN = FUN1, length.warning = FALSE) output <- data1 if(error=="ci") { output <- ci.numeric(x=data1$mean.x, n=data1$count.x, sds=data1$sd.x) } } } #print(data1) # if (any(FUN1 == "median")) { # data1$mean.x <- data1$median.x # data1$lowerci <- data1$p25.x # data1$upperci <- data1$p75.x # output <- data1[, -ncol(data1):-(ncol(data1) - 2)] # } # else { if(any(FUN1=="mean")){ if (error[1] == "ci") { if (x.is.factor.2.levels | is.logical(x) | x.is.01) { data.ci <- ci.binomial(data1$sum.x, data1$count.x, alpha = alpha) } else { data.ci <- ci.numeric(data1$mean.x, data1$count.x, data1$sd.x, alpha = alpha) } data1$lowerci <- data.ci[, 5] data1$upperci <- data.ci[, 6] output <- data1[, -(ncol(data1) - 2:4)] if (x.is.factor.2.levels | is.logical(x) | x.is.01) names(output)[names(output) == "mean.x"] <- paste("prob.", ifelse(x.is.factor.2.levels, name.x, as.character(substitute(x))), sep = "") else names(output)[names(output) == "mean.x"] <- paste("mean.", as.character(substitute(x)), sep = "") names(output)[names(output) == "lowerci"] <- names(data.ci)[5] names(output)[names(output) == "upperci"] <- names(data.ci)[6] } } # } if (any(ylim == "auto")) { if (error[1] == "ci") { ylim0 <- c(min(data1[, ncol(data1) - 1], na.rm = TRUE), max(data1[, ncol(data1)], na.rm = TRUE)) ylim <- ylim0 + c(-1, 1) * 0.2 * (ylim0[2] - ylim0[1]) } else { ylim0 <- c(min(data1$mean.x), max(data1$mean.x)) ylim <- ylim0 + c(-1, 1) * 0.2 * (ylim0[2] - ylim0[1]) } } if (!is.null(grouping)) { data1$grouping <- factor(data1$grouping) if (any(line.col == "auto")) line.col <- unclass(data1$grouping) for (i in 1:length(table(data1$grouping))) { data1$time[data1$grouping == levels(data1$grouping)[i]] <- data1$time[data1$grouping == levels(data1$grouping)[i]] + (i - 1) * lagging * xrange } if(any(FUN1=="mean")){ data1$mid.point <- data1$mean.x if (error == "ci") {data1$upper.point <- data1$upperci; data1$lower.point <- data1$lowerci} if (error == "sd") {data1$upper.point <- data1$mean.x + data1$sd.x; data1$lower.point <- data1$mean.x - data1$sd.x} if (error == "se") {data1$upper.point <- data1$mean.x + data1$sd.x/sqrt(data1$count.x); data1$lower.point <- data1$mean.x - data1$sd.x/sqrt(data1$count.x)} }else{ data1$mid.point <- data1$median.x data1$upper.point <- data1$p75.x data1$lower.point <- data1$p25.x } followup.plot(id = data1$grouping, time = data1$time, outcome = data1$mid.point, ylim = ylim, legend = legend, legend.site = legend.site, lwd = lwd, xlim = xlim, line.col = line.col, lty = lty, xlab = "", ylab = "", ...) if (error != "none") { segments(x0 = data1$time, y0 = data1$upper.point, x1 = data1$time, y1 = data1$lower.point, col = line.col, lwd = lwd) segments(x0 = data1$time - cap.size/2 * xrange, y0 = data1$upper.point, x1 = data1$time + cap.size/2 * xrange, y1 = data1$upper.point, col = line.col, lwd = lwd) segments(x0 = data1$time - cap.size/2 * xrange, y0 = data1$lower.point, x1 = data1$time + cap.size/2 * xrange, y1 = data1$lower.point, col = line.col, lwd = lwd) } if (legend) { legend(x = legend.site, legend = levels(factor(grouping)), lwd = lwd, col = line.col, bg = legend.bg, lty = lty) } } else { if (any(line.col == "auto")) line.col <- 1 if(any(FUN1=="mean")){ data1$mid.point <- data1$mean.x if (error == "ci") {data1$upper.point <- data1$upperci; data1$lower.point <- data1$lowerci} if (error == "sd") {data1$upper.point <- data1$mean.x + data1$sd.x; data1$lower.point <- data1$mean.x - data1$sd.x} if (error == "se") {data1$upper.point <- data1$mean.x + data1$sd.x/sqrt(data1$count.x); data1$lower.point <- data1$mean.x - data1$sd.x/sqrt(data1$count.x)} }else{ data1$mid.point <- data1$median.x data1$upper.point <- data1$p75.x data1$lower.point <- data1$p25.x } followup.plot(id = rep(1, nrow(data1)), time = data1$time, outcome = data1$mid.point, ylim = ylim, legend = FALSE, lwd = lwd, xlim = xlim, line.col = line.col, legend.site = legend.site, xlab = "", ylab = "", ...) if(error !="none"){ segments(x0 = data1$time, y0 = data1$upper.point, x1 = data1$time, y1 = data1$lower.point, col = line.col, lwd = lwd) segments(x0 = data1$time - cap.size/2 * xrange, y0 = data1$upper.point, x1 = data1$time + cap.size/2 * xrange, y1 = data1$upper.point, col = line.col, lwd = lwd) segments(x0 = data1$time - cap.size/2 * xrange, y0 = data1$lower.point, x1 = data1$time + cap.size/2 * xrange, y1 = data1$lower.point, col = line.col, lwd = lwd) } # if (error == "ci") { # segments(x0 = data1$time, y0 = data1$upperci, # x1 = data1$time, y1 = data1$lowerci, lwd = lwd, # col = line.col) # segments(x0 = data1$time - cap.size/2 * xrange, # y0 = data1$upperci, x1 = data1$time + cap.size/2 * # xrange, y1 = data1$upperci, col = line.col, # lwd = lwd) # segments(x0 = data1$time - cap.size/2 * xrange, # y0 = data1$lowerci, x1 = data1$time + cap.size/2 * # xrange, y1 = data1$lowerci, col = line.col, # lwd = lwd) # } } } if (!is.null(main)) { if (main == "auto") { if (FUN[1] == "mean") { main.first <- "Mean" if (length(levels(factor(x))) == 2) { if (is.logical(x)) { main.first <- paste("Prob. of ", deparse(substitute(x))) } else { if (x.is.factor.2.levels) { main.first <- paste("Prob. of", name.x, "=", levels.x.2) } else { if (names(table(x))[2] == "1") { main.first <- paste("Prob. of", deparse(substitute(x))) } else { main.first <- paste("Mean of", deparse(substitute(x))) } } } } } else { main.first <- "Median" } main.and <- paste("and", error[1]) # if (!is.list(by) & main.and == "and se") # main.and <- NULL if (main.first == "Median") { if (error[1] == "none") { main.and <- NULL } else { main.and <- "and IQR" } } else { if (error[1] == "ci") { main.and <- paste("and ", as.character((1 - alpha) * 100), "% CI", sep = "") } if (error[1] == "none") main.and <- NULL } if (is.list(by)) { if (length(names(by)) == 2) { main.by1 <- paste(names(by)[1], "and", names(by)[2]) } else { main.by1 <- names(by)[1] } } else { main.by1 <- deparse(substitute(by)) } if (is.null(grouping)) { main.by2 <- NULL } else { main.by2 <- paste("and", deparse(substitute(grouping))) } if ((error[1] == "ci") & (length(table(x)) == 2)) { title(main = paste(main.first, main.and, "by", main.by1, main.by2), cex.main = 1.2) } else { title(main = paste(main.first, main.and, "of", deparse(substitute(x)), "by", main.by1, main.by2), cex.main = 1.2) } } } if (return.output) output } ## Confidence interval ci <- function(x, ...){ UseMethod("ci") } ci.default <- function(x, ...){ if (is.logical(x)){ ci.binomial(x, ...) }else{ if(is.numeric(x)){ if(min(x, na.rm=TRUE)==0 & max(x, na.rm=TRUE)==1){ ci.binomial(x, ...) } }else{ if(is.factor(x) & length(levels(x))==2){ x <- as.numeric(unclass(x))-1 ci.binomial(x, ...) }else{ ci.numeric(x, ...) } } } } ci.binomial <- function(x, size, precision, alpha=.05, ...){ success <- x if(missing(size)){ success1 <- success if(min(success, na.rm=TRUE)!=0 | max(success, na.rm=TRUE)!=1){stop("This is not a binary vector.")} success <- length(na.omit(success1)[na.omit(success1) >0 ]) size <- length(na.omit(success1)) } reverse <- rep(FALSE, length(success)) reverse[success/size > .5] <- TRUE success[reverse] <- size[reverse]-success[reverse] if(missing(precision)){ precision <- success/size/10000} precision[success==0 |success==size] <-.01/size[success==0 |success==size] probab <- success/size success1 <- success success1[success > 0] <- success[success > 0]-1 for(i in 1:length(success)){while(pbinom(success1[i], size[i], probab[i], lower.tail=FALSE) > alpha/2){ probab[i] <- probab[i] - precision[i] }} estimate <- success/size se <- sqrt(estimate*(1-estimate)/size) ll <- probab probab <- success/size for(i in 1:length(success)){while(pbinom(success[i], size[i], probab[i], lower.tail=TRUE) > alpha/2){ probab[i] <- probab[i]+ precision[i] }} ul <- probab data.frame.a <- data.frame(events=success,total=size,probability = estimate, se=se, ll=ll, ul=ul) data.frame.a[reverse,] <- data.frame(events=size[reverse]-success[reverse],total=size[reverse],probability = 1-estimate[reverse], se=se[reverse], ll=1-ul[reverse], ul=1-ll[reverse]) names(data.frame.a)[5] <- paste("exact.lower",100*(1-alpha),"ci",sep="") names(data.frame.a)[6] <- paste("exact.upper",100*(1-alpha),"ci",sep="") if(nrow(data.frame.a)==1){rownames(data.frame.a) <- ""} data.frame.a } ## Confidence interval of continuous variable(s) ci.numeric <- function(x, n, sds, alpha=.05, ...){ means <- x mean1 <- means if(missing(n) & missing(sds)){ means <- mean(mean1, na.rm=TRUE) n <- length(na.omit(mean1)) sds <- sd(mean1, na.rm=TRUE) } se <- sds/sqrt(n) ll <- means - qt(p=(1-alpha/2), df = n-1)*se ul <- means + qt(p=(1-alpha/2), df = n-1)*se data.frame.a <- data.frame(n=n,mean=means, sd=sds, se=se, ll=ll, ul=ul) names(data.frame.a)[5] <- paste("lower",100*(1-alpha),"ci",sep="") names(data.frame.a)[6] <- paste("upper",100*(1-alpha),"ci",sep="") if(nrow(data.frame.a)==1){rownames(data.frame.a) <- ""} data.frame.a } # Confidence interval for Poisson variables ci.poisson <- function(x, person.time, precision, alpha=.05, ...){ count <- x incidence <- count/person.time if(missing(precision)){ precision <- incidence/1000 precision[incidence==0] <- 0.001/person.time[incidence==0] } lamda <- incidence * person.time for(i in 1:length(count)){ while(ppois(count[i], lamda[i], lower.tail=TRUE) > alpha/2){ incidence[i] <- incidence[i] + precision[i] lamda[i] <- incidence[i] * person.time[i] }} ul <- incidence incidence <- count/person.time lamda <- incidence * person.time count1 <- count-1 count1[count==0] <- count[count==0] for(i in 1:length(count)){ while(ppois(count1[i], lamda[i], lower.tail=FALSE) > alpha/2){ incidence[i] <- incidence[i] - precision[i] lamda[i] <- incidence[i] * person.time[i] }} ll <- incidence data.frame.a <- data.frame(events=count,person.time=person.time,incidence=count/person.time, se=sqrt(count)/person.time, ll=ll, ul=ul) names(data.frame.a)[5] <- paste("exact.lower",100*(1-alpha),"ci",sep="") names(data.frame.a)[6] <- paste("exact.upper",100*(1-alpha),"ci",sep="") if(nrow(data.frame.a)==1){rownames(data.frame.a) <- ""} data.frame.a } # Rename rename <- function(x1, x2, dataFrame = .data, ...){ UseMethod("rename") } ren <- rename rename.default <- function (x1, x2, dataFrame = .data, ...) { data1 <- dataFrame if (any(names(data1) == as.character(substitute(x1)))) { names(data1)[names(data1) == as.character(substitute(x1))] <- as.character(substitute(x2)) assign(as.character(substitute(dataFrame)), data1, pos=1) if(is.element(as.character(substitute(dataFrame)), search())){ detach(pos=which(search() %in% as.character(substitute(dataFrame)))) attach(data1, name=as.character(substitute(dataFrame)), warn.conflicts = FALSE) } } else { if (length(grep(pattern = x1, x = names(data1))) > 0) { rename.pattern(x1, x2, printNote = TRUE, dataFrame = .data) } else { stop(paste("\n", "\"", as.character(substitute(x1)), "\"", " is neither a var name nor an available pattern")) } } } ## Rename a variable rename.var <- function (x1, x2, dataFrame = .data, ...) { data1 <- dataFrame if (any(names(data1) == as.character(substitute(x1)))) { names(data1)[names(data1) == as.character(substitute(x1))] <- as.character(substitute(x2)) assign(as.character(substitute(dataFrame)), data1, pos=1) if(is.element(as.character(substitute(dataFrame)), search())){ detach(pos=which(search() %in% as.character(substitute(dataFrame)))) attach(data1, name=as.character(substitute(dataFrame)), warn.conflicts = FALSE) } } else { if (any(names(data1) == x1)) { names(data1)[names(data1) == x1] <- as.character(substitute(x2)) assign(as.character(substitute(dataFrame)), data1, pos=1) if(is.element(as.character(substitute(dataFrame)), search())){ detach(pos=which(search() %in% as.character(substitute(dataFrame)))) attach(data1, name=as.character(substitute(dataFrame)), warn.conflicts = FALSE) } } else { stop(paste("\n", "\"", as.character(substitute(x1)), "\"", " does not exist in the data frame", sep = "")) } } } ## Rename pattern of variables rename.pattern <- function (x1, x2, dataFrame = .data, printNote = TRUE, ...) { data1 <- dataFrame if (length(grep(pattern = x1, x = names(data1))) == 0) stop(paste("Pattern ", "\"", as.character(substitute(x1)), "\"", " does not exist", sep = "")) table1 <- cbind(names(data1)[grep(pattern = x1, x = names(data1))], sub(pattern = x1, replacement = x2, x = names(data1))[grep(pattern = x1, x = names(data1))]) rownames(table1) <- rep(" ", length(names(data1)[grep(pattern = x1, x = names(data1))])) colnames(table1) <- c("Old var names ", "New var names") if (printNote) { cat("Note the following change(s) in variable name(s):", "\n") print(table1) } names(data1) <- sub(pattern = x1, replacement = x2, x = names(data1)) assign(as.character(substitute(dataFrame)), data1, pos=1) if(is.element(as.character(substitute(dataFrame)), search())){ detach(pos=which(search() %in% as.character(substitute(dataFrame)))) attach(data1, name=as.character(substitute(dataFrame)), warn.conflicts = FALSE) } } ## Expand expand <- function(aggregate.data, index.var="Freq", retain.freq=FALSE){ output <- NULL for(i in 1:nrow(aggregate.data)){ if(retain.freq){ output <- rbind(output, aggregate.data[rep(i, aggregate.data[,which(names(aggregate.data)==index.var)][i]),]) }else{ output <- rbind(output, aggregate.data[rep(i, aggregate.data[,which(names(aggregate.data)==index.var)][i]),][,-which(names(aggregate.data)==index.var)]) }} data.frame(output,row.names=1:nrow(output))} ## BE to AD be2ad <- function(Date.in.BE){ if(class(Date.in.BE)!="Date") {stop("The class of the variable must be Date")} year <- format(Date.in.BE, "%Y") year <- as.integer(year) AD <- year-543 month <- format(Date.in.BE, "%m") day <- format(Date.in.BE, "%d") as.Date(paste(AD,"-",month,"-",day, sep="")) } ## Cronbach's alpha alpha <- function (vars, dataFrame = .data, casewise = FALSE, reverse = TRUE, decimal = 4, vars.to.reverse = NULL, var.labels = TRUE, var.labels.trunc=150) { if (casewise) { usage <- "complete.obs" } else { usage <- "pairwise.complete.obs" } nl <- as.list(1:ncol(dataFrame)) names(nl) <- names(dataFrame) selected <- eval(substitute(vars), nl, parent.frame()) selected.dataFrame <- dataFrame[, selected] selected.matrix <- NULL for (i in selected) { selected.matrix <- cbind(selected.matrix, unclass(dataFrame[, i])) } colnames(selected.matrix) <- names(selected.dataFrame) nl1 <- as.list(1:ncol(dataFrame[, selected])) names(nl1) <- names(dataFrame[, selected]) which.neg <- eval(substitute(vars.to.reverse), nl1, parent.frame()) if (suppressWarnings(!is.null(which.neg))) { selected.matrix[, which.neg] <- -1 * selected.matrix[, which.neg] reverse <- FALSE sign1 <- rep(1, ncol(selected.matrix)) sign1[which.neg] <- -1 } matR1 <- cor(selected.matrix, use = usage) diag(matR1) <- 0 if(any(matR1 > .999)){ reverse <- FALSE which(matR1 > .999, arr.ind =TRUE) -> temp.mat warning(paste(paste(rownames(temp.mat), collapse= " and "))," are extremely correlated.","\n", " Remove one of them from 'vars' if 'reverse' is required.") } if (reverse) { score <- factanal(na.omit(selected.matrix), factors = 1, scores = "regression")$score sign1 <- NULL for (i in 1:length(selected)) { sign1 <- c(sign1, sign(cor(score, na.omit(selected.matrix)[, i], use = usage))) } which.neg <- which(sign1 < 0) selected.matrix[, which.neg] <- -1 * selected.matrix[, which.neg] } reliability <- function(matrixC, matrixR, matrixN) { k1 <- ncol(matrixC) if (casewise) { cbar <- mean(matrixC[lower.tri(matrixC)]) rbar <- mean(matrixR[lower.tri(matrixR)]) } else { cbar.numerator <- sum(matrixC[lower.tri(matrixC)] * matrixN[lower.tri(matrixN)]) rbar.numerator <- sum(matrixR[lower.tri(matrixR)] * matrixN[lower.tri(matrixN)]) denominator <- sum(matrixN[lower.tri(matrixN)]) cbar <- cbar.numerator/denominator rbar <- rbar.numerator/denominator } vbar <- sum(diag(matrixC) * diag(matrixN))/sum(diag(matrixN)) alpha <- k1 * cbar/(vbar + (k1 - 1) * cbar) std.alpha <- k1 * rbar/(1 + (k1 - 1) * rbar) list(alpha = alpha, std.alpha = std.alpha, rbar = rbar) } k <- ncol(selected.matrix) matC <- cov(selected.matrix, use = usage) matR <- cor(selected.matrix, use = usage) if (casewise) { samp.size <- nrow(na.omit(selected.matrix)) matN <- matrix(nrow(na.omit(selected.matrix)), k, k) } else { samp.size <- length(na.omit(rowSums((!is.na(selected.matrix)) * 1) > 1)) matN <- matrix(0, k, k) for (i in 1:k) { for (j in 1:k) { matN[i, j] <- length(na.omit(selected.matrix[, i] + selected.matrix[, j])) } } } rel <- matrix(0, k, 3) colnames(rel) <- c("Alpha", "Std.Alpha", "r(item, rest)") rownames(rel) <- names(dataFrame)[selected] for (i in 1:k) { rel[i, 1] <- reliability(matrixC = matC[-i, -i], matrixR = matR[-i, -i], matrixN = matN[-i, -i])$alpha rel[i, 2] <- reliability(matC[-i, -i], matR[-i, -i], matN[-i, -i])$std.alpha if (usage == "pairwise.complete.obs") { meanrest <- rowMeans(selected.matrix[, -i], na.rm = TRUE) } if (usage == "complete.obs") { meanrest <- rowMeans(na.omit(selected.matrix)[, -i]) } if (usage == "pairwise.complete.obs") { rel[i, 3] <- cor(selected.matrix[, i], meanrest, use = "pairwise") } if (usage == "complete.obs") { rel[i, 3] <- cor(na.omit(selected.matrix)[, i], meanrest, use = "complete.obs") } } if (!is.null(which.neg)) { Reversed <- ifelse(sign1 < 0, " x ", " . ") result <- cbind(Reversed, round(rel, digits = decimal)) }else{ result <- round(rel, digits=decimal) } rownames(result) <- names(dataFrame)[selected] if (var.labels) { if (!is.null(attributes(dataFrame)$var.labels)) { result <- cbind(result, substr(attributes(dataFrame)$var.labels[selected],1,var.labels.trunc)) colnames(result)[ncol(result)] <- "description" } } results <- list(alpha = reliability(matC, matR, matN)$alpha, std.alpha = reliability(matC, matR, matN)$std.alpha, sample.size=samp.size, use.method = usage, rbar=reliability(matC, matR, matN)$rbar, items.selected = names(dataFrame)[selected], alpha.if.removed = rel, result=result, decimal=decimal) if(!is.null(which.neg)) results <- c(results, list(items.reversed = names(selected.dataFrame)[sign1 < 0])) if(var.labels && !is.null(attributes(dataFrame)$var.labels)){ results <- c(results, list(item.labels=attributes(dataFrame)$var.labels[selected])) } class(results) <- "alpha" results } print.alpha <- function(x, ...) { cat("Number of items in the scale =", length(x$items.selected), "\n") cat("Sample size =", x$sample.size, "\n") cat(paste("Average inter-item correlation =", round(x$rbar, digits = x$decimal), "\n", "\n")) cat(paste("Cronbach's alpha: ", "cov/cor computed with ", "'", x$use.method, "'", "\n", sep = "")) cat(paste(" unstandardized value =", round(x$alpha, digits = x$decimal), "\n")) cat(paste(" standardized value =", round(x$std.alpha, digits = x$decimal), "\n", "\n")) if(!is.null(x$items.reversed)){ cat(paste("Item(s) reversed:", paste(x$items.reversed, collapse= ", "), "\n", "\n")) }else{ cat(paste("Note: no attempt to reverse any item.", "\n", "\n")) } cat(paste("New alpha if item omitted:", "\n")) print.noquote(x$result) } # The best Cronbach alpha alphaBest <- function (vars, standardized = FALSE, dataFrame = .data) { nl <- as.list(1:ncol(dataFrame)) names(nl) <- names(dataFrame) selected <- eval(substitute(vars), nl, parent.frame()) a <- alpha(vars = selected, dataFrame = dataFrame) sorted.alpha.if.removed <- a$alpha.if.removed[order(a$alpha.if.removed[, 1 + standardized], decreasing = TRUE), 1 + standardized] removed.names <- NULL removed.orders <- NULL while (a[1 + standardized] < sorted.alpha.if.removed[1]) { removed.name0 <- names(sorted.alpha.if.removed)[1] removed.names <- c(removed.names, removed.name0) removed.orders <- c(removed.orders, which(names(dataFrame) %in% removed.name0)) a <- alpha(vars = setdiff(selected, removed.orders), dataFrame = dataFrame) sorted.alpha.if.removed <- a$alpha.if.removed[order(a$alpha.if.removed[, 1 + standardized], decreasing = TRUE), 1 + standardized] } names(removed.orders) <- removed.names remaining.names <- a$items.selected remaining.orders <- which(names(dataFrame) %in% remaining.names) names(remaining.orders) <- remaining.names if (standardized) { list(best.std.alpha = a$alpha, removed.items = removed.orders, remaining.items = remaining.orders) } else { list(best.alpha = a$alpha, removed = removed.orders, remaining = remaining.orders, items.reversed = a$items.reversed) } } ## Table stack tableStack <- function (vars, minlevel = "auto", maxlevel = "auto", count = TRUE, na.rm = FALSE, means = TRUE, medians = FALSE, sds = TRUE, decimal = 1, dataFrame = .data, total = TRUE, var.labels = TRUE, var.labels.trunc = 150, reverse = FALSE, vars.to.reverse = NULL, by = NULL, vars.to.factor = NULL, iqr = "auto", prevalence = FALSE, percent = c("column", "row", "none"), frequency = TRUE, test = TRUE, name.test = TRUE, total.column = FALSE, simulate.p.value = FALSE, sample.size = TRUE) { nl <- as.list(1:ncol(dataFrame)) names(nl) <- names(dataFrame) selected <- eval(substitute(vars), nl, parent.frame()) by.var <- eval(substitute(by), nl, parent.frame()) if (is.numeric(by.var)) { by <- dataFrame[, by.var] } if (is.character(by.var)) { by1 <- as.factor(rep("Total", nrow(dataFrame))) } if (is.null(by)) { selected.class <- NULL for (i in selected) { selected.class <- c(selected.class, class(dataFrame[, i])) } if (length(table(table(selected.class))) > 1) warning("Without 'by', classes of all selected variables should be the same.") } selected.to.factor <- eval(substitute(vars.to.factor), nl, parent.frame()) if (!is.character(iqr)) { selected.iqr <- eval(substitute(iqr), nl, parent.frame()) intersect.selected <- intersect(selected.iqr, selected.to.factor) if (length(intersect.selected) != 0) { stop(paste(names(dataFrame)[intersect.selected], "cannot simultaneously describe IQR and be coerced factor")) } for (i in selected.iqr) { if (!is.integer(dataFrame[, i]) & !is.numeric(dataFrame[, i])) { stop(paste(names(dataFrame)[i], "is neither integer nor numeric, not possible to compute IQR")) } } } for (i in selected) { if ((class(dataFrame[, i]) == "integer" | class(dataFrame[, i]) == "numeric") & !is.null(by)) { if (any(selected.to.factor == i)) { dataFrame[, i] <- factor(dataFrame[, i]) } else { dataFrame[, i] <- as.numeric(dataFrame[, i]) } } } if ((reverse || suppressWarnings(!is.null(vars.to.reverse))) && is.factor(dataFrame[, selected][, 1])) { stop("Variables must be in 'integer' class before reversing. \n Try 'unclassDataframe' first'") } selected.dataFrame <- dataFrame[, selected, drop = FALSE] if (is.null(by)) { selected.matrix <- NULL for (i in selected) { selected.matrix <- cbind(selected.matrix, unclass(dataFrame[, i])) } colnames(selected.matrix) <- names(selected.dataFrame) if (minlevel == "auto") { minlevel <- min(selected.matrix, na.rm = TRUE) } if (maxlevel == "auto") { maxlevel <- max(selected.matrix, na.rm = TRUE) } nlevel <- as.list(minlevel:maxlevel) names(nlevel) <- eval(substitute(minlevel:maxlevel), nlevel, parent.frame()) if (suppressWarnings(!is.null(vars.to.reverse))) { nl1 <- as.list(1:ncol(dataFrame)) names(nl1) <- names(dataFrame[, selected]) which.neg <- eval(substitute(vars.to.reverse), nl1, parent.frame()) for (i in which.neg) { dataFrame[, selected][, i] <- maxlevel + 1 - dataFrame[, selected][, i] selected.matrix[, i] <- maxlevel + 1 - selected.matrix[, i] } reverse <- FALSE sign1 <- rep(1, ncol(selected.matrix)) sign1[which.neg] <- -1 } if (reverse) { matR1 <- cor(selected.matrix, use = "pairwise.complete.obs") diag(matR1) <- 0 if (any(matR1 > 0.98)) { reverse <- FALSE temp.mat <- which(matR1 > 0.98, arr.ind = TRUE) warning(paste(paste(rownames(temp.mat), collapse = " and ")), " are extremely correlated.", "\n", " The command has been excuted without 'reverse'.", "\n", " Remove one of them from 'vars' if 'reverse' is required.") } else { score <- factanal(na.omit(selected.matrix), factors = 1, scores = "regression")$score sign1 <- NULL for (i in 1:length(selected)) { sign1 <- c(sign1, sign(cor(score, na.omit(selected.matrix)[, i], use = "pairwise"))) } which.neg <- which(sign1 < 0) for (i in which.neg) { dataFrame[, selected][, i] <- maxlevel + minlevel - dataFrame[, selected][, i] selected.matrix[, i] <- maxlevel + minlevel - selected.matrix[, i] } } } table1 <- NULL for (i in as.integer(selected)) { if (!is.factor(dataFrame[, i]) & !is.logical(dataFrame[,i, drop=TRUE])) { x <- factor(dataFrame[, i]) levels(x) <- nlevel tablei <- table(x) } else { if(is.logical(dataFrame[,i, drop=TRUE])){ tablei <- table(factor(dataFrame[,i, drop=TRUE], levels=c("FALSE","TRUE"))) }else{ tablei <- table(dataFrame[, i]) }} if (count) { tablei <- c(tablei, length(na.omit(dataFrame[, i]))) names(tablei)[length(tablei)] <- "count" } if (is.numeric(selected.dataFrame[, 1, drop = TRUE]) | is.logical(selected.dataFrame[, 1, drop = TRUE])) { if (means) { tablei <- c(tablei, round(mean(as.numeric(dataFrame[, i]), na.rm = TRUE), digits = decimal)) names(tablei)[length(tablei)] <- "mean" } if (medians) { tablei <- c(tablei, round(median(as.numeric(dataFrame[, i]), na.rm = TRUE), digits = decimal)) names(tablei)[length(tablei)] <- "median" } if (sds) { tablei <- c(tablei, round(sd(as.numeric(dataFrame[, i]), na.rm = TRUE), digits = decimal)) names(tablei)[length(tablei)] <- "sd" } } table1 <- rbind(table1, tablei) } results <- as.table(table1) if (var.labels) { rownames(results) <- names(selected.dataFrame) } else { rownames(results) <- paste(selected, ":", names(selected.dataFrame)) } if (is.integer(selected.dataFrame[, 1])) { rownames(results) <- names(nl)[selected] if (is.factor(dataFrame[, selected][, 1])) { colnames(results)[1:(ncol(results) - (count + means + medians + sds))] <- levels(dataFrame[, selected][, 1]) } else { colnames(results)[1:(ncol(results) - (count + means + medians + sds))] <- names(nlevel) } } result0 <- results if (var.labels) { if (!is.null(attributes(dataFrame)$var.labels)) { results <- as.table(cbind(results, substr(attributes(dataFrame)$var.labels[selected], 1, var.labels.trunc))) } if (!is.null(attributes(dataFrame)$var.labels)) colnames(results)[ncol(results)] <- "description" } if (is.integer(selected.dataFrame[, 1]) | is.numeric(selected.dataFrame[, 1]) | is.logical(selected.dataFrame[, 1])) { if (reverse || (!is.null(vars.to.reverse))) { Reversed <- ifelse(sign1 < 0, " x ", " . ") results <- cbind(Reversed, results) } sumMeans <- 0 sumN <- 0 for (i in selected) { sumMeans <- sumMeans + mean(as.numeric(dataFrame[, i]), na.rm = TRUE) * length(na.omit(dataFrame[, i])) sumN <- sumN + length(na.omit(dataFrame[, i])) } mean.of.total.scores <- weighted.mean(rowSums(selected.matrix), w = rowSums(!is.na(selected.matrix)), na.rm = TRUE) sd.of.total.scores <- sd(rowSums(selected.matrix), na.rm = TRUE) mean.of.average.scores <- weighted.mean(rowMeans(selected.matrix), w = rowSums(!is.na(selected.matrix)), na.rm = TRUE) sd.of.average.scores <- sd(rowMeans(selected.matrix), na.rm = TRUE) countCol <- which(colnames(results) == "count") meanCol <- which(colnames(results) == "mean") sdCol <- which(colnames(results) == "sd") if (total) { results <- rbind(results, rep("", reverse || suppressWarnings(!is.null(vars.to.reverse)) + (maxlevel + 1 - minlevel) + (count + means + medians + sds + var.labels))) results[nrow(results), countCol] <- length((rowSums(selected.dataFrame))[!is.na(rowSums(selected.dataFrame))]) results[nrow(results), meanCol] <- round(mean.of.total.scores, digits = decimal) results[nrow(results), sdCol] <- round(sd.of.total.scores, digits = decimal) rownames(results)[nrow(results)] <- " Total score" results <- rbind(results, rep("", reverse || suppressWarnings(!is.null(vars.to.reverse)) + (maxlevel + 1 - minlevel) + (count + means + medians + sds + var.labels))) results[nrow(results), countCol] <- length(rowSums(selected.dataFrame)[!is.na(rowSums(selected.dataFrame))]) results[nrow(results), meanCol] <- round(mean.of.average.scores, digits = decimal) results[nrow(results), sdCol] <- round(sd.of.average.scores, digits = decimal) rownames(results)[nrow(results)] <- " Average score" } } results <- list(results = noquote(results)) if (reverse || suppressWarnings(!is.null(vars.to.reverse))) results <- c(results, list(items.reversed = names(selected.dataFrame)[sign1 < 0])) if (var.labels && !is.null(attributes(dataFrame)$var.labels)) { results <- c(results, list(item.labels = attributes(dataFrame)$var.labels[selected])) } if (total) { if (is.integer(selected.dataFrame[, 1]) | is.numeric(selected.dataFrame[, 1])) { results <- c(results, list(total.score = rowSums(selected.matrix)), list(mean.score = rowMeans(selected.matrix, na.rm=na.rm)), list(mean.of.total.scores = mean.of.total.scores, sd.of.total.scores = sd.of.total.scores, mean.of.average.scores = mean.of.average.scores, sd.of.average.scores = sd.of.average.scores)) } } class(results) <- c("tableStack", "list") results } else { if (is.character(by.var)) { by1 <- as.factor(rep("Total", nrow(dataFrame))) } else { by1 <- factor(dataFrame[, by.var]) } if (is.logical(dataFrame[, i])) { dataFrame[, i] <- as.factor(dataFrame[, i]) levels(dataFrame[, i]) <- c("No", "Yes") } if (length(table(by1)) == 1) test <- FALSE name.test <- ifelse(test, name.test, FALSE) if (is.character(iqr)) { if (iqr == "auto") { selected.iqr <- NULL for (i in 1:length(selected)) { if (class(dataFrame[, selected[i]]) == "difftime") { dataFrame[, selected[i]] <- as.numeric(dataFrame[, selected[i]]) } if (is.integer(dataFrame[, selected[i]]) | is.numeric(dataFrame[, selected[i]])) { if (length(table(by1)) > 1) { if (nrow(dataFrame) < 5000) { if (nrow(dataFrame) < 3) { selected.iqr <- c(selected.iqr, selected[i]) } else if (shapiro.test(lm(dataFrame[, selected[i]] ~ by1)$residuals)$p.value < 0.01 | bartlett.test(dataFrame[, selected[i]] ~ by1)$p.value < 0.01) { selected.iqr <- c(selected.iqr, selected[i]) } } else { sampled.shapiro <- sample(lm(dataFrame[, selected[i]] ~ by1)$residuals, 250) if (shapiro.test(sampled.shapiro)$p.value < 0.01 | bartlett.test(dataFrame[, selected[i]] ~ by1)$p.value < 0.01) { selected.iqr <- c(selected.iqr, selected[i]) } } } } } } else { selected.iqr <- NULL } } table2 <- NULL if (sample.size) { if (test) { if (name.test) { if (total.column) { table2 <- rbind(c(table(by1), length(by1), "", ""), c(rep("", length(table(by1)) + 1), "", "")) colnames(table2)[ncol(table2) - (2:0)] <- c("Total", "Test stat.", "P value") } else { table2 <- rbind(c(table(by1), "", ""), c(rep("", length(table(by1))), "", "")) colnames(table2)[ncol(table2) - (1:0)] <- c("Test stat.", "P value") } } else { if (total.column) { table2 <- rbind(c(table(by1), length(by1), ""), c(rep("", length(table(by1)) + 1), "", "")) colnames(table2)[ncol(table2) - (1:0)] <- c("Total", "P value") } else { table2 <- rbind(c(table(by1), ""), c(rep("", length(table(by1))), "")) colnames(table2)[ncol(table2)] <- "P value" } } } else { total.column <- FALSE table2 <- rbind(table(by1), "") } } for (i in 1:length(selected)) { if (is.factor(dataFrame[, selected[i]]) | is.logical(dataFrame[, selected[i]]) | is.character(dataFrame[, selected[i]])) { x0 <- table(dataFrame[, selected[i]], by1) if (total.column) { x <- addmargins(x0, margin = 2) } else { x <- x0 } nr <- nrow(x) nc <- ncol(x0) sr <- rowSums(x0) if (any(sr == 0)) { stop(paste(names(dataFrame)[selected[i]], " has zero count in at least one row")) } sc <- colSums(x0) if (any(sc == 0)) { stop(paste(names(dataFrame)[selected[i]], " has zero count in at least one column")) } x.row.percent <- round(x/rowSums(x0) * 100, decimal) table0 <- x if (nrow(x) == 2 & prevalence) { table00 <- addmargins(x, margin = 1) table0 <- paste(table00[2, ], "/", table00[3, ], " (", round(table00[2, ]/table00[3, ] * 100, decimal), "%)", sep = "") table0 <- t(table0) rownames(table0) <- " prevalence" } else { if (any(percent == "column")) { x.col.percent <- round(t(t(x)/colSums(x)) * 100, decimal) x.col.percent1 <- matrix(paste(x, " (", x.col.percent, ")", sep = ""), nrow(x), ncol(x)) if (!frequency) { x.col.percent1 <- x.col.percent } table0 <- x.col.percent1 } else { if (any(percent == "row")) { x.row.percent <- round(x/rowSums(x0) * 100, decimal) x.row.percent1 <- matrix(paste(x, " (", x.row.percent, ")", sep = ""), nrow(x), ncol(x)) if (!frequency) { x.row.percent1 <- x.row.percent } table0 <- x.row.percent1 } } rownames(table0) <- paste(" ", rownames(x)) colnames(table0) <- colnames(x) } if (test) { E <- outer(sr, sc, "*")/sum(x0) dim(E) <- NULL if ((sum(E < 5))/length(E) > 0.2 & nrow(dataFrame) < 1000) { test.method <- "Fisher's exact test" p.value <- fisher.test(x0, simulate.p.value = simulate.p.value)$p.value } else { test.method <- paste("Chisq. (", suppressWarnings(chisq.test(x0)$parameter), " df) = ", suppressWarnings(round(chisq.test(x0)$statistic, decimal + 1)), sep = "") p.value <- suppressWarnings(chisq.test(x0)$p.value) } } } if (is.numeric(dataFrame[, selected[i]])) { if (any(selected.iqr == selected[i])) { term1 <- NULL term2 <- NULL term3 <- NULL for (j in 1:(length(levels(by1)))) { term1 <- c(term1, quantile(dataFrame[by1 == levels(by1)[j], selected[i]], na.rm = TRUE)[3]) term2 <- c(term2, quantile(dataFrame[by1 == levels(by1)[j], selected[i]], na.rm = TRUE)[2]) term3 <- c(term3, quantile(dataFrame[by1 == levels(by1)[j], selected[i]], na.rm = TRUE)[4]) } if (total.column) { term1 <- c(term1, quantile(dataFrame[, selected[i]], na.rm = TRUE)[3]) term2 <- c(term2, quantile(dataFrame[, selected[i]], na.rm = TRUE)[2]) term3 <- c(term3, quantile(dataFrame[, selected[i]], na.rm = TRUE)[4]) } term.numeric <- paste(round(term1, decimal), " (", round(term2, decimal), ",", round(term3, decimal), ")", sep = "") term.numeric <- t(term.numeric) rownames(term.numeric) <- " median(IQR)" } else { term1 <- as.vector(tapply(X = dataFrame[, selected[i]], INDEX = list(by1), FUN = "mean", na.rm = TRUE)) if (total.column) { term1 <- c(term1, mean(dataFrame[, selected[i]], na.rm = TRUE)) } term2 <- as.vector(tapply(X = dataFrame[, selected[i]], INDEX = list(by1), FUN = "sd", na.rm = TRUE)) if (total.column) { term2 <- c(term2, sd(dataFrame[, selected[i]], na.rm = TRUE)) } term.numeric <- paste(round(term1, decimal), " (", round(term2, decimal), ")", sep = "") term.numeric <- t(term.numeric) rownames(term.numeric) <- " mean(SD)" } table0 <- term.numeric if (test) { if (any(as.integer(table(by1[!is.na(dataFrame[, selected[i]])])) < 3) | length(table(by1)) > length(table(by1[!is.na(dataFrame[, selected[i]])]))) { test.method <- paste("Sample too small: group", paste(which(as.integer(table(factor(by)[!is.na(dataFrame[, selected[i]])])) < 3), collapse = " ")) p.value <- NA } else { if (any(selected.iqr == selected[i])) { if (length(levels(by1)) > 2) { test.method <- "Kruskal-Wallis test" p.value <- kruskal.test(dataFrame[, selected[i]] ~ by1)$p.value } else { test.method <- "Ranksum test" p.value <- wilcox.test(dataFrame[, selected[i]] ~ by1, exact = FALSE)$p.value } } else { if (length(levels(by1)) > 2) { test.method <- paste("ANOVA F-test (", anova(lm(dataFrame[, selected[i]] ~ by1))[1, 1], ", ", anova(lm(dataFrame[, selected[i]] ~ by1))[2, 1], " df) = ", round(anova(lm(dataFrame[, selected[i]] ~ by1))[1, 4], decimal + 1), sep = "") p.value <- anova(lm(dataFrame[, selected[i]] ~ by1))[1, 5] } else { test.method <- paste("t-test", paste(" (", t.test(dataFrame[, selected[i]] ~ by1, var.equal = TRUE)$parameter, " df)", sep = ""), "=", round(abs(t.test(dataFrame[, selected[i]] ~ by1, var.equal = TRUE)$statistic), decimal + 1)) p.value <- t.test(dataFrame[, selected[i]] ~ by1, var.equal = TRUE)$p.value } } } } } if (test) { if (name.test) { label.row <- c(rep("", length(levels(by1)) + total.column), test.method, ifelse(p.value < 0.001, "< 0.001", round(p.value, decimal + 2))) label.row <- t(label.row) if (total.column) { colnames(label.row) <- c(levels(by1), "Total", "Test stat.", "P value") } else { colnames(label.row) <- c(levels(by1), "Test stat.", "P value") } table0 <- cbind(table0, "", "") blank.row <- rep("", length(levels(by1)) + total.column + 2) } else { label.row <- c(rep("", length(levels(by1)) + total.column), ifelse(p.value < 0.001, "< 0.001", round(p.value, decimal + 2))) label.row <- t(label.row) if (total.column) { colnames(label.row) <- c(levels(by1), "Total", "P value") } else { colnames(label.row) <- c(levels(by1), "P value") } table0 <- cbind(table0, "") blank.row <- rep("", length(levels(by1)) + total.column + 1) } } else { label.row <- c(rep("", length(levels(by1)) + total.column)) label.row <- t(label.row) if (total.column) { colnames(label.row) <- c(levels(by1), "Total") } else { colnames(label.row) <- c(levels(by1)) } blank.row <- rep("", length(levels(by1)) + total.column) } if (var.labels) { rownames(label.row) <- ifelse(!is.null(attributes(dataFrame)$var.labels[selected][i]), attributes(dataFrame)$var.labels[selected[i]], names(dataFrame)[selected][i]) rownames(label.row) <- ifelse(rownames(label.row) == "", names(dataFrame[selected[i]]), rownames(label.row)) } else { rownames(label.row) <- paste(selected[i], ":", names(dataFrame[selected[i]])) } if (!is.logical(dataFrame[, selected[i]])) { if (prevalence & length(levels(dataFrame[, selected[i]])) == 2) { rownames(label.row) <- paste(rownames(label.row), "=", levels(dataFrame[, selected[i]])[2]) } } blank.row <- t(blank.row) rownames(blank.row) <- "" table2 <- rbind(table2, label.row, table0, blank.row) } if (sample.size) { rownames(table2)[1:2] <- c("Total", "") } class(table2) <- c("tableStack", "table") table2 } } # Print tableStack print.tableStack <- function (x, ...) { if(any(class(x)=="list")){ print(x$results) }else{ print.table(noquote((x))) } } # Unclass data frame unclassDataframe <- function(vars, dataFrame = .data){ data1 <- dataFrame nl <- as.list(1:ncol(data1)) names(nl) <- names(data1) selected <- eval(substitute(vars), nl, parent.frame()) for(i in selected){ data1[,i] <- unclass(data1[,i]) attributes(data1[, i]) <- NULL } assign(as.character(substitute(dataFrame)), data1, pos=1) if(is.element(as.character(substitute(dataFrame)), search())){ detach(pos=which(search() %in% as.character(substitute(dataFrame)))) attach(data1, name=as.character(substitute(dataFrame)), warn.conflicts = FALSE) } } ## Merge with var.labels maintained merge.lab <- function(x, y, ...){ if(!is.data.frame(x) | !is.data.frame(y)) stop("Both object must be in class data frame") if(is.null(attr(x, "var.labels"))) { array1 <- cbind(names(x), "") }else{ array1 <- cbind(names(x),attr(x, "var.labels")) } if(is.null(attr(y, "var.labels"))) { array2 <- cbind(names(y), "") }else{ array2 <- cbind(names(y),attr(y, "var.labels")) } array12 <- rbind(array1, array2) array12 <- array12[!duplicated(array12[,1]),] newdata <- merge(x, y, ...) attr(newdata, "var.labels") <- rep("", nrow(newdata)) attr(newdata, "var.labels") <- lookup(names(newdata), lookup.array=array12) newdata } ## Longitudinal data management # Area under curve auc <- function(conc, time, id=NULL) { auc <- 0 for(i in 2:(length(time))){ auc <- auc + (time[i] - time[i-1])*(conc[i] + conc[i-1])/2 } if (!is.null(id)){ subject <- NULL auc <- NULL for(i in 1: length(table(id))) { if ((is.ordered(id) & is.factor(id))) { subject.integer <- as.integer(id)[order(id)] }else{ subject.integer <- id } subject <- c(subject, subject.integer[id==i][1]) auc.individual <- 0 for(j in 2:(length(time[id==i]))){ auc.individual <- auc.individual + (time[id==i][j] - time[id==i][j-1])*(conc[id==i][j] + conc[id==i][j-1])/2 } auc <- c(auc, auc.individual) } auc <- data.frame (subject=subject, auc=auc) names(auc)[1] <- as.character(substitute(id)) auc } auc } # Mark visits of followup by id and time markVisits <- function (id, time) { if(length(id) !=length(time)) stop("The length of these two variables must be equal") if(any(duplicated(paste(id,time)))) stop("The combination of id and time must be unique") original.order <- 1:length(id) if(any(data.frame(id, time) != data.frame(id[order(id, time)], time[order(id,time)]))){ new.order <- original.order[order(id,time)] id <- id[order(id,time)] time <- time[order(id,time)] } list1 <- rle(as.vector(id)) unlist(sapply(X=list1$lengths, FUN=function(x) 1:x, simplify=FALSE)) -> visit visit[order(original.order)] } # Creating lag and next measurement lagVar <- function (var, id, visit, lag.unit = 1) { if (!is.integer(lag.unit)) lag.unit <- as.integer(lag.unit) if (length(id) != length(visit)) stop("The length of these two variables must be equal") if (any(duplicated(paste(id, visit)))) stop("The combination of id and visit must be unique") if (any(data.frame(id, visit) != data.frame(id[order(id, visit)], visit[order(id, visit)]))) { new.order <- order(id, visit) var <- var[new.order] id <- id[new.order] visit <- visit[new.order] } var.lag <- var id.lag <- id visit.lag <- visit if (lag.unit >= 1) { var.lag[length(id):(lag.unit + 1)] <- var[(length(id) - lag.unit):1] var.lag[1:lag.unit] <- NA id.lag[length(id):(lag.unit + 1)] <- id[(length(id) - lag.unit):1] visit.lag[length(id):(lag.unit + 1)] <- visit[(length(id) - lag.unit):1] } else { var.lag[1:(length(id) + lag.unit)] <- var[(-lag.unit + 1):length(id)] var.lag[length(id):(length(id) + lag.unit + 1)] <- NA id.lag[1:(length(id) + lag.unit)] <- id[(-lag.unit + 1):length(id)] visit.lag[1:(length(id) + lag.unit)] <- visit[(-lag.unit + 1):length(id)] } var.lag[id != id.lag] <- NA var.lag[visit - visit.lag != lag.unit] <- NA if(exists("new.order")){ var.lag <- var.lag[order(new.order)] } var.lag } # fill in missing records fillin <- function(dataFrame=.data, select, fill=NA) { if(missing(select)) select=1:ncol(dataFrame) nl <- as.list(1:ncol(dataFrame)) names(nl) <- names(dataFrame) vars <- eval(substitute(select), nl, parent.frame()) x <- data.frame(table(dataFrame[,vars])) x0 <- subset(x, Freq==0)[,-length(x)] if(nrow(x0)==0){ dataFrame warning("Nothing to fill")} else{ z <- as.data.frame(dataFrame[1:nrow(x0), -vars, drop=FALSE]) if(dim(z)[2]==1) names(z) <- names(dataFrame)[-vars] z[,] <- fill rbind(dataFrame, cbind(x0, z)) } } addMissingRecords <- function (dataFrame = .data, id, visit, outcome, check.present = TRUE, present.varname = "present", update.visit.related.vars = TRUE) { if(missing(outcome)) stop("Outcome variable(s) must be specified") id.varname <- as.character(substitute(id)) visit.varname <- as.character(substitute(visit)) unique.id <- unique(dataFrame[, id.varname]) unique.visit <- unique(dataFrame[, visit.varname]) if (any(table(dataFrame[, id.varname], dataFrame[, visit.varname]) > 1)) { stop(paste("\n", "Missing records cannot be added because the combination of IDs and visits are not unique")) } index.col <- which(names(dataFrame) %in% c(id.varname, visit.varname)) if (check.present) { dataFrame <- merge.lab(dataFrame, data.frame(present.varname = 1), all = TRUE) names(dataFrame)[ncol(dataFrame)] <- present.varname } long <- data.frame(id.varname = rep(unique.id, rep(length(unique.visit), length(unique.id))), visit.varname = rep(unique(unique.visit), length(unique(id.varname)))) names(long) <- c(id.varname, visit.varname) new.data <- merge.lab(long, dataFrame, all = TRUE) var.to.fill <- 3:ncol(new.data) if (check.present) var.to.fill <- var.to.fill[-length(var.to.fill)] nl <- as.list(1:ncol(new.data)) names(nl) <- names(new.data) vars.outcome <- eval(substitute(outcome), nl, parent.frame()) for (i in setdiff(var.to.fill,vars.outcome)) { if (all(rowSums(table(dataFrame[, id.varname], dataFrame[, names(new.data)[i]]) > 0) == 1)) { unique.array <- unique((dataFrame)[, c(id.varname, names(new.data)[i])]) new.data[, i] <- rep(unique.array[, 2], times = rep(length(table(dataFrame[, visit.varname])), length(table(dataFrame[, id.varname])))) } } if (check.present) new.data[, ncol(new.data)][is.na(new.data[, ncol(new.data)])] <- 0 if (update.visit.related.vars) { var.to.check.update <- 3:(ncol(new.data) - 1) for (i in var.to.check.update) { if (all(rowSums(table(new.data[, 2], new.data[, i]) > 1) == 1)) { tx <- unique(data.frame(new.data[, 2], new.data[, i])) tx <- tx[!is.na(tx[, 1]) & !is.na(tx[, 2]), ] for (j in 1:nrow(tx)) { new.data[new.data[, 2] == tx[j, 1], i] <- tx[j, 2] } } } } new.data } tally.events <- function(x, by=NULL, breaks=c("day","week","month","year"), graph=TRUE, type="l", line.col="auto", legend = TRUE, legend.site="topright", legend.bg="white", ylim="auto", cex=1, addmargins=TRUE, ...) { if(class(x)!="Date") stop("The object to be plotted must be of class 'Date'!") if(length(breaks)>1 | any(breaks=="day")) { breaks <- "day" label.x <- levels(cut(x, breaks="day")) }else{ if(breaks=="week") label.x <- round(as.integer(format(as.Date(levels(cut(x, breaks="week"))),"%j"))/7+1) if(breaks=="month") label.x <- format(as.Date(levels(cut(x, breaks="month"))),"%b-%y") if(breaks=="year") label.x <- format(as.Date(levels(cut(x, breaks="year"))),"%Y") } if(is.null(by)) { results <- table(cut(x, breaks=breaks)) names(results) <- label.x if(graph){ if(length(ylim)==1) ylim <- c(min(results),max(results)) else ylim <- ylim plot(as.numeric(results), xlab="",ylab="", type=type, xaxt="n", col=ifelse(any(line.col=="auto"),1,line.col), ylim=ylim, ...) axis(side=1, labels=label.x, at=1:length(as.numeric(results)), ...) } return(results) }else{ results <- table(cut(x, breaks=breaks),by) rownames(results) <- label.x if(graph){ if(any(line.col=="auto")) {line.col <- 1:ncol(results)}else{line.col<-rep(line.col,ncol(results))} if(length(ylim)==1) ylim <- c(min(results),max(results)) else ylim <- ylim plot(as.numeric(results[,1]), xlab="", ylab="", type="l", xaxt="n", ylim = ylim, col=line.col[1], ...) for(i in 2:ncol(results)){ lines(as.numeric(results[,i]), col=line.col[i], lty=i, ...) } axis(side=1, at= 1:nrow(results), labels=rownames(results), ...) if(legend) legend(legend.site, lty=1:i, col=line.col[1:i], legend = colnames(results), text.col=line.col[1:i], cex=cex, bg=legend.bg) } if(addmargins) results <- addmargins(results) return(results) } }epicalc/NAMESPACE0000644000176000001440000000035212026244670013124 0ustar ripleyusers# Default NAMESPACE created by R # Remove the previous line if you edit this file # Export all names exportPattern(".") # Import all packages listed as Imports or Depends import( foreign, survival, MASS, nnet ) epicalc/man/0000755000176000001440000000000012026244665012464 5ustar ripleyusersepicalc/man/zap.rd0000644000176000001440000000314112026244665013604 0ustar ripleyusers\name{zap} \alias{zap} \title{Remove and detach all} \description{Detach and remove all objects and data frames from the global environment} \usage{ zap() } \details{The R command 'attach()' copies the data frame in the argument into a data frame in the search path (usually the second position) consequently making all the variables in the data frame easy to refer to. However, changing any element of the index data frame has no effect on the one in the search path unless the changed data frame is attached to the search path again. Having too many data frames in the search path subsequently causes confusion, not to mention an increase in memory usage. It is a good practice to detach the index data frame first before manipulating it and then attaching to it again. 'detachAllData()' is a self explanatory command which solves the over-attaching problem. 'zap()' is a combination of 'detachAllData()' and removal of non-function objects in the R workspace. At the commencement of a new session, 'zap()' can be quite useful to clean the objects left over from previous R sessions and detach from any unwanted data frames. 'zap()' as well as 'rm(list=ls())' do not remove any objects starting with a dot '.', which are meant to be hidden. Therefore the object '.data' is resistant to 'zap()'.} \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'use', 'detach', 'ls', 'rm'} \examples{ object1 <- 1:5 object2 <- list(a=3, b=5) function1 <- function(x) {x^3 +1} attach(CO2) lsNoFunction() ls() search() detachAllData() ls() search() zap() ls() search() rm(function1) } \keyword{database}epicalc/man/Xerop.rd0000644000176000001440000000217712026244665014117 0ustar ripleyusers\name{Xerophthalmia and respiratory infection} \alias{Xerop} \docType{data} \title{Dataset from an Indonesian study on vitamin A deficiency and risk of respiratory infection} \description{ This dataset was adopted from Diggle et al: Analysis of Longitudinal Data. REFERENCE -- Zeger and Karim, JASA (1991) Note that there are some duplications of id and time combination. } \usage{data(Xerop)} \format{A data frame containing 1200 observations and 10 variables. \describe{ \item{\code{id}}{a numeric vector for personal identification number} \item{\code{respinfect}}{whether the child had respiratory infection in that visit} \item{\code{age.month}}{current age in month} \item{\code{xerop}}{whether the child currently had vitamin A deficiency} \item{\code{sex}}{gender of the child no detail on the code} \item{\code{ht.for.age}}{height for age} \item{\code{stunted}}{whether the child has stunted growth} \item{\code{time}}{time of scheduled visit} \item{\code{baseline.age}}{baseline age} \item{\code{season}}{season} } } \examples{ data(Xerop) } \keyword{datasets} epicalc/man/VCT.rd0000644000176000001440000000102712026244665013447 0ustar ripleyusers\name{Voluntary counselling and testing} \docType{data} \alias{VCT} \title{Dataset on attitudes toward VCT} \description{ This dataset contains information on the records of 200 women working at a tourist destination community. } \usage{data(VCT)} \format{A subset of a data frame containing 200 observations and 12 variables with variable descriptions. Details of the codes can be seen from the results of the function 'codebook()' below. } \examples{ data(VCT) use(VCT) des() codebook() } \keyword{datasets} epicalc/man/Vc1to1.rd0000644000176000001440000000221512026244665014070 0ustar ripleyusers\name{Matched case-control study} \docType{data} \alias{VC1to1} \alias{VC1to6} \title{Datasets on a matched case-control study of esophageal cancer} \description{ Two different datasets for the same matched case-control study. VC1to6 has 1 case : varying number of controls (from 1 to 6) whereas VC1to1 has the number of control reduced to 1 for each case. } \usage{data(VC1to1) data(VC1to6)} \format{ A data frame with the following 5 variables. \describe{ \item{\code{matset}}{a numeric vector indicating matched set number from 1 to 26} \item{\code{case}}{a numeric vector: 1=case, 0=control} \item{\code{smoking}}{a numeric vector: 1=smoker, 0=non-smoker} \item{\code{rubber}}{a numeric vector: 1=exposed, 0=never exposed to rubber industry} \item{\code{alcohol}}{a numeric vector: 1=drinker, 0=non-drinker} } } \source{Chongsuvivatwong, V. 1990 A case-control study of esophageal cancer in Southern Thailand. \emph{J Gastro Hep} \bold{5}:391--394.} \seealso{ 'infert' in the datasets package. } \examples{ data(VC1to6) use(VC1to6) des() matchTab(case, alcohol, matset) } \keyword{datasets} epicalc/man/use.rd0000644000176000001440000000370712026244665013616 0ustar ripleyusers\name{use} \alias{use} \title{Command to read in and attach data} \description{Command to read in data from Stata, SPSS, EpiInfo and .csv formats in addition to any R data frame } \usage{use(filename, dataFrame = .data, clear = TRUE, spss.missing = TRUE, tolower = TRUE) } \details{'use' reads in datasets from Dbase (.dbf), Stata (.dta), SPSS(.sav), EpiInfo(.rec) and Comma separated value (.csv) formats as well as R data frames. The destination data frame is saved in memory, by default as '.data', and automatically attached to the search path. This setting is the basis for other commands of 'epicalc' including 'des', 'summ', 'recode', 'label.var' etc. The 'use' command overwrites the destination data frame ('.data') with the new one.} \arguments{ \item{filename}{a character object ending with one of the following: .dbf, .dta, .sav, .rec, .csv (file with comma and header); data frames in R requires no quote} \item{dataFrame}{destination data frame where the read object is store} \item{clear}{equal to 'detachAllData()' before reading in the data set and attaching it to the search path} \item{spss.missing}{whether the values planned for missing for the SPSS dataset should be replaced with NA} \item{tolower}{whether all the names of the variables should be forced to lower case (only if the original file has one the following extensions: '.dbf', 'rec' and '.sav')} } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'read.table', 'read.dta', 'read.SPSS', etc and 'detachAllData'} \examples{ # data(BOD) library(foreign) write.dta(BOD, file="BOD.dta") rm(list=ls()) ls() use("BOD.dta", clear=FALSE) # The above lines write Stata format from R data frame. # In reality, one just types 'use("filename.dta")', if the file is available. des() file.remove("BOD.dta") # A better way to read an R dataset for exploration with Epicalc is use(BOD, clear=FALSE) des() summ() } \keyword{database} epicalc/man/unclassDataframe.rd0000644000176000001440000000260512026244665016273 0ustar ripleyusers\name{Unclass factors in a dataframe} \alias{unclassDataframe} \title{Unclass factor(s) in the default data frame} \description{This function unclasses factor(s) in the default data frame (.data). } \usage{ unclassDataframe (vars, dataFrame = .data) } \arguments{ \item{vars}{a vector of variables in the data frame, usually factors, that will be unclassed} \item{dataFrame}{data frame containing the variables} } \details{This function 'unclass'es several variables of class factor to their corresponding integer values. This is useful in further summation of items. } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'unclass', 'alpha', 'tableStack'} \examples{ expect1 <- c(3,4,3,2,5,3,2,5,2,4,4,3,2,4,4, 1,3,2,4,4,4,3,4,2,4,5,4,4,3,4) expect2 <- c(3,2,4,3,5,3,4,5,4,4,5,5,3,4,4, 3,4,2,3,5,3,4,4,2,4,5,4,4,3,5) found1 <- c(1,3,4,3,4,3,3,2,2,4,5,4,3,4,3, 1,1,2,3,4,4,1,1,3,4,5,4,1,4,2) found2 <- c(1,1,2,1,3,1,1,2,2,4,3,3,1,1,3, 3,1,1,2,1,1,1,1,1,3,5,4,4,1,1) .data <- data.frame(expect1, expect2, found1, found2) use(.data) pack() # clean up des() level.lab <- list("Very poor"=1, "Poor"=2, "Fair"=3, "Good"=4, "Very good"=5) for (i in 1:4) { .data[,i] <- factor(.data[,i]) levels(.data[,i]) <- level.lab } des() # All variables are now factors unclassDataframe(vars=c(1,4)) des() # Only variables #1 and #4 are 'unclass'ed } \keyword{aplot} epicalc/man/titleString.rd0000644000176000001440000000651712026244665015334 0ustar ripleyusers\name{titleString} \alias{titleString} \title{Replace commonly used words in Epicalc graph title} \description{Setting vocabularies for Epicalc graph title} \usage{ titleString (distribution.of = .distribution.of, by = .by, frequency = .frequency, locale = .locale(), return.look.up.table=FALSE) } \arguments{ \item{distribution.of}{A string denoting "Distribution of"} \item{by}{That for "by"} \item{frequency}{That for "Frequency"} \item{locale}{Logical value to overwrite .locale(). The initial value is FALSE} \item{return.look.up.table}{Should the look-up table be returned?} } \details{The two internationalization commands of Epicalc, 'setTitle' and 'titleString', work together to set the langauge and wording of titles of automatic graphs obtained from certain Epicalc functions. In general, 'setTitle' is simple and works well if the locale required fits in with the version of the operating system. The three commonly used words in the graph titles: "Distribution of", "by" and "Frequency", which are in English, are initially stored in three respective hidden objects '.distribution.of', '.by' and '.frequency' as well as in the look-up table within the 'titleString' function. When the locale is changed to a language other than English, the look-up table is used and wordings are changed accordingly. The function 'titleString' is useful when the user wants to change the strings stored in the look-up table. It changes the initial values of '.distribution.of', '.by' and '.frequency', respectively. The argument, 'locale', must be manually set to FALSE by the user to disable the use of the look-up table and to enable the use of the three objects assigned by the command instead. The two functions suppress each other. Use of 'setTitle' disables the effects of 'titleString', switching .locale() to TRUE and forcing Epicalc to read from the look-up table in 'titleString'. However, 'setTitle' does not overwrite the values assigned by the arguments of 'titleString'. The key and decisive switch object is .locale(). Once .locale() is set to FALSE, either manually or inside the 'titleString' command, the values of the three hidden objects will be used. Setting .locale() to TRUE, either manually or automatically by the 'setTitle' function, points the graph title to use the look-up table inside 'titleString'. Typing 'titleString()' without an argument displays the current contents of these three objects. The look-up table is also displayed if the return.look.up.table argument is set to TRUE. International users who want to add their specific locales and corresponding terminology to the look-up table or to suggest more appropriate terminology can contact the author. } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'setTitle'} \examples{ .data <- iris attach(.data) dotplot(Sepal.Length, by=Species) titleString(distribution.of="", by="grouped by", locale=FALSE) ## The above command is equivalent to the following three lines: ## .distribution.of <- "" ## .by <- "grouped by" ## .locale(FALSE) dotplot(Sepal.Length, by=Species) titleString() setTitle("English") dotplot(Sepal.Length, by=Species) titleString(return.look.up.table=TRUE) .locale(FALSE) dotplot(Sepal.Length, by=Species) titleString() .distribution.of <- "Distribution of" titleString() .by <- "by" titleString() detach(.data) rm(.data) } \keyword{misc} epicalc/man/Timing.Rd0000644000176000001440000000274212026244665014207 0ustar ripleyusers\name{Timing exercise} \alias{Timing} \docType{data} \title{ Dataset on time going to bed, waking up and arrival at a workshop} \description{ This dataset came from an interview survey on the workshop attendants on 2004-12-14. Note that the date of bed time is 2004-12-13 if the respondent went to bed before midnight. } \usage{data(Timing)} \format{ A data frame with 18 observations on the following 11 variables. \describe{ \item{\code{id}}{a numeric vector} \item{\code{gender}}{a factor with levels \code{male} \code{female}} \item{\code{age}}{a numeric vector} \item{\code{marital}}{a factor with levels \code{single} \code{married} \code{others}} \item{\code{child}}{a numeric vector indicating number of children} \item{\code{bedhr}}{a numeric vector indicating the hour of going to bed} \item{\code{bedmin}}{a numeric vector indicating the minute of going to bed} \item{\code{wokhr}}{a numeric vector indicating the hour of waking up} \item{\code{wokmin}}{a numeric vector indicating the minute of waking up} \item{\code{arrhr}}{a numeric vector indicating the hour of arrival at the workshop} \item{\code{arrmin}}{a numeric vector indicating the minute of arrival at the workshop} } } \examples{ data(Timing) use(Timing) des() arrival.time <- ISOdatetime(year=2004, month=12, day=14, hour=arrhr, min=arrmin, sec=0) summ(arrival.time, by= gender) } \keyword{datasets} epicalc/man/tally.events.rd0000644000176000001440000000504412026244665015446 0ustar ripleyusers\name{tally events} \alias{tally.events} \title{Tally a date variable by larger time unit} \description{Tabulate dates breakdown by week, month or year and plot the results} \usage{ \method{tally}{events}(x, by=NULL, breaks=c("day","week","month","year"), graph=TRUE, type="l", line.col="auto", legend = TRUE, legend.site="topright", legend.bg = "white", ylim="auto", cex=1, addmargins=TRUE, ...) } \arguments{ \item{x}{a date variable} \item{by}{a grouping elements} \item{breaks}{time unit for aggregation of the events} \item{graph}{whether the table be plotted} \item{type}{graph type} \item{line.col}{line colour} \item{legend}{wheter the legend will be produced if there are more than one groups} \item{legend.site}{a single character string indicating location of the legend. See details of ?legend} \item{legend.bg}{background colour of the legend} \item{ylim}{Y axis limits} \item{cex}{character expanding factor for the legend} \item{addmargins}{whether the margin values of the cross-table will be computed} \item{...}{additional graphic parameters passed on to other methods} } \details{This function produces table of events by day, month or year with zero cells included. It also plots the table. 'by' is a grouping variable, usually a factor. 'breaks' can be "day", "week", "month" and "year". 'type' can be "l", "p", "b", "c", "o", "h", "s" and "S" only when there is only group (by=NULL). Otherwise, graph type will be 'l'. 'line.col' control line colours in the graph and the legend If 'legend = TRUE" (by default), a legend box is automatically drawn on the "topright" corner of the graph. This character string can be changed to others such as, "topleft", "center", etc (see examples). } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'dotplot'} \examples{ random.dates <- as.Date("2001/1/1") + round(20*stats::runif(100)) tally.events(random.dates) # Compare with summ(random.dates) # and dotplot(random.dates) tally.events(random.dates, las=2) tally.events(random.dates, las=2, type = "h", lwd =2, ylim = c(0,20)) random.dates2 <- as.Date("2001/1/1") + round(500*stats::runif(100)) gender100 <- c(rep("F", 50),rep("M", 50)) tally.events(random.dates2, las=2, breaks="week") tally.events(random.dates2, las=2, breaks="month", type="h") tally.events(random.dates2, breaks="week", by=gender100) tally.events(random.dates2, breaks="month", by=gender100, cex=2, line.col=c("blue","brown"), lwd=2) } \keyword{database} epicalc/man/tabpct.rd0000644000176000001440000000423112026244665014270 0ustar ripleyusers\name{tabpct} \alias{tabpct} \title{Two-way tabulation with mosaic plot} \description{Two-way tabulation with automatic mosaic plot} \usage{ tabpct(row, column, decimal = 1, percent = c("both", "col", "row"), graph = TRUE, las = 0, main = "auto", xlab = "auto", ylab = "auto", col = "auto", ...) } \arguments{ \item{row, column}{variables} \item{decimal}{number of decimals for the percentage in the table} \item{percent}{orientation of the percentage in the table} \item{graph}{automatic graphing} \item{las}{orientation of group labelling} \item{main}{main title} \item{xlab}{X axis label} \item{ylab}{Y axis label} \item{col}{colours of the bars} \item{...}{additional arguments for 'table'} 0: always parallel to axis 1: always horizontal, 2: always perpendicular to the axis, 3: always vertical. } \details{'tabpct' gives column and row percent cross-tabulation as well as mosaic plot. The width of the bar in the plot denotes the relative proportion of the row variable. Inside each bar, the relative proportion denotes the distribution of column variables within each row variable. Note that 'row' and 'col' arguments of this function are for the table, not the mosaic plot and the default value for the 'percent' orientation is "both". Due to limitation of 'mosaicplot', certain graphic parameters such as 'cex.main', 'cex.lab' are not acceptable. The parameter 'main', 'xlab' and 'ylab' can be suppressed by making equal to " ". An additional line starting with 'title' can be used to write new main and label titles with 'cex.main' and 'cex.lab' specified. } \value{Tables of row and column percentage} \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'tab1', 'table', 'mosaicplot'} \examples{ data(Oswego) use(Oswego) agegr <- cut(age, breaks=c(0,20,40,60,80)) label.var(agegr, "age group") tabpct(agegr, ill) tabpct(agegr, ill, cex.axis=1) # enlarge value labels # To increase the size of the various titles: tabpct(agegr, ill, cex.axis=1, main="", xlab="", ylab="", col=c("blue","purple")) title(main="Diseased by Age group", cex.main=1.8, xlab="Age (years)",ylab="Diseased", cex.lab=1.5) } \keyword{aplot}epicalc/man/tableStack.rd0000644000176000001440000002221312026244665015070 0ustar ripleyusers\name{tableStack} \alias{tableStack} \title{Tabulation of variables in a stack form} \description{Tabulation of variables with the same possible range of distribution and stack into a new table with or without other descriptive statistics or to breakdown distribution of more than one row variables against a column variable} \usage{ tableStack (vars, minlevel = "auto", maxlevel = "auto", count = TRUE, na.rm =FALSE, means = TRUE, medians = FALSE, sds = TRUE, decimal = 1, dataFrame = .data, total = TRUE, var.labels = TRUE, var.labels.trunc =150, reverse = FALSE, vars.to.reverse = NULL, by = NULL, vars.to.factor = NULL, iqr = "auto", prevalence = FALSE, percent = c("column", "row", "none"), frequency=TRUE, test = TRUE, name.test = TRUE, total.column = FALSE, simulate.p.value = FALSE, sample.size=TRUE) } \arguments{ \item{vars}{a vector of variables in the data frame} \item{minlevel}{possible minimum value of items specified by user} \item{maxlevel}{possible maximum value of items specified by user} \item{count}{whether number of valid records for each item will be displayed} \item{na.rm}{whether missing value would be removed during calculation mean score of each person} \item{means}{whether means of all selected items will be displayed} \item{medians}{whether medians of all selected items will be displayed} \item{sds}{whether standard deviations of all selected items will be displayed} \item{decimal}{number of decimals displayed in the statistics} \item{dataFrame}{source data frame of the variables} \item{total}{display of means and standard deviations of total and average scores} \item{var.labels}{presence of descriptions of variables on the last column of output} \item{var.labels.trunc}{number of characters used for variable description} \item{reverse}{whether item(s) negatively correlated with other majority will be reversed} \item{vars.to.reverse}{variable(s) to reverse} \item{by}{a variable for column breakdown. If a single character (with quotes) is given, only the 'total column' will be displayed} \item{vars.to.factor}{variable(s) to be converted to factor for tabulaton} \item{iqr}{variable(s) to display median and inter-quartile range} \item{prevalence}{for logical variable, whether prevalence of the dichotomous row variable in each column subgroup will be displayed} \item{percent}{type of percentage displayed when the variable is categorical. Default is column} \item{frequency}{whether to display frequency in the cells when the variable is categorical} \item{test}{whether statistical test(s) will be computed} \item{name.test}{display name of the test and relevant degrees of freedom} \item{total.column}{whether to add 'total column' to the output or not} \item{simulate.p.value}{simulate P value for Fisher's exact test} \item{sample.size}{whether to display non-missing sample size of each column} } \details{This function simultaneously explores several variables with a fixed integer rating scale. For non-factor variables, the default values for tabulation are the mininum and the maximum of all variables but can be specified by user. The classes of the variables can be 'integer', 'factor' or 'logical but should not be any mixture of these. Unlike function 'alpha', the argument 'reverse' has a default value of FALSE. This argument is ignored if 'vars.to.reverse' is specified. Options for 'reverse', 'vars.to.reverse' and statistics of 'means', 'medians', 'sds' and 'total' are available only if the items are not factor. To obtain statistics of factor items, users need to use 'unclassDataframe' to convert them into integer. When the 'by' argument is given, 'reverse' and 'vars.to.reverse' do not apply. Instead, columns of the 'by' variable will be formed. A table will be created against each selected variable. If the variable is a factor or coerced to factor with 'vars.to.factor', cross-tabulation will result with percents as specified, ie. "column", "row", or "none" (FALSE). For a dichotomous row variable, if set to 'TRUE', the prevalence of row variable in the form of a fraction is displayed in each subgroup column. For continuous variables, means with standard deviations will be displayed. For variables with residuals that are not normally distributed or where the variance of subgroups are significantly not normally distributed (using a significance level of 0.01), medians and inter-quartile ranges will be presented if the argument 'iqr' is set to "auto" (by default). Users may specify a subset of the selected variables (from the 'vars' argument) to be presented in such a form. Otherwise, the argument could be set as any other character string such as "none", to insist to present means and standard deviations. When 'test = TRUE' (default), Pearson's chi-squared test (or a two-sided Fisher's exact test, if the sample size is small) will be carried out for a categorical variable or a factor. The two-sample t-test (or ANOVA F-test, when there are more than 2 levels of 'by') will be computed for a numeric variable. If the numeric variable is included in the 'iqr' argument, (manually or automatically), Wilcoxson's ranksum test or Kruskal-Wallis test will be performed instead. If the sample size of the numeric variable is too small in any group, the test is omitted and the problem reported. For Fisher's exact test, the default method employs 'simulate.p.value = FALSE'. See further explanation in 'fisher.test' procedure. If the dataset is extraordinarily large, the option may be manually set to TRUE. When 'by' is specified as a single character object (such as 'by="none"'), there will be no breakdown and all tests will be omitted. Only the 'total' column is shown. If this 'total column' is to accompany the 'by' breakdown, the argument 'total.column=TRUE' should be specified. The 'sample.size' is TRUE by default. The total number of records for each group is displayed in the first row of the output. However, the variable in each row may have some missing records, the information on which is not reported by tableStack. By default, Epicalc sets 'var.labels=TRUE' in order to give nice output. However, 'var.labels=FALSE' can sometimes be more useful during data exploration. Variable numbers as well as variable names are displayed instead of variable labels. Names and numbers of abnormally distributed variables, especially factors with too many levels, can be easily identified for further relevelling or recoding. } \value{an object of class 'tableStack' and 'list' when by=NULL \item{results}{an object of class 'noquote' which is used for print out} \item{items.reversed}{name(s) of variable(s) reversed} \item{total.score}{a vector from 'rowSums' of the columns of variables specified in 'vars'} \item{mean.score}{a vector from 'rowMeans' of the columns of variables specified in 'vars'} \item{mean.of.total.scores}{mean of total scores} \item{sd.of.total.scores}{standard deviation of total scores} \item{mean.of.average.scores}{mean of mean scores} \item{sd.of.average.scores}{standard deviation of mean scores} When 'by' is specified, an object of class 'tableStack' and 'table is returned. } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'table', 'tab1', 'summ', 'alpha', 'unclassDataframe'} \examples{ data(Oswego) use(Oswego) des() tableStack(bakedham:fruitsalad) tableStack(bakedham:fruitsalad, by= ill) tableStack(bakedham:fruitsalad, by= ill, prevalence=TRUE) tableStack(bakedham:fruitsalad, by= ill, percent=FALSE) tableStack(bakedham:fruitsalad, by= ill, percent=FALSE, name.test=FALSE) data(Cars93, package="MASS") use(Cars93) des() tableStack(vars=4:25, by=Origin) tableStack(vars=4:25, by="none") tableStack(vars=4:25, by=Origin, total.column=TRUE) tableStack(vars=4:25, by=Origin, total.column=TRUE, test=FALSE) data(Attitudes) use(Attitudes) tableStack(qa1:qa18) # May need full screen of Rconsole tableStack(qa1:qa18, var.labels.trunc=35) # Fits in with default R console screen tableStack(qa1:qa18, reverse=TRUE) -> a a ## Components of 'a' have appropriate items reversed a$mean.score -> mean.score a$total.score -> total.score pack() tableStack(c(qa1,qa13:qa18,mean.score,total.score), by=sex, test=FALSE) tableStack(c(qa15, qa17, mean.score:total.score), by=sex, iqr=c(qa17,total.score)) tableStack(c(qa15, qa17, mean.score:total.score), by=dep, iqr=c(qa17,total.score)) ## 'vars' can be mixture of different classes of variables highscore <- mean.score > 4 label.var(highscore, "high score") tableStack(mean.score:highscore, by=sex, iqr=total.score) data(Ectopic) use(Ectopic) des() tableStack(vars=3:4, by=outc) tableStack(vars=3:4, by=outc, percent="none") tableStack(vars=3:4, by=outc, prevalence = TRUE) tableStack(vars=3:4, by=outc, name.test = FALSE) ## Variable in numeric or factor data(Outbreak) use(Outbreak) des() # Comparison of exposure to food items between the two gender tableStack(vars=5:8, by=sex) # as continuous varaibles tableStack(vars=5:8, by=sex, vars.to.factor = 5:8) # as factors } \keyword{aplot} epicalc/man/tab1.rd0000644000176000001440000001003712026244665013643 0ustar ripleyusers\name{tab1} \alias{tab1} \alias{print.tab1} \title{One-way tabulation} \description{One-way tabulation with automatic bar chart and optional indicator variables generation} \usage{ tab1(x0, decimal = 1, sort.group = c(FALSE, "decreasing", "increasing"), cum.percent = !any(is.na(x0)), graph = TRUE, missing = TRUE, bar.values = c("frequency", "percent", "none"), horiz = FALSE, cex = 1, cex.names = 1, main = "auto", xlab = "auto", ylab = "auto", col = "auto", gen.ind.vars = FALSE, ...) \method{print}{tab1}(x, ...) } \arguments{ \item{x0}{a variable} \item{decimal}{number of decimals for the percentages in the table} \item{sort.group}{pattern for sorting categories in the table and in the chart. Default is no sorting.} \item{cum.percent}{presence of cumulative percentage in the output table. Default is TRUE for a variable without any missing values.} \item{graph}{whether a graph should be shown} \item{missing}{include the missing values category or in the graphic display} \item{bar.values}{include the value of frequency, percentage or none at the end of each bar} \item{horiz}{set the bar chart to horizontal orientation} \item{cex}{parameter for extension of characters or relative size of the bar.values} \item{cex.names}{character extension or relative scale of the name labels for the bars} \item{main}{main title of the graph} \item{xlab}{label of X axis} \item{ylab}{label of Y axis} \item{col}{colours of the bar} \item{gen.ind.vars}{whether the indicator variables will be generated} \item{x}{object of class 'tab1' obtained from saving 'tab1' results} \item{...}{further arguments passed to or used by other methods} } \details{'tab1' is an advanced one-way tabulation providing a nice frequency table as well as a bar chart. The description of the variable is also used in the main title of the graph. The bar chart is vertical unless the number of categories is more than six \strong{and} any of the labels of the levels consists of more than 8 characters \strong{or} 'horiz' is set to TRUE. For table has less than categories, the automatic colour is "grey". Otherwise, the graph will be colourful. The argument, 'col' can be overwritten by the user. The argument 'gen.ind.vars' is effective only if x0 is factor. } \value{Output table} \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'tabpct', 'label.var', 'table', 'barplot', 'model.matrix'} \examples{ tab1(state.division) tab1(state.division, bar.values ="percent") tab1(state.division, sort.group ="decreasing") tab1(state.division, sort.group ="increasing") tab1(state.division, col=c("chocolate","brown1","brown4"), main="Number of states in each zone") # For presentation, several 'cex' parameters should increase tab1(state.division, col=c("chocolate","brown1","brown4"), main="Number of states in each zone", cex.main=1.7, cex.name=1.2, cex.axis=1.3, cex.lab=1.3) data(Oswego) use(Oswego) tab1(ill) # Note the column of cumulative percentages in the table. tab1(ill, cum.percent=FALSE) tab1(chocolate) # Due to missing values, cumulative percentages are now automatically turned off. tab1(chocolate, cum.percent=TRUE) # Slightly too many columns in text! tab1(chocolate, missing=FALSE, bar.values="percent") agegr <- cut(age, breaks=c(0,10,20,30,40,50,60,70,80)) tab1(agegr) tab1(agegr, col="grey") # graphic output from older versions of 'tab1' tab1(agegr, col=c("red","yellow","blue")) # Colours recycled tab1(agegr, horiz=TRUE) # Keeping output table dev.off() tab1(agegr, graph = FALSE) -> a print(a) a # same results attributes(a) a$output.table class(a$output.table) # "matrix" # 'a$output.table' is ready for exporting to a .csv file by # write.csv(a$output.table, file="table1.csv") # "table1.csv" is now readable by a spreadsheet program # Generating indicator variables data(Compaq) use(Compaq) des() # Illustration of indicator variables head(cbind( ses, model.matrix(~ses -1))) tab1(ses, gen=TRUE) # indicator variables of 'ses' have been generated ls() # Four new names starting with 'ses' pack() des() } \keyword{aplot}epicalc/man/Suwit.Rd0000644000176000001440000000175512026244665014076 0ustar ripleyusers\name{Hookworm and blood loss} \alias{Suwit} \docType{data} \title{ Hookworm infection and blood loss: SEAJTM 1970} \description{ A study using radio-isotope to examine daily blood loss and number of hookworms infecting the patients. } \usage{data(Suwit)} \format{ A data frame with 15 observations on the following 3 variables. \describe{ \item{\code{id}}{a numeric vector} \item{\code{worm}}{a numeric vector: number of worms} \item{\code{bloss}}{a numeric vector: estimated daily blood loss (mg/day)} } } \source{Areekul, S., Devakul, K., Viravan, C., Harinasuta, C. 1970 Studies on blood loss, iron absorption and iron reabsorption in hookworm patients in Thailand. \emph{Southeast Asian J Trop Med Pub Hlth} \bold{1(4)}: 519-523.} \references{ ~~ possibly secondary sources and usages ~~ } \examples{ data(Suwit) use(Suwit) des() plot(worm, bloss, type="n") text(worm, bloss, labels=id) abline(lm(bloss ~ worm), col="red") } \keyword{datasets} epicalc/man/summ.rd0000644000176000001440000000334712026244665014003 0ustar ripleyusers\name{summ} \alias{summ} \title{Summary with graph} \description{Summary of data frame in a convenient table. Summary of a variable with statistics and graph} \usage{ summ(x = .data, by = NULL, graph = TRUE, box = FALSE, pch = 18, ylab = "auto", main = "auto", cex.X.axis = 1, cex.Y.axis = 1, dot.col = "auto", ...) } \details{For data frames, 'summ' gives basic statistics of each variable in the data frame. The other arguments are ignored. For single vectors, a sorted dot chart is also provided, if graph=TRUE (default).} \arguments{ \item{x}{'x' can be a data frame or a vector. 'summ()' is the same as 'summ(.data)'} \item{by}{a stratification variable, valid only when x is a vector} \item{graph}{automatic plot (sorted dot chart) if 'x' is a vector} \item{box}{add a boxplot to the graph (by=NULL)} \item{pch}{plot characters} \item{ylab}{annotation on Y axis} \item{main}{main title of the graph} \item{cex.X.axis}{character extension scale of X axis} \item{cex.Y.axis}{character extension scale of Y axis} \item{dot.col}{colour(s) of plot character(s)} \item{...}{additional graph parameters} } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'summary', 'use', 'des'} \examples{ data(BP) use(BP) summ() summ(sex) summ(sbp, box=TRUE) summ(sbp, dot.col="brown") summ(sbp, by=sex) # Changing dot colours summ(sbp, by=sex, dot.col = c("blue","orange")) # Enlarging main title and other elements summ(sbp, by=sex, cex.main=1.5, cex.X.axis=1.5, cex.Y.axis=1.7) # Free vector summ(rnorm(1000)) summ((1:100)^2, by=rep(1:2, 50)) summ((1:100)^2, by=rep(c("Odd","Even"), 50), main="Quadratic distribution by odd and even numbers") } \keyword{database} epicalc/man/sortBy.rd0000644000176000001440000000252412026244665014300 0ustar ripleyusers\name{Sort data frame by variable(s)} \alias{sortBy} \title{Sort data frame by variable(s)} \description{Sort the whole dataset by one or more variables} \usage{ sortBy(..., dataFrame = .data, inclusive = TRUE) } \arguments{ \item{...}{index variable(s) used for sorting} \item{dataFrame}{Destination data frame where all variables of the same length are sorted} \item{inclusive}{whether vectors outside the default data frame should also be sorted} } \details{The whole dataset can be sorted by an index variable(s) inside the (...). If 'inclusive = TRUE', variables outside the data frame with same length will also be sorted. } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'sort', 'order'} \examples{ sbp <- c(120, 100, 110, 120, 140, 120, NA, NA) dbp <- c( 80, 80, 70, 80, 70, NA, 70, 60) age <- c(37, 32, 24, 33, 31, 30, 26, 25) data1 <- data.frame(sbp, dbp, age) use(data1) age2 <- age^2 sortBy(age, inclusive = FALSE) age2 # unsorted use(data1) age2 <- age^2 sortBy(age, inclusive = TRUE) age2 # sorted des() .data sortBy(age, decreasing=TRUE) .data ## Note that the argument of 'sortBy' must not be concatenated vectors data(Familydata) use(Familydata) .data sortBy(money, sex) # correct .data use(Familydata) # Read in the dataset afresh sortBy(c(money, sex)) # errors. .data } \keyword{database}epicalc/man/SO2.Rd0000644000176000001440000000124212026244665013355 0ustar ripleyusers\name{Air Pollution} \alias{SO2} \docType{data} \title{Dataset on air pollution and deaths in UK} \description{ Deaths in London from 1st-15th Dec 1952 } \usage{data(SO2)} \format{ A data frame with 15 observations on the following 4 variables. \describe{ \item{\code{day}}{a numeric vector: the day in Dec 1952} \item{\code{deaths}}{a numeric vector: number of deaths} \item{\code{smoke}}{a numeric vector: atmospheric smoke (mg/cu.m)} \item{\code{SO2}}{a numeric vector: atmospheric sulphur dioxide (parts/million)} } } \source{ from John F. Osborn, Statistical Exercises in Medical Research, Blackwell 1979 } \keyword{datasets} epicalc/man/Sleep3.Rd0000644000176000001440000000164412026244665014113 0ustar ripleyusers\name{Sleepiness} \alias{Sleep3} \docType{data} \title{Dataset on sleepiness in a workshop} \description{ Sleepiness among participants in a workshop} \usage{data(Sleep3)} \format{ A data frame with 15 observations on the following 8 variables. \describe{ \item{\code{id}}{a numeric vector} \item{\code{gender}}{a factor with levels \code{male} \code{female}} \item{\code{dbirth}}{a Date vector for birth date} \item{\code{sleepy}}{a numeric vector for any experience of sleepiness in the class: \code{0=no} \code{1=yes}} \item{\code{lecture}}{a numeric vector for ever felt sleepy during a lecture: \code{0=no} \code{1=yes}} \item{\code{grwork}}{a numeric vector for ever felt sleepy during a group work: \code{0=no} \code{1=yes}} \item{\code{kg}}{a numeric vector} \item{\code{cm}}{a numeric vector} } } \examples{ data(Sleep3) use(Sleep3) des() } \keyword{datasets} epicalc/man/shapiro.qqnorm.rd0000644000176000001440000000131712026244665015776 0ustar ripleyusers\name{shapiro.qqnorm} \alias{shapiro.qqnorm} \title{Qqnorm plots with Shapiro-Wilk's test} \description{Quantile-normal plots with Shapiro-Wilk's test result integrated} \usage{ shapiro.qqnorm (x, ...) } \arguments{ \item{x}{A numeric vector} \item{...}{Graphical parameters passed to 'par'} } \details{ To test a variable 'x' against the normal distribution, a qqnorm plot is integrated with the Shapiro-Wilk test to enhance interpretation. } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'shapiro.test', 'qqnorm', 'par'} \examples{ x <- rnorm(10) a <- LETTERS[1:10] shapiro.qqnorm(x, pch=a, col="red") qqline(x, lty=2, col="black") } \keyword{htest} epicalc/man/setTitle.rd0000644000176000001440000000275112026244665014615 0ustar ripleyusers\name{setTitle} \alias{setTitle} \title{Setting the displayed language of Epicalc graph title} \description{Setting locale and internationalizing Epicalc graph title} \usage{ setTitle(locale) } \arguments{ \item{locale}{A string denoting international language of choice} } \details{On calling 'library(epicalc)', '.locale()' has an inital value of FALSE, ie. the titles of Epicalc's automatic graphs are displayed in the English language. 'setTitle' has two effects. It selects the locale and resets the hidden object '.locale()' to TRUE. The command internationalizes the title of automatic graphs created by Epicalc according to 'locale' given in the function's argument. If '.locale()' is TRUE, then the automatic graphs produced by Epicalc commands, such as 'summ(var)' or 'tab1(var)' or 'tabpct(var1,var2)', will lookup a language conversion table for the graph title and the title will be changed accordingly. Internationalization of the title can be disabled by typing '.locale(FALSE)'. This has no effect of locale as a whole unless it is reset to English by issuing the command 'setTitle("English")'. } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'Sys.setlocale', 'Sys.getlocale' and 'titleString'} \examples{ use(iris) summ(Sepal.Length, by=Species) setTitle("English") dotplot(Sepal.Length, by=Species) setTitle("Malay") dotplot(Sepal.Length, by=Species) setTitle("Spanish") dotplot(Sepal.Length, by=Species) detach(.data) rm(.data) } \keyword{database} epicalc/man/sampsize.rd0000644000176000001440000001656312026244665014661 0ustar ripleyusers\name{sampsize} \alias{n.for.survey} \alias{n.for.2means} \alias{n.for.cluster.2means} \alias{n.for.2p} \alias{n.for.cluster.2p} \alias{n.for.equi.2p} \alias{n.for.noninferior.2p} \alias{n.for.lqas} \title{Sample size calculation} \description{Sample size calculations for epidemiological studies} \usage{ n.for.survey (p, delta = "auto", popsize = NULL, deff = 1, alpha = 0.05) n.for.2means (mu1, mu2, sd1, sd2, ratio = 1, alpha = 0.05, power = 0.8) n.for.cluster.2means (mu1, mu2, sd1, sd2, alpha = 0.05, power = 0.8, ratio = 1, mean.cluster.size = 10, previous.mean.cluster.size = NULL, previous.sd.cluster.size = NULL, max.cluster.size = NULL, min.cluster.size = NULL, icc = 0.1) n.for.2p (p1, p2, alpha = 0.05, power = 0.8, ratio = 1) n.for.cluster.2p (p1, p2, alpha = 0.05, power = 0.8, ratio = 1, mean.cluster.size = 10, previous.mean.cluster.size = NULL, previous.sd.cluster.size = NULL, max.cluster.size = NULL, min.cluster.size = NULL, icc = 0.1) n.for.equi.2p(p, sig.diff, alpha=.05, power=.8) n.for.noninferior.2p (p, sig.inferior, alpha = 0.05, power = 0.8) n.for.lqas (p0, q = 0, N = 10000, alpha = 0.05, exact = FALSE) } \arguments{ \item{p}{estimated probability} \item{delta}{difference between the estimated prevalence and one side of the 95 percent confidence limit (precision)} \item{popsize}{size of the finite population} \item{deff}{design effect for cluster sampling} \item{alpha}{significance level} \item{mu1, mu2}{estimated means of the two populations} \item{sd1, sd2}{estimated standard deviations of the two populations} \item{ratio}{n2/n1} \item{mean.cluster.size}{mean of the cluster size planned in the current study} \item{previous.mean.cluster.size, previous.sd.cluster.size}{mean and sd of cluster size from a previous study} \item{max.cluster.size, min.cluster.size}{maximum and minimum of cluster size in the current study} \item{icc}{intraclass correlation coefficient} \item{p1, p2}{estimated probabilities of the two populations} \item{power}{power of the study} \item{sig.diff}{level of difference consider as being clinically significant} \item{sig.inferior}{level of reduction of effectiveness as being clinically significant} \item{p0}{critical proportion beyond which the lot will be rejected} \item{q}{critical number of faulty pieces found in the sample, beyond which the lot will be rejected} \item{N}{lot size} \item{exact}{whether the exact probability is to be computed} } \details{'n.for.survey' is used to compute the sample size required to conduct a survey. When 'delta="auto"', delta will change according to the value of p. If 0.3 <= p <= 0.7, delta = 0.1. If 0.1 <= p < .3, or 0.7< p <=0.9, then delta=.05. Finally, if p < 0.1, then delta = p/2. If 0.9 < p, then delta = (1-p)/2. When cluster sampling is employed, the design effect (deff) has to be taken into account. 'n.for.2means' is used to compute the sample size needed for testing the hypothesis that the difference of two population means is zero. 'n.for.cluster.2means' and 'n.for.cluster.2p' are for cluster (usually randomized) controlled trial. 'n.for.2p' is used to the compute the sample size needed for testing the hypothesis that the difference of two population proportions is zero. 'n.for.equi.2p' is used for equivalent trial with equal probability of success or fail being p for both groups. 'sig.diff' is a difference in probability considered as being clinically significant. If both sides of limits of 95 percent CI of the difference are within +sig.diff or -sig.diff, there would be neither evidence of inferiority nor of superiority of any arm. 'n.for.noninferior.2p' is similar to 'n.for.equi.2p' except if the lower limit of 95 percent CI of the difference is higher than the sig.inferior level, the hypothesis of inferiority would be rejected. For a case control study, p1 and p2 are the proportions of exposure among cases and controls. For a cohort study, p1 and p2 are proportions of positive outcome among the exposed and non-exposed groups. 'ratio' in a case control study is controls:case. In cohort and cross-sectional studies, it is non-exposed:exposed. LQAS stands for Lot Quality Assurance Sampling. The sample size n is determined to test whether the lot of a product has a defective proportion exceeding a critical proportion, p0. Out of the sample tested, if the number of defective specimens is greater than q, the lot is considered not acceptable. This concept can be applied to quality assurance processes in health care. When any parameter is a vector of length > 5, a table of sample size by the varying values of parameters is displayed. } \value{a list. 'n.for.survey' returns an object of class "n.for.survey" 'n.for.2p' returns an object of class "n.for.2p" 'n.for.2means' returns an object of class "n.for.2means" 'n.for.lqas' returns an object of class "n.for.lqas" Each type of returned values consists of vectors of various parameters in the formula and the required sample size(s). } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'power.for.2means', 'power.for.2p'} \references{ Eldridge SM, Ashby D, Kerry S. 2006 Sample size for cluster randomized trials: effect of coefficient of variation of cluster size and analysis method. \emph{Int J Epidemiol} \bold{35(5)}: 1292-300. } \examples{ # In a standard survey to determine the coverage of immunization needed using # a cluster sampling technique on a population of approximately 500000, and # an estimated prevalence of 70 percent, design effect is assumed to be 2. n.for.survey( p = .8, delta = .1, popsize = 500000, deff =2) # 123 needed # To see the effect of prevalence on delta and sample size n.for.survey( p = c(.5, .6, .7, .8, .9, .95, .99)) # Testing the efficacy of measles vaccine in a case control study . # The coverage in the non-diseased population is estimated at 80 percent. # That in the diseased is 60 percent. n.for.2p(p1=.8, p2=.6) # n1=n2=91 needed # A randomized controlled trial testing cure rate of a disease of # 90 percent by new drugs and 80 percent by the old one. n.for.2p(p1=.9, p2=.8) # 219 subjects needed in each arm. # To see the effect of p1 on sample size n.for.2p(p1=seq(1,9,.5)/10, p2=.5) # A table output # The same randomized trial to check whether the new treatment is 5 percent # different from the standard treatment assuming both arms has a common # cure rate of 85 percent would be n.for.equi.2p(p=.85, sig.diff=0.05) # 801 each. # If inferior arm is not allow to be lower than -0.05 (5 percent less effective) n.for.noninferior.2p(p=.85, sig.inferior=0.05) # 631 each. # A cluster randomized controlled trial to test whether training of village # volunteers would result in reduction of prevalence of a disease from 50 percent # in control villages to 30 percent in the study village with a cluster size # varies from 250 to 500 eligible subjects per village (mean of 350) and the # intraclass correlation is assumed to be 0.15 n.for.cluster.2p(p1=.5, p2=.3, mean.cluster.size = 350, max.cluster.size = 500, min.cluster.size = 250, icc = 0.15) # A quality assurance to check whether the coding of ICD-10 is faulty # by no more than 2 percent.The minimum sample is required. # Thus any faulty coding in the sample is not acceptable. n.for.lqas(p0 = .02, q=0, exact = TRUE) # 148 non-faulty checks is required # to support the assurance process. n.for.lqas(p0 = (1:10)/100, q=0, exact = FALSE) } \keyword{math}epicalc/man/roc.rd0000644000176000001440000000751312026244665013604 0ustar ripleyusers\name{ROC} \alias{lroc} \alias{roc.from.table} \title{ROC curve} \description{Receiver Operating Characteristic curve of a logistic regression model and a diagnostic table} \usage{ lroc(logistic.model, graph = TRUE, add = FALSE, title = FALSE, line.col = "red", auc.coords = NULL, grid = TRUE, grid.col = "blue", ...) roc.from.table(table, graph = TRUE, add = FALSE, title = FALSE, line.col = "red", auc.coords = NULL, grid = TRUE, grid.col = "blue", ...) } \arguments{ \item{logistic.model}{A model from logistic regression} \item{table}{A cross tabulation of the levels of a test (rows) vs a gold standard positive and negative (columns)} \item{graph}{Draw ROC curve} \item{add}{Whether the line is drawn on the existing ROC curve} \item{title}{If true, the model will be displayed as main title} \item{line.col}{Color of the line} \item{auc.coords}{Coordinates for label of 'auc' (area under curve)} \item{grid}{Whether the grid should be drawn} \item{grid.col}{Grid colour, if drawn} \item{...}{Additional graphic parameters} } \details{ 'lroc' graphs the ROC curve of a logistic regression model. If `table=TRUE', the diagnostic table based on the regression will be printed out. 'roc.from.table' computes the change of sensitivity and specificity of each cut point and uses these for drawing the ROC curve. In both cases, the area under the curve is computed. } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'glm'} \examples{ # Single ROC curve from logistic regression # Note that 'induced' and 'spontaneous' are both originally continuous variables model1 <- glm(case ~ induced + spontaneous, data=infert, family=binomial) logistic.display(model1) # Having two spontaneous abortions is quite close to being infertile! # This is actually not a causal relationship lroc(model1, title=TRUE, auc.coords=c(.5,.1)) # For PowerPoint presentation, the graphic elements should be enhanced as followed lroc(model1, title=TRUE, cex.main=2, cex.lab=1.5, col.lab="blue", cex.axis=1.3, lwd=3) lroc1 <- lroc(model1) # The main title and auc text have disappeared model2 <- glm(case ~ spontaneous, data=infert, family=binomial) logistic.display(model2) lroc2 <- lroc(model2, add=TRUE, line.col="brown", lty=2) legend("bottomright",legend=c(lroc1$model.description, lroc2$model.description), lty=1:2, col=c("red","brown"), bg="white") title(main="Comparison of two logistic regression models") lrtest(model1, model2) # Number of induced abortions is associated with increased risk for infertility # Various form of logistic regression # Case by case data data(ANCdata) use(ANCdata) glm1 <- glm(death ~ anc + clinic, binomial, data=.data) lroc(glm1) # Frequency format data(ANCtable) ANCtable use(ANCtable) death <- factor (death) levels (death) <- c("no","yes") anc <- factor (anc) levels (anc) <- c("old","new") clinic <- factor (clinic) levels (clinic) <- c("A","B") pack() glm2 <- glm(death ~ anc + clinic, binomial, weights=Freq, data=.data) lroc(glm2) # yes/no format .data$condition <- c(1,1,2,2,3,3,4,4) data2 <- reshape (.data, timevar="death", v.name="Freq", idvar="condition", direction="wide") data2 glm3 <- glm(cbind(Freq.yes, Freq.no) ~ anc + clinic, family=binomial, data=data2) lroc(glm3) # ROC from a diagnostic table table1 <- as.table(cbind(c(1,27,56,15,1),c(0,0,10,69,21))) colnames(table1) <- c("Non-diseased", "Diseased") rownames(table1) <- c("15-29","30-44","45-59","60-89","90+") table1 roc.from.table(table1) roc.from.table(table1, title=TRUE, auc.coords=c(.4,.1), cex=1.2) # Application of the returned list roc1 <- roc.from.table(table1, graph=FALSE) cut.points <- rownames(roc1$diagnostic.table) text(x=roc1$diagnostic.table[,1], y=roc1$diagnostic.table[,2], labels=cut.points, cex=1.2, col="brown") } \keyword{array} epicalc/man/risk.display.rd0000644000176000001440000002153612026244665015436 0ustar ripleyusers\name{Risk.display} \alias{logistic.display} \alias{clogistic.display} \alias{cox.display} \alias{regress.display} \alias{idr.display} \alias{mlogit.display} \alias{ordinal.or.display} \alias{tableGlm} \alias{print.display} \title{Tables for multivariate odds ratio, incidence density etc} \description{Display of various epidemiological modelling results in a medically understandable format} \usage{ logistic.display(logistic.model, alpha = 0.05, crude = TRUE, crude.p.value = FALSE, decimal = 2, simplified = FALSE) clogistic.display(clogit.model, alpha = 0.05, crude=TRUE, crude.p.value=FALSE, decimal = 2, simplified = FALSE) cox.display (cox.model, alpha = 0.05, crude=TRUE, crude.p.value=FALSE, decimal = 2, simplified = FALSE) regress.display(regress.model, alpha = 0.05, crude = FALSE, crude.p.value = FALSE, decimal = 2, simplified = FALSE) idr.display(idr.model, alpha = 0.05, crude = TRUE, crude.p.value = FALSE, decimal = 2, simplified = FALSE) mlogit.display(multinom.model, decimal = 2, alpha = 0.05) ordinal.or.display(ordinal.model, decimal = 3, alpha = 0.05) tableGlm (model, modified.coeff.array, decimal) \method{print}{display}(x, ...) } \details{R provides several epidemiological modelling techniques. The functions above display these results in a format easier for medical people to understand. The function 'tableGlm' is not for general use. It is called by other display functions to receive the 'modified.coeff.array' and produce the output table. The argument 'simplified' has a default value of 'FALSE'. It works best if the 'data' argument has been supplied during creation of the model. Under this condition, the output has three parts. Part 1 (the first line) indicates the type of the regression and the outcome. For logistic regression, if the outcome is a factor then the referent level is shown. Part 2 shows the main output table where each independent variable coefficient is displayed. If the independent variable is continuous (class numeric) then name of the variable is shown (or the descriptive label if it exists). If the variable is a factor then the name of the level is shown with the referent level omitted. In this case, the name of the referent level and the statistic testing for group effects are displayed. An F-test is used when the model is of class 'lm' or 'glm' with 'family=gaussian' specified. A Likelihood Ratio test is performed when the model is of class 'glm' with 'family = binomial' or 'family = poisson' specified and for models of class 'coxph' and 'clogit'. These tests are carried out with the records available in the model, not necessary all records in the full 'data' argument. The number of records in the model is displayed in the part 3 of the output. When 'simplified=TRUE', the first and the last parts are omitted from the display. The result is an object of class 'display' and 'list'. Their apparence on the R console is controlled by 'print.display'. The 'table' attribute of these 'display' objects are ready to write (using 'write.csv') to a .csv file which can then be copied to a manuscript document. This approach can substantially reduce both the time and errors produced due to conventional manual copying. } \arguments{ \item{logistic.model}{a model from a logistic regression} \item{clogit.model}{a model from a conditional logistic regression} \item{regress.model}{a model from a linear regression} \item{cox.model}{a model from a cox regression} \item{idr.model}{a model from a Poisson regression or a negative binomial regression} \item{multinom.model}{a model from a multinomial or polytomous regression} \item{ordinal.model}{a model from an ordinal logistic regression} \item{alpha}{significance level} \item{crude}{whether crude results and their confidence intervals should also be displayed} \item{crude.p.value}{whether crude P values should also be displayed if and only if 'crude=TRUE'} \item{decimal}{number of decimal places displayed} \item{simplified}{whether the display should be simplified} \item{model}{model passed from logistic.display or regress.display to tableGlm} \item{modified.coeff.array}{array of model coefficients sent to the function 'tableGlm' to produce the final output} \item{x}{object obtained from these 'display' functions} \item{...}{further arguments passed to or used by methods} } \note{Before using these 'display' functions, please note the following limitations. 1) Users \bold{should} define the 'data' argument of the model. 2) The names of the independent variables \bold{must} be a subset of the names of the variables in the 'data' argument. Sometimes, one of more variables are omitted by the model due to collinearity. In such a case, users have to specify 'simplified=TRUE' in order to get the display function to work. 3) Under the following conditions, 'simplified' will be forced to TRUE and 'crude' forced to FALSE. 3.1) The names of the independent variables contain a function such as 'factor()' or any '\$' sign. 3.2) The levels of the factor variables contain any ':' sign. 3.3) There are more than one interaction terms in the model 3.4) The 'data' argument is missing in the conditional logistic regression and Cox regression model 4) For any other problems with these display results, users are advised to run 'summary(model)' or 'summary(model)$coefficients' to check the consistency between variable names in the model and those in the coefficients. The number in the latter may be fewer than that in the former due to collinearity. In this case, it is advised to specify 'simplified=TRUE' to turn off the attempt to tidy up the rownames of the output from 'summary(model)$coeffients'. The output when 'simplified=TRUE' is more reliable but less understandable. } \author{Virasakdi Chongsuvivatwong \email{ } } \value{'logistic.display', 'regress.display', 'clogit.display' and 'cox.display', each produces an output table. See 'details'.} \seealso{'glm', 'confint'} \examples{ model0 <- glm(case ~ induced + spontaneous, family=binomial, data=infert) summary(model0) logistic.display(model0) data(ANCdata) glm1 <- glm(death ~ anc + clinic, family=binomial, data=ANCdata) logistic.display(glm1) logistic.display(glm1, simplified=TRUE) library(MASS) # necessary for negative binomial regression data(DHF99); use(DHF99) model.poisson <- glm(containers ~ education + viltype, family=poisson, data=.data) model.nb <- glm.nb(containers ~ education + viltype, data=.data) idr.display(model.poisson) -> poiss print(poiss) # or print.display(poiss) or poiss idr.display(model.nb) -> nb print(nb) nb # same result write.csv(nb$table, file="tablenb.csv") getwd() ## You may go to this directory (folder) and have a look ## at the file using a spreadsheet programme. data(VC1to6) use(VC1to6) fsmoke <- factor(smoking) levels(fsmoke) <- list("no"=0, "yes"=1) pack() clr1 <- clogit(case ~ alcohol + fsmoke + strata(matset), data=.data) clogistic.display(clr1) data(BP) use(BP) age <- as.numeric(as.Date("2000-01-01") - birthdate)/365.25 agegr <- pyramid(age,sex, bin=20)$ageGroup hypertension <- sbp >= 140 | dbp >=90 pack() model1 <- glm(hypertension ~ sex + agegr + saltadd, family=binomial, data=.data) logistic.display(model1) -> table3 attributes(table3) table3 table3$table write.csv(table3$table, file="table3.csv") # Note $table ## Have a look at this file in Excel, or similar spreadsheet program file.remove(file="table3.csv") model2 <- glm(hypertension ~ sex * age + sex * saltadd, family=binomial, data=.data) logistic.display(model2) # More than 1 interaction term so 'simplified turned to TRUE reg1 <- lm(sbp ~ sex + agegr + saltadd, data=.data) regress.display(reg1) reg2 <- glm(sbp ~ sex + agegr + saltadd, family=gaussian, data=.data) regress.display(reg2) data(Compaq) cox1 <- coxph(Surv(year, status) ~ hospital + stage * ses, data=Compaq) cox.display(cox1, crude.p.value=TRUE) # Ordinal logistic regression library(nnet) options(contrasts = c("contr.treatment", "contr.poly")) house.plr <- polr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) house.plr ordinal.or.display(house.plr) # Polytomous or multinomial logistic regression house.multinom <- multinom(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) summary(house.multinom) mlogit.display(house.multinom, alpha=.01) # with 99 percent confidence limits. } \keyword{database} epicalc/man/rename.rd0000644000176000001440000000446612026244665014274 0ustar ripleyusers\name{Rename} \alias{rename} \alias{ren} \alias{rename.default} \alias{rename.var} \alias{rename.pattern} \title{Rename variable(s) in the default data frame} \description{Rename a variable or change a pattern of variable names.} \usage{ rename(x1, x2, dataFrame = .data, ...) \method{rename}{default}(x1, x2, dataFrame = .data, ...) \method{rename}{var}(x1, x2, dataFrame = .data, ...) \method{rename}{pattern}(x1, x2, dataFrame = .data, printNote=TRUE, ...) ren(x1, x2, dataFrame = .data, ...) } \arguments{ \item{x1}{a variable or a pattern among the names of the variables inside .data.} \item{x2}{new name or new pattern of the variable(s). \tabular{llll}{ \tab FUNCTION \tab 'x1' \tab 'x2' \cr \tab 'rename.var' \tab old variable\tab new variable\cr \tab 'rename.pattern' \tab old pattern \tab new pattern \cr } } \item{dataFrame}{a data frame, the variable(s) of which will be renamed} \item{printNote}{whether the table of old names and new names of the variables(s) should be printed out.} \item{...}{further arguments passed to or used by other methods.} } \details{'rename.var' renames variable 'x1' to 'x2'. Both arguments may have the quotes omitted. 'rename.pattern' changes substring 'x1' in any names of variables inside .data to 'x2'. With 'printNote=TRUE', a table with columns of old and new variables will be displayed. 'rename.var' is called if 'x1' perfectly matches with a variable name. 'rename.pattern' is called if the pattern 'x1' is found as a substring among the variable names. Otherwise, an error will occur. Finally, 'ren' is the abbreviated form of 'rename' without any suffix} \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'recode' and 'label.var'} \examples{ data(Oswego) use(Oswego) des() rename.var("ill", "sick") des() # Note change of the 4th variable name rename(timesupper, time.of.supper) # Note that '.var' and the quotes '"' can be omitted. # But not 'rename(timesupper, "time of supper")'. Why? # Even shorter with 'ren' ren(sex, gender) des() rename.pattern("ll", "LL") des() rename("onset", "onset_") # '.pattern' can be omitted but not the quotes. des() } \keyword{database} epicalc/man/recode.rd0000644000176000001440000000725212026244665014262 0ustar ripleyusers\name{recode} \alias{recode} \alias{recode.default} \alias{recode.is.na} \title{Recode variable(s)} \description{Change value(s) of variable(s) in the default data frame} \usage{ recode(vars, ...) \method{recode}{default}(vars, old.value, new.value, dataFrame = .data, ...) \method{recode}{is.na}(vars, new.value = 0, dataFrame = .data, ...) } \arguments{ \item{vars}{a variable or variables with the same recoding scheme} \item{old.value}{original values or a condition} \item{new.value}{new values for all variables listed} \item{dataFrame}{a data frame} \item{...}{further arguments passed to or used by other methods.} } \details{'recode' is very useful for recoding missing values but can also be used for other purposes. 'vars' can be a single variable or a list of variables in the format of list(var1, var2, var3) or c(var1, var2, var3), which will be recoded simultaneously under the same scheme. Both 'old.value' and 'new.value' can be vectors of equal length. The elements of old.value and new.value will be matched by corresponding orders. However, 'new.value' can have a single element into which all the old values are recoded. The argument 'old.value' can be also be a condition for recoding the 'vars' into the single new.value regardless of the old value. Note that changing the value label of a variable's levels can be done with 'levels(var)[levels(var)=="old name"] <- "new name"'. However, Epicalc 'recode' is more efficient in changing several factors using the same scheme. See example. All the 'recode'd vars are automatically 'pack'ed into the default data frame which is synchronize with the one in the search path. 'recode.is.na' is used to recode any missing value of one or more variable to a common 'new.value', which is zero by default. } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'replace', 'lookup'} \examples{ age <- c( 37, 99, 24, 33, 31, 30, 26, 25) systolic <- c(120, 120, 110, 120, 130, 120, 888, 999) diastolic <- c( 80, 80, 70, 80, 70, 999, 70, 60) sick <- c( 1, 2, 2, 1, 2, 2, 2, NA) treated <- c( 2, 1, 2, 2, 1, 2, 2, 1) yesno <- c("Y", "N") sick <- factor(sick, labels=yesno) treated <- factor(treated, labels=yesno) .data <- data.frame(age, systolic, diastolic, sick, treated) use(.data) pack() # 'pack() integate all variables into .data # to avoid confusion with free vectors. # The above lines generate a hypothetical data frame. # In reality, one just exploits 'use("datafile")', if the "datafile" exists. .data summ() recode(age, old.value=99, new.value=NA) summ() recode(vars=c(systolic, diastolic), 999, NA) # The value 888 is not recoded. summ() recode(systolic, systolic > 250, NA) summ() table(sick, treated) recode(vars=c(sick, treated), old.value="Y", new.value="yes") table(sick, treated) # Recode both sick and treated to "N" if sick status is missing. recode(vars=c(sick,treated), is.na(sick), new.value="N") table(sick, treated) # Recode more than one old values data(VCT) use(VCT) des() table(A16); table(A17); table(A18) recode(vars=A16:A18, c("willing","willing if have money"), "willing") table(A16); table(A17); table(A18) # Recode two last categories to missing recode(A16:A18, c("not relevant","not answer"), NA) table(A16); table(A17); table(A18) # Use 'recode.is.na' to recode NA to "missing data" recode.is.na(vars=A16:A18, "missing data") table(A16); table(A17); table(A18) recode(vars=A4:A5, 999, NA) summ() # recode back from NA to 0 recode.is.na(vars=A4:A5) # Note that new value is 0 by default # Swaping data(Hakimi) use(Hakimi) des() summ() table(treatment) recode(treatment, c(1,2), c(2,1)) table(treatment) } \keyword{database}epicalc/man/pyramid.rd0000644000176000001440000000551612026244665014467 0ustar ripleyusers\name{pyramid} \alias{pyramid} \title{Population pyramid} \description{Create a population pyramid from age and sex} \usage{ pyramid (age, sex, binwidth = 5, inputTable = NULL, printTable = FALSE, percent = c("none", "each", "total"), col.gender = NULL, bar.label = "auto", decimal = 1, col = NULL, cex.bar.value = 0.8, cex.axis = 1, main = "auto", cex.main = 1.2, ...) } \arguments{ \item{age}{a numeric variable for age} \item{sex}{a variable of two levels for sexes, can be numeric but preferrably factor with labelled levels or characters} \item{binwidth}{bin width of age for each bar} \item{inputTable}{a table to read in with two columns of sexes and rows of age groups} \item{printTable}{whether the output table should be displayed on the console} \item{percent}{whether the lengths of the bars should be calculated from freqencies (default), percentages of each sex or total percentages} \item{col.gender}{vector reflecting colours of the two gender} \item{bar.label}{whether the bars would be labelled with the values} \item{decimal}{number of decimals displayed in the percent output table} \item{col}{colour(s) of the bars} \item{cex.bar.value}{character extension factor of the bar labels} \item{cex.axis}{character extension factor of the axis} \item{main}{main title} \item{cex.main}{character extension factor of main title} \item{...}{graph options for the bars, e.g. col} } \details{'pyramid' draws a horizontal bar graph of age by sex. The parameters of graph (par) options can be applied to 'font.lab' and those of the bars, e.g. 'col' but not of others. Other lower level graph commands should be only for adding a 'title'. 'bar.label' when set as "auto", will be TRUE when 'percent="each"' or 'percent="total"' } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'barplot', 'levels', 'table'} \value{When the variables age and sex are input arguments, the return object includes age group variable and the output table. The argument 'decimal' controls only decimals of the output displayed on the console but not the returned table.} \examples{ data(Oswego) use(Oswego) pyramid(age, sex) pyramid(age, sex, bar.label = TRUE) pyramid(age, sex, printTable=TRUE) pyramid(age, sex, percent = "each", printTable=TRUE) pyramid(age, sex, percent = "total", printTable=TRUE) pyramid(age, sex, percent = "total", bar.label = FALSE) pyramid(age, sex, percent = "total", cex.bar.value = .5) pyramid(age, sex, col="red") pyramid(age, sex, col=1:16) # Too colorful! pyramid(age, sex, col.gender = c("pink","lightblue")) output <- pyramid(age, sex, binwidth = 10, percent="each", decimal=2) output tabpct(output$ageGroup, chocolate) pyramid(inputTable=VADeaths[,1:2], font.lab=4) pyramid(inputTable=VADeaths[,1:2], font.lab=4, main=NULL) title("Death rates per 100 in rural Virginia in 1940") } \keyword{aplot}epicalc/man/print.tableStack.rd0000644000176000001440000000114112026244665016220 0ustar ripleyusers\name{print tableStack} \alias{print.tableStack} \title{Print tableStack object} \description{Print a tableStack object} \usage{ \method{print}{tableStack}(x, ...) } \arguments{ \item{x}{object of class 'tableStack' } \item{...}{further arguments passed to or used by methods.} } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'tableStack'} \examples{ data(Attitudes) tableStack(qa1:qa18, dataFrame=Attitudes) -> a print(a) data(Ectopic) tableStack(hia, gravi, by=outc, dataFrame=Ectopic) -> b print(b) } \keyword{database} epicalc/man/print.summ.rd0000644000176000001440000000075712026244665015140 0ustar ripleyusers\name{print summ} \alias{print.summ} \title{Print 'summ' results} \description{Print summary of data frame of a variable} \usage{ \method{print}{summ}(x, ...) } \arguments{ \item{x}{object of class 'summ'} \item{...}{further arguments passed to or used by methods.} } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'summ'} \keyword{database} epicalc/man/print.power.for.2p.rd0000644000176000001440000000123712026244665016412 0ustar ripleyusers\name{print power.for.2p} \alias{print.power.for.2p} \title{Print power.for.2p results} \description{Print results for power of hypothesis testing of 2 proportions} \usage{ \method{print}{power.for.2p}(x, ...) } \arguments{ \item{x}{object of class 'power.for.2p'} \item{...}{further arguments passed to or used by methods.} } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'n.for.2p'} \examples{ power.for.2p(p1=.1, p2=.2, n1=10, n2=15) power.for.2p(p1=seq(1,9,.5)/10, p2=.5, n1=100, n2=120) } \keyword{database} epicalc/man/print.n.for.survey.rd0000644000176000001440000000112612026244665016524 0ustar ripleyusers\name{print n.for.survey} \alias{print.n.for.survey} \title{Print n.for.survey results} \description{Print results for sample size of a continuous variable} \usage{ \method{print}{n.for.survey}(x, ...) } \arguments{ \item{x}{object of class 'n.for.survey'} \item{...}{further arguments passed to or used by methods.} } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'n.for.2p'} \examples{ n.for.survey(p=seq(5,95,5)/100) } \keyword{database} epicalc/man/print.n.for.noninferior.2p.rd0000644000176000001440000000126112026244665020037 0ustar ripleyusers\name{print n.for.noninferior.2p} \alias{print.n.for.noninferior.2p} \title{Print n.for.noninferior.2p results} \description{Print results for sample size for hypothesis testing of 2 proportions in non-inferior trial} \usage{ \method{print}{n.for.noninferior.2p}(x, ...) } \arguments{ \item{x}{object of class 'n.for.noninferior.2p'} \item{...}{further arguments passed to or used by methods.} } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'n.for.2p'} \examples{ n.for.noninferior.2p(p=.85, sig.inferior=.05) } \keyword{database} epicalc/man/print.n.for.lqas.rd0000644000176000001440000000116312026244665016130 0ustar ripleyusers\name{print n.for.lqas} \alias{print.n.for.lqas} \title{Print n.for.lqas results} \description{Print results for sample size for lot quality assurance sampling} \usage{ \method{print}{n.for.lqas}(x, ...) } \arguments{ \item{x}{object of class 'n.for.lqas'} \item{...}{further arguments passed to or used by methods.} } \author{Virasakdi Chongsuvivatwong \email{ } } \examples{ n.for.lqas(p0 = 0.05, q=0) n.for.lqas(p0 = (10:1)/100, q=0 ) -> a a } \keyword{database} epicalc/man/print.n.for.equi.2p.rd0000644000176000001440000000120112026244665016444 0ustar ripleyusers\name{print n.for.equi.2p} \alias{print.n.for.equi.2p} \title{Print n.for.equi.2p results} \description{Print results for sample size for hypothesis testing of 2 proportions in equivalent trial} \usage{ \method{print}{n.for.equi.2p}(x, ...) } \arguments{ \item{x}{object of class 'n.for.equi.2p'} \item{...}{further arguments passed to or used by methods.} } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'n.for.2p'} \examples{ n.for.equi.2p(p=.85, sig.diff=.05) } \keyword{database} epicalc/man/print.n.for.cluster.2p.rd0000644000176000001440000000114012026244665017164 0ustar ripleyusers\name{print n.for.cluster.2p} \alias{print.n.for.cluster.2p} \title{Print n.for.cluster.2p results} \description{Print results for sample size for hypothesis testing of 2 proportions in cluster RCT} \usage{ \method{print}{n.for.cluster.2p}(x, ...) } \arguments{ \item{x}{object of class 'n.for.cluster.2p'} \item{...}{further arguments passed to or used by methods.} } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'n.for.cluster.2p'} \keyword{database} epicalc/man/print.n.for.cluster.2means.rd0000644000176000001440000000116312026244665020035 0ustar ripleyusers\name{print n.for.cluster.2means} \alias{print.n.for.cluster.2means} \title{Print n.for.cluster.2means results} \description{Print results for sample size for hypothesis testing of 2 means in cluster RCT} \usage{ \method{print}{n.for.cluster.2means}(x, ...) } \arguments{ \item{x}{object of class 'n.for.cluster.2means'} \item{...}{further arguments passed to or used by methods.} } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'n.for.cluster.2means'} \keyword{database} epicalc/man/print.n.for.2p.rd0000644000176000001440000000115412026244665015511 0ustar ripleyusers\name{print n.for.2p} \alias{print.n.for.2p} \title{Print n.for.2p results} \description{Print results for sample size for hypothesis testing of 2 proportions} \usage{ \method{print}{n.for.2p}(x, ...) } \arguments{ \item{x}{object of class 'n.for.2p'} \item{...}{further arguments passed to or used by methods.} } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'n.for.2p'} \examples{ n.for.2p(p1=.1, p2=.2) n.for.2p(p1=seq(1,9,.5)/10, p2=.5) } \keyword{database} epicalc/man/print.n.for.2means.rd0000644000176000001440000000125412026244665016356 0ustar ripleyusers\name{print n.for.2means} \alias{print.n.for.2means} \title{Print n.for.2means results} \description{Print results for sample size for hypothesis testing of 2 means} \usage{ \method{print}{n.for.2means}(x, ...) } \arguments{ \item{x}{object of class 'n.for.2means'} \item{...}{further arguments passed to or used by methods.} } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'n.for.2p'} \examples{ n.for.2means(mu1 = 10, mu2 = 14, sd1=3, sd2=3.5) n.for.2means(mu1 = 10, mu2 = 7:14, sd1=3, sd2=3.5) -> a a } \keyword{database} epicalc/man/print.lrtest.rd0000644000176000001440000000132012026244665015457 0ustar ripleyusers\name{print lrtest} \alias{print.lrtest} \title{Print lrtest results} \description{Print results for likelihood ratio test} \usage{ \method{print}{lrtest}(x, ...) } \arguments{ \item{x}{object of class 'lrtest'} \item{...}{further arguments passed to or used by methods.} } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'logistic.display'} \examples{ model0 <- glm(case ~ induced + spontaneous, family=binomial, data=infert) model1 <- glm(case ~ induced, family=binomial, data=infert) lrtest (model0, model1) lrtest (model1, model0) -> a a} \keyword{database} epicalc/man/print.kap.table.rd0000644000176000001440000000067212026244665016014 0ustar ripleyusers\name{print kap.table} \alias{print.kap.table} \title{Print kap.table results} \description{Print results for kap.table commands} \usage{ \method{print}{kap.table}(x, ...) } \arguments{ \item{x}{object of class 'kap.table'} \item{...}{further arguments passed to or used by methods.} } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'kap.table'} \keyword{database} epicalc/man/print.kap.ByCategory.rd0000644000176000001440000000073512026244665016775 0ustar ripleyusers\name{print kap.ByCategory} \alias{print.kap.ByCategory} \title{Print kap.ByCategory results} \description{Print results for kap.Bycategory commands} \usage{ \method{print}{kap.ByCategory}(x, ...) } \arguments{ \item{x}{object of class 'kap.ByCategory'} \item{...}{further arguments passed to or used by methods.} } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'kap.ByCategory'} \keyword{database} epicalc/man/print.des.rd0000644000176000001440000000075512026244665014730 0ustar ripleyusers\name{print des} \alias{print.des} \title{Print 'des' results} \description{Print description of data frame of a variable} \usage{ \method{print}{des}(x, ...) } \arguments{ \item{x}{object of class 'des'} \item{...}{further arguments passed to or used by methods.} } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'des'} \keyword{database} epicalc/man/print.cci.rd0000644000176000001440000000106512026244665014706 0ustar ripleyusers\name{print cci} \alias{print.cci} \title{Print cci results} \description{Print results for cci and cc commands} \usage{ \method{print}{cci}(x, ...) } \arguments{ \item{x}{object of class 'cci'} \item{...}{further arguments passed to or used by methods.} } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'cci'} \examples{ cci(25, 22, 20, 7) data(Oswego) use(Oswego) cc(ill, chocolate) } \keyword{database} epicalc/man/print.alpha.rd0000644000176000001440000000100112026244665015223 0ustar ripleyusers\name{print alpha} \alias{print.alpha} \title{Print alpha object} \description{Print results related to Cronbach's alpha} \usage{ \method{print}{alpha}(x, ...) } \arguments{ \item{x}{object of class 'alpha'} \item{...}{further arguments passed to or used by methods.} } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'tableStack'} \examples{ data(Attitudes) alpha(qa1:qa18, dataFrame=Attitudes) -> a print(a) a} \keyword{database} epicalc/man/power.rd0000644000176000001440000000240612026244665014151 0ustar ripleyusers\name{Power} \alias{power.for.2means} \alias{power.for.2p} \title{Power calculation for two sample means and proportions} \description{Calculation of power given the results from a study} \usage{ power.for.2p(p1, p2, n1, n2, alpha = 0.05) power.for.2means(mu1, mu2, n1, n2, sd1, sd2, alpha = 0.05) } \arguments{ \item{p1, p2}{probabilities of the two samples} \item{n1, n2}{sample sizes of the two samples} \item{alpha}{significance level} \item{mu1, mu2}{means of the two samples} \item{sd1, sd2}{standard deviations of the two samples} } \details{These two functions compute the power of a study from the given arguments } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'n.for.2means', 'n.for.2p'} \examples{ # Suppose, in the example found in 'help(n.for.2p)', # given the two proportions are .8 and .6 and the sample size # for each group is 60. power.for.2p(p1=.8, p2=.6, n1=60, n2=60) # 59 percent # If the means of a continuous outcome variable in the same # two groups were 50 and 60 units and the standard deviations were 30 # and 35 units, then the power to detect a statistical significance # would be power.for.2means(mu1=50, mu2=60, sd1=30, sd2=35, n1=60, n2=60) # 39 percent. Note the graphic display } \keyword{math}epicalc/man/power.for.2means.rd0000644000176000001440000000134012026244665016116 0ustar ripleyusers\name{print power.for.2means} \alias{print.power.for.2means} \title{Print power.for.2means results} \description{Print results for power for hypothesis testing of 2 means} \usage{ \method{print}{power.for.2means}(x, ...) } \arguments{ \item{x}{object of class 'power.for.2means'} \item{...}{further arguments passed to or used by methods.} } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'n.for.2means'} \examples{ power.for.2means(mu1 = 10, mu2=14, n1=5, n2=7, sd1=3, sd2=3.5) power.for.2means(mu1 = 10, mu2=7:14, n1=20, n2=25, sd1=3, sd2=3.5) -> a a } \keyword{database} epicalc/man/poisgof.rd0000644000176000001440000000171712026244665014467 0ustar ripleyusers\name{poisgof} \alias{poisgof} \title{Goodness of fit test for modeling of count data} \description{Poisson and negative binomial regression are used for modeling count data. This command tests the deviance against the degrees of freedom in the model thus determining whether there is overdispersion.} \usage{ poisgof(model) } \arguments{ \item{model}{A Poisson or negative binomial model} } \details{ To test the significance of overdispersion of the errors of a Poisson or negative binomial model, the deviance is tested against degrees of freedom using chi-squared distribution. A low P value indicates significant overdispersion. } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{`glm'} \examples{ library(MASS) quine.pois <- glm(Days ~ Sex/(Age + Eth*Lrn), data = quine, family=poisson) poisgof(quine.pois) quine.nb1 <- glm.nb(Days ~ Sex/(Age + Eth*Lrn), data = quine) poisgof(quine.nb1) } \keyword{htest} epicalc/man/Planning.rd0000644000176000001440000000424212026244665014563 0ustar ripleyusers\name{Data for cleaning} \docType{data} \alias{Planning} \title{Dataset for practicing cleaning, labelling and recoding} \description{ The data come from clients of a family planning clinic. For all variables except id: 9, 99, 99.9, 888, 999 represent missing values } \format{ A data frame with 251 observations on the following 11 variables. \describe{ \item{\code{ID}}{a numeric vector: ID code} \item{\code{AGE}}{a numeric vector} \item{\code{RELIG}}{a numeric vector: Religion} \tabular{lll}{ \tab 1 \tab = Buddhist\cr \tab 2 \tab = Muslim\cr } \item{\code{PED}}{a numeric vector: Patient's education level} \tabular{lll}{ \tab 1 \tab = none\cr \tab 2 \tab = primary school\cr \tab 3 \tab = secondary school\cr \tab 4 \tab = high school\cr \tab 5 \tab = vocational school\cr \tab 6 \tab = university\cr \tab 7 \tab = other\cr } \item{\code{INCOME}}{a numeric vector: Monthly income in Thai Baht} \tabular{lll}{ \tab 1 \tab = nil\cr \tab 2 \tab = < 1,000\cr \tab 3 \tab = 1,000-4,999\cr \tab 4 \tab = 5,000-9,999\cr \tab 5 \tab = 10,000\cr } \item{\code{AM}}{a numeric vector: Age at marriage} \item{\code{REASON}}{a numeric vector: Reason for family planning} \tabular{lll}{ \tab 1 \tab = birth spacing\cr \tab 2 \tab = enough children\cr \tab 3 \tab = other\cr } \item{\code{BPS}}{a numeric vector: systolic blood pressure} \item{\code{BPD}}{a numeric vector: diastolic blood pressure} \item{\code{WT}}{a numeric vector: weight (Kg)} \item{\code{HT}}{a numeric vector: height (cm)} } } \usage{data(Planning)} \examples{ data(Planning) des(Planning) # Change var. name to lowercase names(Planning) <- tolower(names(Planning)) use(Planning) des() # Check for duplication of 'id' any(duplicated(id)) duplicated(id) id[duplicated(id)] #215 # Which one(s) are missing? setdiff(min(id):max(id), id) # 216 # Correct the wrong one id[duplicated(id)] <- 216 } \keyword{datasets} epicalc/man/Outbreak.rd0000644000176000001440000000432212026244665014570 0ustar ripleyusers\name{Outbreak investigation} \docType{data} \alias{Outbreak} \title{Dataset from an outbreak of food poisoning on a sportsday, Thailand 1990.} \description{ This dataset contains information from an outbreak investigation concerning food poisoning on a sportsday in Thailand 1990. Dichotomous variables for exposures and symptoms were coded as follow: \tabular{lll}{ \tab 0 \tab = no\cr \tab 1 \tab = yes\cr \tab 9 \tab = missing or unknown\cr } } \usage{data(Outbreak)} \format{ A data frame with 1094 observations on the following 13 variables. \describe{ \item{\code{id}}{a numeric vector} \item{\code{sex}}{a numeric vector} \tabular{lll}{ \tab 0 \tab = female\cr \tab 1 \tab = male\cr } \item{\code{age}}{a numeric vector: age in years} \tabular{lll}{ \tab 99 \tab = missing\cr } \item{\code{exptime}}{an AsIs or character vector of exposure times} \item{\code{beefcurry}}{a numeric vector: whether the subject had eaten beefcurry} \item{\code{saltegg}}{a numeric vector: whether the subject had eaten salted eggs} \item{\code{eclair}}{a numeric vector: pieces of eclair eaten} \tabular{lll}{ \tab 80 \tab = ate but could not remember how much\cr \tab 90 \tab = totally missing information\cr } \item{\code{water}}{a numeric vector: whether the subject had drunk water} \item{\code{onset}}{an AsIs or character vector of onset times} \item{\code{nausea}}{a numeric vector} \item{\code{vomiting}}{a numeric vector} \item{\code{abdpain}}{a numeric vector: abdominal pain} \item{\code{diarrhea}}{a numeric vector} } } \references{Thaikruea, L., Pataraarechachai, J., Savanpunyalert, P., Naluponjiragul, U. 1995 An unusual outbreak of food poisoning. \emph{Southeast Asian J Trop Med Public Health} \bold{26(1)}:78-85. } \examples{ data(Outbreak) use(Outbreak) # Distribution of reported pieces of eclair taken tab1(eclair) # Defining missing value recode(eclair, eclair>20, NA) pieces.of.eclair <- cut(eclair, c(0,1,2,20), include.lowest=TRUE, right=FALSE) tabpct(pieces.of.eclair, diarrhea) } \keyword{datasets} epicalc/man/Oswego.rd0000644000176000001440000000105512026244665014257 0ustar ripleyusers\name{Oswego} \docType{data} \alias{Oswego} \title{Dataset from an outbreak of food poisoning in US} \description{ This dataset contains information on the records of 75 persons under investigation for the cause of acute food poisoning after a dinner party. } \usage{data(Oswego)} \format{A data frame containing 75 observations and 20 variables.} \source{EpiInfo package} \references{ See: \url{http://www.cdc.gov/eis/casestudies/casestudyex.htm}. } \examples{ zap() data(Oswego) use(Oswego) pyramid(age, sex) } \keyword{datasets} epicalc/man/Montana.rd0000644000176000001440000000170212026244665014410 0ustar ripleyusers\name{Montana} \docType{data} \alias{Montana} \title{Dataset on arsenic exposure and respiratory deaths} \description{ Dataset from a cohort study of exposure to arsenic from industry and deaths from respiratory diseases. } \format{ A data frame with 114 observations on the following 6 variables. \describe{ \item{\code{respdeath}}{a numeric vector indicating number of deaths from respiratory diseases} \item{\code{personyrs}}{a numeric vector indicating person-years of exposure} \item{\code{agegr}}{a numeric vector: 1=40-49, 2=50-59, 3=60-69, 4=70-79)} \item{\code{period}}{a numeric vector: 1=1938-1949, 2=1950-1959, 3=1960-1969, 4=1970-1977} \item{\code{start}}{a numeric vector indicating starting period: 1=pre-1925, 2=1925 & after} \item{\code{arsenic}}{a numeric vector indicating years of exposure: 1=<1 year, 2=1-4 years, 3=5-14 years, 4=15+ years } } } \usage{data(Montana)} \keyword{datasets} epicalc/man/mhor.rd0000644000176000001440000000224712026244665013765 0ustar ripleyusers\name{mhor} \alias{mhor} \title{Mantel-Haenszel odds ratio} \description{Mantel-Haenszel odds ratio calculation and graphing from a stratified case-control study} \usage{ mhor(..., mhtable = NULL, decimal=2, graph = TRUE, design = "cohort") } \arguments{ \item{...}{Three variables viz. 'outcome', 'exposure' and 'stratification'.} \item{mhtable}{a 2-by-2-by-s table, where s (strata) is more than one} \item{decimal}{number of decimal places displayed} \item{graph}{If TRUE (default), produces an odds ratio plot} \item{design}{Specification for graph; can be "case control","case-control", "cohort" or "prospective"} } \details{ 'mhor' computes stratum-specific odds ratios and 95 percent confidence intervals and the Mantel-Haenszel odds ratio and chi-squared test is given as well as the homogeneity test. A stratified odds ratio graph is displayed. } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'fisher.test', 'chisq.test'} \examples{ data(Oswego) use(Oswego) cc(ill, chocolate) mhor(ill, chocolate, sex) mht1 <- table(ill, chocolate, sex) dim(mht1) mhor(mhtable=mht1) # same results } \keyword{array} epicalc/man/merge.lab.rd0000644000176000001440000000264012026244665014651 0ustar ripleyusers\name{merge with labels kept} \alias{merge.lab} \title{Merge two data frames with variable labels kept} \description{Create a new data frame from merging two with variable labels of the data frame kept} \usage{ \method{merge}{lab}(x, y, ...) } \arguments{ \item{x, y}{data frames to be merged to one} \item{...}{additional arguments passed on to 'merge'} } \details{This is the 'merge' method exclusively used for objects of class 'data.frame'. Epicalc can create and make use of variable labels extensively. Unfortunately, they are ignored by the function 'merge'. The current method, 'merge.lab', carries the variable labels from both data frames into the results. If the labels from these two data frames are conflicting, that in 'x' will be used. } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'label.var'} \examples{ data1 <- data.frame(id = c("A","B"), age = c(12,25)) label.var(id, "personal id", dataFrame=data1) label.var(age, "age in years", dataFrame=data1) des(data1) data2 <- data.frame(id= LETTERS, money = 1:26) label.var(id, "Identification code", dataFrame=data2) label.var(money, "money in dollar", dataFrame=data2) des(data2) merge(data1, data2) -> aa des(aa) # No variable description merge.lab(data1, data2) -> bb des(bb) merge.lab(data2, data1) -> cc des(cc) # Note the difference in description of 'id' between the three methods. } \keyword{database} epicalc/man/matchTab.rd0000644000176000001440000000236712026244665014546 0ustar ripleyusers\name{matchTab} \alias{matchTab} \title{Matched tabulation} \description{Tabulation of outcome vs exposure from a matched case control study} \usage{ matchTab (case, exposed, strata) } \arguments{ \item{case}{Outcome variables where 0 = control and 1 = case} \item{exposed}{Exposure variable where 0 = non-exposed and 1 = exposed} \item{strata}{Identification number for each matched set} } \details{Tabulation for an unmatched case control study is based on individual records classified by outcome and exposure variables. Matched tabulation is tallying based on each matched set. The simplest form is McNemar's table where only one case is matched with one control. 'matchTab' can handle 1:m matching where m can vary from 1 to m. A MLE method is then used to compute the conditional odds ratio. } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'table', 'cc' and 'clogit'} \examples{ use(infert) ## Not run: # matchTab(case, induced, stratum) # Tabulation successful but OR not computed # because 'induced' is not binary ## End(Not run) ia <- induced > 0 matchTab(case, ia, stratum) # See also library(survival) clogit(case ~ ia + strata(stratum), data=infert) } \keyword{array} epicalc/man/Marryage.Rd0000644000176000001440000000156612026244665014532 0ustar ripleyusers\name{Age at marriage} \alias{Marryage} \docType{data} \title{ Dataset on age at marriage} \description{ This dataset contains data on age at first marriage of attendants at a workshop in 1997. } \usage{data(Marryage)} \format{ A data frame with 27 observations on the following 7 variables. \describe{ \item{\code{id}}{a numeric vector} \item{\code{sex}}{a factor with levels \code{male} \code{female}} \item{\code{birthyr}}{a numeric vector indicating year of birth} \item{\code{educ}}{a factor with levels \code{bach-} \code{bachelor or higher}} \item{\code{marital}}{a factor with levels \code{Single} \code{Married}} \item{\code{maryr}}{a numeric vector indicating year of marriage} \item{\code{endyr}}{a numeric vector indicating year of analysis} } } \examples{ data(Marryage) use(Marryage) des() } \keyword{datasets} epicalc/man/markVisits.rd0000644000176000001440000000203012026244665015142 0ustar ripleyusers\name{markVisits} \alias{markVisits} \title{Mark visits of subjects in a long format} \description{Mark visits of subjects in a longitudinal data frame} \usage{markVisits(id, time) } \details{ Visit numbers are essential in longitudinal data analysis. This function make it easy for R user to do so. If visits marked by this function is going to be further used for calculation of lag difference, there must not be any missing visit in the data set. } \note{This was created from combination of the functions 'rle' and 'sapply'} \arguments{ \item{id}{subject identification field} \item{time}{time of visit} } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'rle', 'sapply'} \examples{ ## Data frame data(Sitka, package="MASS") use(Sitka) ## Classical R methods list1 <- rle(tree) list1 visit1 <- unlist(sapply(X=list1$lengths, FUN=function(x) 1:x, simplify=FALSE)) visit1 ## Do it again by Epicalc visit2 <- markVisits(id=tree, time=Time) visit2 } \keyword{database} epicalc/man/lsNoFunction.rd0000644000176000001440000000131112026244665015430 0ustar ripleyusers\name{List non-function objects} \alias{lsNoFunction} \title{List non-function objects} \description{List all objects visible in the global environment except user created functions.} \usage{ lsNoFunction() } \details{Compared to standard 'ls()', this function displays only the subset of 'ls()' which are not functions. The member of this list can be removed by 'zap()' but not the set of the functions created. } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'use', 'detach', 'ls', 'rm'} \examples{ object1 <- 1:5 object2 <- list(a=3, b=5) function1 <- function(x) {x^3 +1} ls() lsNoFunction() ## To show only functions as.character(lsf.str()[]) } \keyword{database}epicalc/man/lrtest.rd0000644000176000001440000000211712026244665014331 0ustar ripleyusers\name{lrtest} \alias{lrtest} \title{Likelihood ratio test} \description{Likelihood ratio test for objects of class 'glm'} \usage{ lrtest (model1, model2) } \details{Likelihood ratio test checks the difference between -2*logLikelihood of the two models against the change in degrees of freedom using a chi-squared test. It is best applied to a model from 'glm' to test the effect of a factor with more than two levels. The records used in the dataset for both models MUST be the same. The function can also be used with "clogit", which does not have real logLikelihood. } \arguments{ \item{model1, model2}{Two models of class "glm" having the same set of records and the same type ('family' and 'link')} } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'glm', 'logLik', 'deviance'} \examples{ model0 <- glm(case ~ induced + spontaneous, family=binomial, data=infert) model1 <- glm(case ~ induced, family=binomial, data=infert) lrtest (model0, model1) lrtest (model1, model0) # same result lrtest (model1, model0) -> a a } \keyword{htest} epicalc/man/lookup.rd0000644000176000001440000000267212026244665014333 0ustar ripleyusers\name{lookup} \alias{lookup} \title{Recode several values of a variable} \description{Systematic replacement of several values of a variable using an array} \usage{ lookup(x, lookup.array) } \arguments{ \item{x}{a variable} \item{lookup.array}{a n-by-2 array used for looking up the recoding scheme} } \details{This command is used for changing more than one value of a variable using a n-by-2 look-up array. The first column of the look-up array (index column) must be unique. If either the variable or the look-up table is character, the result vector will be character. For changing the levels of a factor variable, 'recode(vars, "old level", "new level")' or 'levels(var) <- ' instead. } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'replace', 'recode'} \examples{ a <- c( 1, 2, 2, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5, 5, NA) tx <- rbind(c(1,2),c(2,1),c(3,4),c(4,NA),c(NA,3)) # Swapping values of 1 and 2; rotating 3, 4 and NA new.a <- lookup(a, tx) data.frame(a, new.a) tableA <- table(a, new.a, exclude=NULL) # All non-diagonal cells which are non-zero are the recoded cells. print(tableA, zero=".") ## Character look-up table b <- c(rep(letters[1:4],2), ".", NA) tx1 <- cbind(c(letters[1:5], ".", NA), c("Disease A","Disease B","Disease C", "Disease D","Disease E", NA, "Unknown")) DiseaseName <- lookup(b, tx1) data.frame(b, DiseaseName) } \keyword{database}epicalc/man/lagVar.rd0000644000176000001440000000262712026244665014236 0ustar ripleyusers\name{lagVar} \alias{lagVar} \title{Create a vector of lagged or subsequent value} \description{Create a vector of lagged or subsequent value in a long form longitudinal data} \usage{lagVar(var, id, visit, lag.unit=1) } \details{Data must be in long format having variable to create the lag, id and visit. The variable 'visit' must be the number of visit, with step = 1. The default value of lag.unit is 1. When the number is negative, the next measured is created instead. } \arguments{ \item{var}{variable to create the lag} \item{id}{subject identification field} \item{visit}{visit of measurement} \item{lag.unit}{lag number of visits} } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'lag'} \examples{ ## Identification of the tree that became smaller during followup data(Sitka, package="MASS") use(Sitka) table(Time) visit <- Time pack() recode(visit, as.numeric(names(table(Time))), 1:5) lag1.size <- lagVar(var=size, id=tree, visit=visit, lag=1) data.frame(tree=tree, time=Time, visit=visit, size=size, lag1.size=lag1.size) [1:20,] # Answer data.frame(Time, tree, size, lag1.size) [which(lag1.size > size),] # Alternatively next.size <- lagVar(size, tree, visit, lag=-1) data.frame(tree=tree, time=Time, size=size, next.size=next.size) [1:20,] data.frame(Time, tree, size, next.size) [which(size > next.size),] } \keyword{database} epicalc/man/label.var.rd0000644000176000001440000000362312026244665014665 0ustar ripleyusers\name{Variable manipulation} \alias{label.var} \alias{pack} \title{Variable manipulation} \description{Label a variable; integrate outside variable(s) into .data.} \usage{ label.var(var, label, pack = TRUE, dataFrame = .data) pack(dataFrame = .data) } \arguments{ \item{var}{A variable inside .data or a free vector.} \item{label}{A short description of the variable} \item{pack}{Remove the original free variable?} \item{dataFrame}{Destination data frame where all variables of the same length are labeled or packed into} } \details{A data frame imported from Stata or SPSS can have 'variable labels', which is adopted as an attribute (but not used) by R. Epicalc exploits this attribute by displaying the labels in the output from 'des()' and graphs following 'summ(var)', tab1(var)', 'tabpct(var1, var2)'. For free vector(s) (variables outside the data frame), 'label.var' appends vector(s) to the data frame specified with the descriptive label attached. For variables already in the data frame, the command simply attaches the label to the variable. The 'var.labels' attribute is updated in the data frame. The argument 'pack', if TRUE, removes the original vector. This is useful to avoid redundancy and confusion. More than one free vector of the same length can be integrated into the data frame (.data) without labelling, using 'pack()'. } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'use','des'} \examples{ sbp <- c(120, 100, 110, 120, 140, 120, NA, NA) dbp <- c( 80, 80, 70, 80, 70, NA, 70, 60) .data <- data.frame(sbp, dbp) use(.data) pack() des() label.var(sbp, "systolic BP") label.var(dbp, "diastolic BP") des() pp <- sbp - dbp # This is a new free vector in the global environment. summ(pp) # unlabelled label.var(pp, "pulse pressure") des() summ(pp) ## Silly things to do. Just for demonstration. pp2 <- pp^2 pp3 <- pp^3 pack() .data } \keyword{database}epicalc/man/keepData.rd0000644000176000001440000001003412026244665014527 0ustar ripleyusers\name{Keep data} \alias{keepData} \title{Keep a subset of variables or records} \description{Keep only subset of variables or records in the default data frame '.data'} \usage{ keepData (dataFrame = .data, sample=NULL, exclude=NULL, subset, select, drop = FALSE, refactor = c("subset.vars", "all", "none"), ...) } \arguments{ \item{dataFrame}{a data frame} \item{sample}{an integer indicating the size of random sample or a value < 1 indicating fraction of records to be extracted} \item{exclude}{an expression, indicating columns to remove from '.data'.} \item{subset}{a logical expression indicating elements or rows to keep: missing values are taken as false.} \item{select}{an expression indicating columns to select from a data frame.} \item{drop}{passed on to [ indexing operator.} \item{refactor}{after subsetting, whether the levels of variable(s) with zero count should be removed} \item{...}{further arguments to be passed to or from other methods.} } \details{'keepData' is the Epicalc version of 'subset.data.frame' which is a standard R function. It reduces the data frame to the specified subset and updates the search path accordingly. Using 'keepData' will retain descriptions of the data, and the remaining variables, ready to be used by other Epicalc functions that can exploit them such as 'des', 'codebook', 'summ', 'tab1' etc ... Since this command only affects the specified data frame (usually '.data'), any new variables created as free vectors will not be changed. The difference in length of variables may occur from the 'subset' argument. To avoid this, 'pack' or 'label.var' should be used to incoporate any relevant free vectors into the default data frame, '.data' so that all variables can be subsetted simultaneously, thus reducing the complications of the difference in variable lengths. The argument 'refactor' is effective only when the argument 'subset' is specified. By default, 'refactor' is set to "subset.vars" indicating that the levels of the variables used in subset criteria will be revised to eliminate levels with zero count. If refactor="all", all factor variables in the dataFrame will be affected. } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'des', 'subset', 'sample'} \examples{ ## Record sampling data(ANCdata) use(ANCdata) des() keepData(sample=500) des() # Note reduction of sample size to 500 use(ANCdata) keepData(sample=.1) # Select 10% or 75 records des() ## Selecting specific record numbers data(Compaq) use(Compaq) keepData(subset = 1:nrow(.data) <= 50) #First 50 records summ() use(Compaq) every.seventh <- is.element(1:nrow(.data), seq(1, nrow(.data), 7)) keepData(subset = every.seventh) head(.data) ## Selecting records under certain conditions data(Familydata) use(Familydata) des() .data bmi <- wt/(ht/100)^2 label.var(bmi, "Body mass index (kg/m2)") keepData(subset = ht > 120) .data # Which record is missing? use(Compaq) des() tab1(ses) ses1 <- ses pack() keepData(subset=ses=="Rich") tab1(ses) tab1(ses1) # 'refactor' set to 'subset.vars' thus levels of ses1 not affected ## Reduction of variables ## Removal of consecutive variables use(Familydata) keepData(select = -(age:ht)) # Variables from 'age' to 'ht' removed des() ## A better alternative would be: use(Familydata) keepData(exclude = age:ht) des() keepData(select = -c(1,3)) # Further removal of the first and # the third variables des() codebook() ## Targeting only a certain variables data(Oswego) use(Oswego) des() keepData(select = c(age, sex, ill, cakes:fruitsalad)) des() keepData(select = c(1,2,5:7)) # Retain all variables except the third #the the fourth des() # Note the repetition of '(subset)' ## Wildcard use(Oswego) des() keepData(select = "c*") # The wildcard must be enclosed in quotes des() use(Oswego) des() keepData(exclude = "on*") # Variables having names starting with "on" removed keepData(exclude = "???") # Variables having names with 3 characters removed des() # Which are missing? } \keyword{database}epicalc/man/kap.rd0000644000176000001440000001254212026244665013572 0ustar ripleyusers\name{kap} \alias{kap} \alias{kap.default} \alias{kap.table} \alias{kap.2.raters} \alias{kap.m.raters} \alias{kap.ByCategory} \title{Kappa statistic} \description{Measurement of agreement in categorization by 2 or more raters} \usage{ kap(x, ...) \method{kap}{default}(x, ...) \method{kap}{table}(x, decimal =3, wttable = c(NULL, "w", "w2"), print.wttable = FALSE, ...) \method{kap}{2.raters}(x, rater2, decimal =3, ...) \method{kap}{m.raters}(x, decimal =3, ...) \method{kap}{ByCategory}(x, decimal =3, ...) } \arguments{ \item{x}{an object serving the first argument for different methods \tabular{lll}{ \tab FUNCTION \tab 'x'\cr \tab 'kap.table' \tab table\cr \tab 'kap.2.raters' \tab rater1\cr \tab 'kap.m.raters' \tab data frame with raters in column\cr \tab 'kap.ByCategory' \tab data frame with categories in column\cr }} \item{decimal}{number of decimal in the print} \item{wttable}{cross tabulation of weights of agreement among categories. Applicable only for 'kap.table' and 'kap.2.raters'} \item{print.wttable}{whether the weights table will be printed out} \item{rater2}{a vector or factor containing opinions of the second rater among two raters.} \item{...}{further arguments passed to or used by other methods.} } \details{ There are two different principles for the calculation of the kappa statistic. 'kap.table' and 'kap.2.raters' use two fixed raters whereas 'kap.m.raters' and 'kap.ByCategory' are based on frequency of category of rating an individual received without a requirement that the raters must be fixed. 'kap.table' analyses kappa statistics from a predefined table of agreement of two raters. 'wttable' is important only if the rating can be more than 2 levels. If this argument is left as default or 'NULL', full agreement will be weighted as 1. Partial agreement is considered as non-agreement and weighted as 0. When 'wttable = "w"' the weights are given by \deqn{1 - abs(i - j)/(1 - k)} where i and j index the rows and columns of the ratings and k is the maximum number of possible ratings. A weight of 1 indicates an observation of perfect agreement. When 'wttable = "w2", the weights are given by \deqn{1 - (abs(i - j)/(1 - k))^2.} In this case, weights of partial agreements will further increase. 'wttable' can otherwise be defined by the user. 'kap.2.raters' takes two vectors or factors, one for each of the two raters. Cross-tabulation of the two raters is displayed and automatically forwarded for computation of kappa statistic by 'kap.table'. 'kap.m.raters' is used for more than 2 raters. Although the variables are arranged based on columns of individual raters, only the frequency in each category rating is used. This function calculates the frequencies without any display and automatically forwards the results for computation by 'kap.ByCategory'. 'kap.ByCategory' is for the grouped data format, where each category (column) contains the counts for each individual subject being rated. As mentioned above, the frequencies can come from different sets of raters. } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'table'} \examples{ ## Computation of kappa from a table class <- c("Normal","Benign","Suspect","Cancer") raterA <- gl(4,4, label=class) raterB <- gl(4,1,16, label=class) freq <- c(50,2,0,1,2,30,4,3,0,0,20,1,1,3,4,25) table1 <- xtabs(freq ~ raterA + raterB) table1 kap(table1) wt <-c(1,.5,0,0,.5,1,0,0,0,0,1,.8,0,0,.8,1) wttable <- xtabs(wt ~ raterA + raterB) wttable # Agreement between benign vs normal is .5, suspect vs cancer is .8 kap(table1, wttable=wttable, print.wttable=TRUE) # The following two lines are computational possible but inappropriate kap(table1, wttable = "w", print.wttable=TRUE) kap(table1, wttable = "w2", print.wttable=TRUE) ## A data set from 5 raters with 3 possible categories. category.lab <- c("yes","no","Don't know") rater1 <- factor(c(1,1,3,1,1,1,1,2,1,1), labels=category.lab) rater2 <- factor(c(2,1,3,1,1,2,1,2,3,1), labels=category.lab) rater3 <- factor(c(2,3,3,1,1,2,1,2,3,1), labels=category.lab) rater4 <- factor(c(2,3,3,1,3,2,1,2,3,3), labels=category.lab) rater5 <- factor(c(2,3,3,3,3,2,1,3,3,3), labels=category.lab) kap.m.raters(data.frame(rater1,rater2,rater3,rater4,rater5)) # The above is the same as YES <- c(1,2,0,4,3,1,5,0,1,3) NO <- c(4,0,0,0,0,4,0,4,0,0) DONTKNOW <- c(0,3,5,1,2,0,0,1,4,2) kap.ByCategory(data.frame(YES,NO,DONTKNOW)) # Using 'kap.m.raters' for 2 raters is inappropriate. Kappa obtained # from this method assumes that the agreement can come from any two raters, # which is usually not the case. kap.m.raters(data.frame(rater1, rater2)) # 'kap.2.raters' gives correct results kap.2.raters(rater1, rater2) # When there are missing values, rater3[9] <- NA; rater4[c(1,9)] <- NA kap.m.raters(data.frame(rater1,rater2,rater3,rater4,rater5)) # standard errors and other related statistics are not available. # Two exclusive rating categories give only one common set of results. # The standard error is obtainable even if the numbers of raters vary # among individual subjects being rated. totalRaters <- c(2,2,3,4,3,4,3,5,2,4,5,3,4,4,2,2,3,2,4,5,3,4,3,3,2) pos <- c(2,0,2,3,3,1,0,0,0,4,5,3,4,3,0,2,1,1,1,4,2,0,0,3,2) neg <- totalRaters - pos kap.ByCategory(data.frame(neg, pos)) } \keyword{array} epicalc/man/IudFollowup.rd0000644000176000001440000000131612026244665015265 0ustar ripleyusers\name{IUD trial follow-up data} \alias{IudFollowup} \docType{data} \title{Dataset followup cases of IUD trials} \description{ This dataset is a subset of WHO IUD trial. It should be merged with IudAdmit and IudDiscontinue } \usage{data(IudFollowup)} \format{A data frame containing 4235 observations and 6 variables. \describe{ \item{\code{id}}{a numeric vector for personal identification number} \item{\code{vlmpdate}}{date of last mentrual period before this visit} \item{\code{vdate}}{date of visit} \item{\code{f22}}{lactating} \item{\code{f51}}{IUD threads visible} \item{\code{f61}}{subject continuing} } } \examples{ data(IudFollowup) } \keyword{datasets} epicalc/man/IudDiscontinue.rd0000644000176000001440000000115112026244665015737 0ustar ripleyusers\name{IUD trial discontinuation data} \alias{IudDiscontinue} \docType{data} \title{Dataset on discontinuation of the IUD trial cases} \description{ This dataset is a subset of WHO IUD trial. It should be merged with IudAdmit and IudFollowup } \usage{data(IudDiscontinue)} \format{A data frame containing 398 observations and 3 variables. \describe{ \item{\code{id}}{a numeric vector for personal identification number} \item{\code{discdate}}{date of discontinuation} \item{\code{d23}}{primary reason for discontinuation} } } \examples{ data(IudDiscontinue) } \keyword{datasets} epicalc/man/IudAdmit.rd0000644000176000001440000000116112026244665014512 0ustar ripleyusers\name{IUD trial admission data} \alias{IudAdmit} \docType{data} \title{Dataset admission of cases for IUD trials} \description{ This dataset is a subset of WHO IUD trial. It should be merged with IudFollowup and IudDiscontinue } \usage{data(IudAdmit)} \format{A data frame containing 918 observations and 4 variables. \describe{ \item{\code{id}}{a numeric vector for personal identification number} \item{\code{idate}}{date of IUD insertion} \item{\code{lmptime}}{time since last menstrual period} \item{\code{a122}}{type of IUD} } } \examples{ data(IudAdmit) } \keyword{datasets} epicalc/man/HW93.Rd0000644000176000001440000000200312026244665013440 0ustar ripleyusers\name{Hookworm 1993} \alias{HW93} \docType{data} \title{Dataset from a study on hookworm prevalence and intensity in 1993} \description{ A dataset from a cross-sectional survey in 1993 examining hookworm infection} \usage{data(HW93)} \format{ A data frame with 637 observations on the following 6 variables. \describe{ \item{\code{id}}{a numeric vector for personal identification number} \item{\code{epg}}{a numeric vector for eggs per gram of faeces} \item{\code{age}}{a numeric vector for age in years} \item{\code{shoes}}{a factor for shoe wearing with levels \code{no} \code{yes}} \item{\code{intense}}{a factor for intensity of infection in epg. with levels \code{0} \code{1-1,999} \code{2,000+}} \item{\code{agegr}}{a factor for age group with levels \code{<15 yrs} \code{15-59 yrs} \code{60+ yrs}} } } \examples{ library(MASS) data(HW93) use(HW93) intense.ord <- ordered(intense) ord.hw <- polr(intense.ord ~ agegr + shoes) summary(ord.hw) } \keyword{datasets} epicalc/man/Hakimi.rd0000644000176000001440000000153712026244665014223 0ustar ripleyusers\name{Hakimi's data} \docType{data} \alias{Hakimi} \title{Dataset on effect of training personnel on neonatal mortality} \description{ Subset of a dataset from an intervention trial of education on personnel and the effect on neonatal mortality. Non-fatal records were randomly selected from the original dataset, just for practice and interpretation of interaction term. } \usage{data(Hakimi)} \format{A data frame containing 456 observations and 4 variables. \describe{ \item{\code{dead}}{neonatal death: 1=yes, 0=no} \item{\code{treatment}}{intervention programme: 1=yes, 2=no} \item{\code{malpres}}{malpresentation of fetus: 1=yes, 0=no} \item{\code{birthwt}}{birth weight for foetus in gram} } } \examples{ data(Hakimi) use(Hakimi) des() cc(dead, treatment) mhor(dead, treatment, malpres) } \keyword{datasets} epicalc/man/followup.plot.rd0000644000176000001440000000657512026244665015654 0ustar ripleyusers\name{Follow-up Plot} \alias{followup.plot} \title{Longitudinal followup plot} \description{Plot longitudinal values of individuals with or without stratification} \usage{ followup.plot(id, time, outcome, by = NULL, n.of.lines = NULL, legend = TRUE, legend.site = "topright", lty = "auto", line.col = "auto", stress = NULL, stress.labels = FALSE, label.col = 1, stress.col = NULL, stress.width = NULL, stress.type = NULL, lwd = 1, xlab, ylab, ...) } \arguments{ \item{id}{idenfication variable of the same subject being followed up} \item{time}{time at each measurement} \item{outcome}{continuous outcome variable} \item{by}{stratification factor (if any)} \item{n.of.lines}{number of lines (or number of subjects in the data frame) randomly chosen for drawing} \item{legend}{whether a legend will be automatically included in the graph} \item{legend.site}{a single character string indicating location of the legend. See details of ?legend} \item{lty}{type of the "time" lines. See 'lty' in ?par} \item{line.col}{line colour(s) for non-stratified plot} \item{stress}{subset of ids to draw stressed lines} \item{stress.labels}{whether the stressed lines should be labelled} \item{label.col}{single integer indicating colour of the stressed line labels} \item{stress.col}{colour values used for the stressed line. Default value is '1' or black} \item{stress.width}{relative width of the stressed line} \item{stress.type}{line type code for the stressed line} \item{lwd}{line width} \item{xlab}{label for X axis} \item{ylab}{label for Y axis} \item{...}{other graphic parameters} } \details{'followup.plot' plots outcome over time of the individual subjects. If a stratification variable 'by' is specified, the levels of this variable will be used to color the lines. 'n.of.lines' is used to reduce the number of lines to allow the pattern to be seen more clearly. 'legend' is omitted if 'n.of.lines' is not NULL or the number of subjects exceeds 7 without stratification. 'line.col' works only for a non-stratified plot. It can be a single standard colour or "multicolor". Values for 'stress.col', 'stress.width' and 'stress.type', if not NULL, should follow those for 'col', 'lwd' and 'lty', respectively } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'plot','lines'} \examples{ use(Indometh) followup.plot(Subject, time, conc) followup.plot(Subject, time, conc, lty=1:6, line.col=rep("black",6)) library(MASS) use(Sitka) followup.plot(tree, Time, size) followup.plot(tree, Time, size, line.col = "brown") followup.plot(tree, Time, size, line.col = "multicolor") followup.plot(tree, Time, size, n.of.lines=20, line.col = "multicolor") # Breakdown of color by treatment group followup.plot(tree, Time, size, by=treat) # The number of lines reduced to 40 followup.plot(tree, Time, size, by=treat, n.of.lines=40) # Stress some lines length(table(tree)) # 79 trees followed up # Identifying trees that sometimes became smaller sortBy(tree, Time) next.tree <- c(tree[-1], NA) next.size <- c(size[-1], NA) next.size[tree != next.tree] <- NA pack() smaller.trees <- tree[next.size < size] followup.plot (tree, Time, size, line.col=5, stress=smaller.trees, stress.col=2, stress.width=2, stress.type=2) followup.plot (tree, Time, size, line.col=5, stress=smaller.trees, stress.col=2, stress.width=2, stress.type=2, stress.labels=TRUE) } \keyword{aplot}epicalc/man/fillin.rd0000644000176000001440000000214412026244665014271 0ustar ripleyusers\name{fillin} \alias{fillin} \title{fillin - Rectangularize a dataframe} \description{ fillin adds observations with missing data so that all combinations of the specified variables exist, thus making a complete rectangularization. } \usage{ fillin(dataFrame=.data, select, fill=NA) } \arguments{ \item{dataFrame}{a data frame.} \item{select}{a vector of at least 2 variables from the data frame. If missing all variables in the data frame will be used.} \item{fill}{the value used to fill in all other variables from the data frame. Defaults to NA.} } \author{Edward McNeil \email{ } } \seealso{table} \examples{ data <- data.frame(sex=c("female","male","male"), race=c("black","black","white"), x1=c(.5,.4,.1), x2=c(32,40,53)) data fillin(data, select=c(sex,race)) data.new <- fillin(data, select=c(sex,race), fill=0) data.new data <- data.frame(x = gl(3,3), y = rep(gl(3,1),3), z = gl(2,6,length=9), n = rpois(9,10) ) data fillin(data, c(x,y)) fillin(data, c(x,z)) fillin(data, c(x,y,z), fill=0) } \keyword{database} epicalc/man/Familydata.Rd0000644000176000001440000000164412026244665015033 0ustar ripleyusers\name{Familydata} \alias{Familydata} \docType{data} \title{ Dataset of a hypothetical family} \description{ Anthropometric and financial data of a hypothetical family} \usage{data(Familydata)} \format{ A data frame with 11 observations on the following 6 variables. \describe{ \item{\code{code}}{a character vector} \item{\code{age}}{a numeric vector} \item{\code{ht}}{a numeric vector} \item{\code{wt}}{a numeric vector} \item{\code{money}}{a numeric vector} \item{\code{sex}}{a factor with levels \code{F} \code{M}} } } \examples{ data(Familydata) use(Familydata) des() summ() age2 <- age^2 plot(age, money, log="y") dots.of.age <- seq(0,80,0.01) new.data.frame <- data.frame(age=dots.of.age, age2=dots.of.age^2) lm1 <- lm(log(money) ~ age + age2) dots.of.money <- predict.lm(lm1, new.data.frame) lines(dots.of.age, exp(dots.of.money), col="blue") } \keyword{datasets} epicalc/man/expand.rd0000644000176000001440000000303512026244665014273 0ustar ripleyusers\name{expand} \alias{expand} \title{Expand an aggregated data frame} \description{Expand an 'aggregate'd data frame into a case-by-case format based on the values specified in a column} \usage{expand(aggregate.data, index.var = "Freq", retain.freq = FALSE) } \details{An aggregated data frame has one variable (colunm) indicating the number or frequency of replication of subjects having the same values of other variables as the index record. 'expand' replicates the row using the value in 'index.var' as the number of replications. 'retain.freq' indicates whether the 'index.var', which is the frequency, should be retained. } \note{The aggregated data frame is not changed. Remember to assign the result.} \arguments{ \item{aggregate.data}{an aggregate data frame having a variable indicating the replication of subjects having that combination of characteristics, which are indicated by other variables} \item{index.var}{name of a variable indicating frequency of replication} \item{retain.freq}{whether the index variable or frequency variable should be retained in the returned data frame} } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'table', 'xtabs', 'aggregate'} \examples{ ## Expanding an aggregated data frame data(ANCtable) des(ANCtable) a <- expand(ANCtable) des(a) ## Aggregating a case-by-case data frame data(ANCdata) use(ANCdata) des() id <- 1:nrow(ANCdata) aggregate.numeric(id, by=list(Death=death, Anc=anc, Clinic=clinic), FUN="count") } \keyword{database} epicalc/man/Ectopic.Rd0000644000176000001440000000240612026244665014343 0ustar ripleyusers\name{Ectopic pregnancy} \alias{Ectopic} \docType{data} \title{ Dataset of a case-control study looking at history of abortion as a risk factor for ectopic pregnancy} \description{ This case-control study has one case series and two control groups.\cr The subjects were recruited based on three types of pregnancy outcome } \usage{data(Ectopic)} \format{ A data frame with 723 observations on the following 4 variables. \describe{ \item{\code{id}}{a numeric vector} \item{\code{outc}}{a factor with levels \code{EP} \code{IA} \code{Deli}} \tabular{lll}{ \tab EP \tab = ectopic pregnancy\cr \tab IA \tab = women coming for induced abortion\cr \tab Deli \tab = women admitted for full-term delivery\cr } \item{\code{hia}}{a factor with levels \code{never IA} \code{ever IA}} \item{\code{gravi}}{a factor with levels \code{1-2} \code{3-4} \code{>4}} } } \examples{data(Ectopic) library(nnet) use(Ectopic) multi1 <- multinom(outc ~ hia + gravi, data=.data) summary(multi1) mlogit.display(multi1) # Changing referent group of outcome outcIA <- relevel(outc, ref="IA") pack() multi2 <- multinom(outcIA ~ hia + gravi, data=.data) summary(multi2) mlogit.display(multi2) } \keyword{datasets} epicalc/man/dotplot.rd0000644000176000001440000001251512026244665014504 0ustar ripleyusers\name{dotplot} \alias{dotplot} \title{Dot plot} \description{Plot of frequency in dots} \usage{ dotplot (x, bin = "auto", by = NULL, xmin = NULL, xmax = NULL, time.format = NULL, time.step = NULL, pch = 18, dot.col = "auto", main = "auto", ylab = "auto", cex.X.axis = 1, cex.Y.axis = 1, ...) } \arguments{ \item{x}{a numeric vector. Allowed types also include "Date" and "POSIXct"} \item{bin}{number of bins for the range of 'x'} \item{by}{stratification variable} \item{xmin}{lower bound of x in the graph} \item{xmax}{upper bound of x in the graph} \item{time.format}{format for time or date at the tick marks} \item{time.step}{a character string indicating increment of the sequence of tick marks} \item{pch}{either an integer specifying a symbol or a single character to be used as the default in plotting points} \item{dot.col}{a character or a numeric vector indicating the colour of each category of 'by'} \item{main}{main title} \item{ylab}{Y axis title} \item{cex.X.axis}{character extension scale of X axis} \item{cex.Y.axis}{character extension scale of Y axis} \item{...}{graphical parameters for the dots when there is no stratification} } \details{'dotplot' in Epicalc is similar to a histogram. Each dot represents one record. Attributes of the dots can be further specified in '...' when there is no strafication. Otherwise, the dots are plotted as a diamond shape and the colours are automatically chosen based on the current palette and the number of strata. When 'bin="auto"' (by default), and the class of the vector is 'integer', 'bin' will be automatically set to max(x)-min(x)+1. This strategy is also applied to all other time and date variables. Users can try other values if the defaults are not to their liking. See the example of 'timeExposed' below. The argument 'xmin' and 'xmax' indicate the range of x to be displayed on the graph. These two arguments are independent from the value of 'bin', which controls only the number of columns for the original data range. Dotplot usually starts the first tick mark on the X-axis at 'xmin' (or min(x) if the 'xmin' is not specified). The argument 'time.step' is typically a character string, containing one of 'sec', 'min', 'hour', 'day', 'DSTday', 'week', 'month' or 'year'. This can optionally be preceded by an integer and a space, or followed by "s", such as "2 weeks". Setting proper 'xmin', 'xmax' and 'time.step' can improve the location of tick marks on the X-axis. The 'time.format' argument can then be given to further improve the graph. See the last two examples for a better understanding.} \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'summ', 'hist', 'seq.Date' and 'seq.POSIXt'} \examples{ a <- rep(1:2, 250) b <- rnorm(500,mean=a) dotplot(b) dotplot(b, pch=1) dotplot(b, by=a) dotplot(b, by=a, pch=1) # You may try other values of 'pch' # For the commands below, # if dates in X axis are not readable, # try omitting '#' from the next line # Sys.setlocale("LC_ALL", "C") # The number of dots in each column is the frequency # of 'x' for the exact value on the X axis. zap() data(Outbreak) use(Outbreak) class(age) # numeric dotplot(age) # 40 columns age.as.integer <- as.integer(age) dotplot(age.as.integer) # 'bin' is the number of columns in the data range. # Specifying 'min' and 'max' only expands or truncates # the range of the X axis and has no effect on the distribution # of the dots inside the data range. dotplot(age.as.integer, xmin=0, xmax=150) # Just for demonstration. dotplot(age.as.integer, xmin=0, xmax=70) # the "99"s are now out of the plot. dotplot(age.as.integer, xmin=0, xmax=70, by=sex) # Controlling colours of the dots dotplot(age.as.integer, xmin=0, xmax=70, dot.col="chocolate") sex1 <- factor(sex); levels(sex1) <- list("M"=1,"F"=0) dotplot(age.as.integer, xmin=0, xmax=70, by=sex1, dot.col=c(2,5)) dotplot(age.as.integer, xmin=0, xmax=70, by=sex1, dot.col=c("brown","blue"), main="Age by sex", cex.X.axis=1.3, cex.Y.axis=1.5, cex.main=1.5) # Dotplot of a time variable timeExposed <- ISOdatetime(year=1990, month=8, day=25, hour=substr(exptime,9,10), min=substr(exptime,11,12),sec=0) range(timeExposed, na.rm=TRUE) max(timeExposed, na.rm=TRUE)-min(timeExposed, na.rm=TRUE) # The unit of difference between the two time points is "hour" # Therefore, bin="auto" will produce a dotplot by hour dotplot(timeExposed) # In fact, there are details in 'min' min <- substr(exptime, 11, 12) tab1(min, graph=FALSE) # To create a half-hourly dotplot # 11:00 to 21:10 requires 21 columns for half-hour intervals. dotplot(timeExposed, bin=21) # For a dotplot of every 15-minutes 41 columns is required dotplot(timeExposed, bin=41) # To display exposure half-hourly in the past 24 hours dotplot(timeExposed, bin=21, xmin=ISOdatetime(1990,8,25,0,0,0), xmax=ISOdatetime(1990,8,26,0,0,0), time.step="2 hours", time.format="\%H:\%M") ## Wide range of a variable with 'Date' class data(BP) use(BP); des() dotplot(birthdate) range(birthdate) # "1930-11-14" and "1975-12-08" # There are too many days between these two points of time. # Users may want to reduce the number of bins, say, to 40 dotplot(birthdate, bin=40) # Setting 'xmin', 'xmax', 'time.step and 'time.format' # to mark nicer date ticks. dotplot(birthdate, bin=40, xmin=as.Date("1930-01-01"), xmax=as.Date("1976-01-01"), time.step="5 years", time.format="\%Y") } \keyword{aplot}epicalc/man/DHF99.Rd0000644000176000001440000000203312026244665013534 0ustar ripleyusers\name{DHF99} \alias{DHF99} \docType{data} \title{Dataset for exercise on predictors for mosquito larva infestation} \description{ Dataset from a community survey on water containers infested by mosquito larvae. } \usage{data(DHF99)} \format{ A data frame with 300 observations on the following 5 variables. \describe{ \item{\code{houseid}}{a numeric vector} \item{\code{village}}{a numeric vector indicating village ID} \item{\code{education}}{a factor with levels \code{Primary} \code{Secondary} \code{High school} \code{Bachelor} \code{Other}} \item{\code{containers}}{a numeric vector indicating number of containers infested} \item{\code{viltype}}{a factor with levels \code{rural} \code{urban} \code{slum}} } } \references{ Thammapalo, S., Chongsuwiwatwong, V., Geater, A., Lim, A., Choomalee, K. 2005. Socio-demographic and environmental factors associated with Aedes breeding places in Phuket, Thailand. \emph{Southeast Asian J Trop Med Pub Hlth} \bold{36(2)}: 426-33.} \keyword{datasets} epicalc/man/detachAlllData.rd0000644000176000001440000000217212026244665015644 0ustar ripleyusers\name{Detach all data frames} \alias{detachAllData} \title{Detach all data frames} \description{Detach all data frames} \usage{ detachAllData() } \details{The R command 'attach()' copies the data frame in the argument into a data frame in the search path (usually the second position) consequently making all the variables in the data frame easy to refer to. However, changing any element of the index data frame has no effect on the one in the search path unless the changed data frame is attached to the search path again. Having too many data frames in the search path subsequently causes confusion, not to mention an increase in memory usage. It is a good practice to detach the index data frame first before manipulating it and then attaching to it again. 'detachAllData()' is a self explanatory command which solves the over-attaching problem. 'detachAllData()' removes all non-function objects in the R search path. } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'use', 'detach', 'search'} \examples{ attach(CO2) data(Hakimi) attach(Hakimi) search() detachAllData() search() } \keyword{database}epicalc/man/des.rd0000644000176000001440000000567712026244665013605 0ustar ripleyusers\name{des} \alias{des} \title{Desription of a data frame or a variable} \description{Description of a data frame or a variable or wildcard for variable names} \usage{ des(x=.data, select, exclude) } \arguments{ \item{x}{an object such as a vector (variable), a matrix, a table, a list or a data frame} \item{select}{expression, indicating columns to select from '.data.'} \item{exclude}{expression, indicating columns to exclude} } \details{The default value of x (ie if no argument is supplied) is '.data'. If 'x' is a data frame, its variable names will be listed with class and the description of each variable. If 'x' is a variable, the environment and attached data frame containing 'x' will be described. For a data frame containing too many variables, 'select' and 'exclude' can be specified to display fewer variable descriptions at a time. Unlike 'keepData', these two arguments do not have any permanent effect on the data frame.} \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'use', 'summ', 'label.var', 'subset' and 'keepData'} \examples{ data(Oswego) use(Oswego) # In the tutorial, when "oswego.rec" which is an EpiInfo file is available, # instead of typing the above two lines, one can directly type: # use("oswego.rec") des() # This is one of the most useful Epicalc functions! #### Detection of variables of the same name in different data frames. # Note that 'age' is a variable in '.data' due to the function 'use'. des(Oswego) # Same results. Note that 'age' is also in 'Oswego'. des(infert) # The third 'age' is in another data frame, # from the datasets package in R, 'infert'. attach(infert) search() # Show all data frames that are in the search path des(sex) # 'sex' is found only in '.data' des(induced) age <- "abc" # Just a silly example for a variable des(age) # Shows all occurrences of 'age', wherever it is rm(age) detachAllData() #### Wildcard for variables use(Oswego) des("c*") # Show all variables starting with 'c' des("?????") # Show all variables with 5 characters in the name agegr <- cut(age, breaks=c(0,20,40,60,80)) label.var(agegr, "age group") # Note that the above line incoperates 'agegr' into '.data # making it eligible to be included in the group under the following wildcard des("age*") #### Subset of variables in .data des(select = 1:5) # First five variables des(select = age:onsetdate) # Same results des(select = c(1,2,5,20)) des(select = c(age, sex, onsetdate, fruitsalad)) des(select = sex:chocolate) ## The following six lines give the same results des(select = -(sex:chocolate)) des(select = -sex:-chocolate) des(select = -(2:19)) des(select = -19:-2) des(exclude = sex:chocolate) des(exclude = 2:19) #### Wildcard: same effects with or without 'select' des(select = "c*") des("c*") ## Exclusion using wildcard, however, needs an 'exclude' argument. des(exclude = "c*") } \keyword{database} epicalc/man/Decay.rd0000644000176000001440000000150012026244665014034 0ustar ripleyusers\name{Tooth decay} \docType{data} \alias{Decay} \title{Dataset on tooth decay and mutan streptococci} \description{ Relationship between bacteria and presence of any decayed tooth. } \usage{data(Decay)} \format{ A data frame with 436 observations on the following 2 variables. \describe{ \item{\code{decay}}{a numeric vector indicating presence of tooth decay} \item{\code{strep}}{a numeric vector indicating number of colony-forming-units (CFUs) of \emph{Streptococcus mutan} in the saliva} } } \source{Teanpaisan, R., Kintarak, S., Chuncharoen, C., Akkayanont, P. 1995 Mutans Streptococci and dental -caries in schoolchildren in Southern Thailand. \emph{Community Dentistry and Oral Epidemiology} \bold{23}: 317-318.} \examples{ data(Decay) use(Decay) des() } \keyword{datasets} epicalc/man/Compaq.rd0000644000176000001440000000177312026244665014243 0ustar ripleyusers\name{Cancer survival} \docType{data} \alias{Compaq} \title{Dataset on cancer survival} \description{A dataset on cancer survival checking whether there is a survival difference between cancer patients in private and public hospitals.} \usage{data(Compaq)} \format{ A data frame with 1064 observations on the following 7 variables. \describe{ \item{\code{id}}{a numeric vector} \item{\code{hospital}}{a factor with levels \code{Public hospital} \code{Private hospital}} \item{\code{status}}{a numeric vector} \item{\code{stage}}{a factor with levels \code{Stage 1} \code{Stage 2} \code{Stage 3} \code{Stage 4}} \item{\code{agegr}}{a factor with levels \code{<40} \code{40-49} \code{50-59} \code{60+}} \item{\code{ses}}{a factor with levels \code{Rich} \code{High-middle} \code{Poor-middle} \code{Poor}} \item{\code{year}}{a numeric vector indicating the year of recruitment into the study} } } \examples{ data(Compaq) use(Compaq) des() } \keyword{datasets} epicalc/man/codebook.rd0000644000176000001440000000153512026244665014604 0ustar ripleyusers\name{Codebook} \alias{codebook} \title{Codebook of a data frame} \description{Print description, summary statistics and one-way tabulation of variables} \usage{ codebook(dataFrame=.data) } \arguments{ \item{dataFrame}{A data frame for printing the codebook} } \details{The default value of dataFrame (ie if no argument is supplied) is '.data'. While 'summ' produces summary statistics of both numeric and factor variables, 'codebook' gives summary statistics of all numeric variables and one-way tabulation of all factors of the data frame.} \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'use', 'summ', 'tab1' and 'tableStack'} \examples{ data(Familydata) use(Familydata) des() codebook(Familydata) codebook() # Same result since line #2 has created .data from Familydata } \keyword{database} epicalc/man/ci.rd0000644000176000001440000000640612026244665013414 0ustar ripleyusers\name{CI} \alias{ci} \alias{ci.default} \alias{ci.binomial} \alias{ci.numeric} \alias{ci.poisson} \title{Confidence interval of probabilty, mean and incidence} \description{Compute confidence interval(s) of variables or values input from keyboard.} \usage{ ci(x, ...) \method{ci}{default}(x,...) \method{ci}{binomial}(x, size, precision, alpha = 0.05, ...) \method{ci}{numeric}(x, n, sds, alpha = 0.05, ...) \method{ci}{poisson}(x, person.time, precision, alpha = 0.05, ...) } \arguments{ \item{x}{a variable for 'ci', number of success for 'ci.binomial', mean(s) for 'ci.numeric', and counts for 'ci.poisson'} \item{size}{denominator for success} \item{precision}{level of precision used during computation for the confidence limits} \item{alpha}{significance level} \item{n}{sample size} \item{sds}{standard deviation} \item{person.time}{denominator for count} \item{...}{further arguments passed to or used by other methods} } \details{These functions compute confidence intervals of probability, mean and incidence from variables in a dataset or values from keyboard input. 'ci' will try to identify the nature of the variable 'x' and determine the appropriate method (between 'ci.binomial' and 'ci.numeric') for computation. 'ci' without a specified method will never call 'ci.poisson'. The specific method, ie. 'ci.binomial', 'ci.numeric' or 'ci.poisson', should be used when the values are input from the keyboard or from an aggregated data frame with columns of variables for the arguments. 'ci.binomial' and 'ci.numeric' employ exact probability computation while 'ci.numeric' is based on the t-distribution assumption. } \value{'ci.binomial' and 'ci.poisson' return a data frame containing the number of events, the denominator and the incidence rate. 'ci.numeric' returns means and standard deviations. All of these are followed by the standard error and the confidence limit, the level of which is determined by 'alpha'} \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'summ'} \examples{ data(Oswego) use(Oswego) # logical variable ci(ill) # numeric variable ci(age) # factor ci(sex=="M") ci(sex=="F") # Example of confidence interval for means library(MASS) use(Cars93) car.price <- aggregate(Price, by=list(type=Type), FUN=c("mean","length","sd")) car.price ci.numeric(x=car.price$mean, n=car.price$length, sds=car.price$sd.Price ) # Example of confidence interval for probabilty data(ANCdata) use(ANCdata) death1 <- death=="yes" death.by.group <- aggregate.numeric(death1, by=list(anc=anc, clinic=clinic), FUN=c("sum","length")) death.by.group ci.binomial(death.by.group$sum.death1, death.by.group$length) # Example of confidence interval for incidence data(Montana) des(Montana) age.Montana <- aggregate.data.frame(Montana[,1:2], by=list(agegr=Montana$agegr),FUN="sum") age.Montana ci.poisson(age.Montana$respdeath, person.time=age.Montana$personyrs) # Keyboard input # What is the 95 \% CI of sensitivity of a test that gives all # positive results among 40 diseased individuals ci.binomial(40,40) # What is the 99 \% CI of incidence of a disease if the number # of cases is 25 among 340,000 person-years ci.poisson(25, 340000, alpha=.01) # 4.1 to 12.0 per 100,000 person-years } \keyword{database} epicalc/man/cc.rd0000644000176000001440000001222212026244665013377 0ustar ripleyusers\name{cc} \alias{cc} \alias{cci} \alias{cs} \alias{csi} \alias{make2x2} \alias{graph.casecontrol} \alias{graph.prospective} \alias{labelTable} \title{Odds ratio calculation and graphing} \description{Odds ratio calculation and graphing} \usage{ cc(outcome, exposure, decimal = 2, cctable = NULL, graph = TRUE, original = TRUE, design = "cohort", main, xlab = "auto", ylab, alpha = .05, fisher.or = FALSE, exact.ci.or = TRUE) cci(caseexp, controlex, casenonex, controlnonex, cctable = NULL, graph = TRUE, design = "cohort", main, xlab, ylab, xaxis, yaxis, alpha = .05, fisher.or = FALSE, exact.ci.or = TRUE,decimal = 2 ) cs(outcome, exposure, cctable = NULL, decimal = 2, method="Newcombe.Wilson", main, xlab, ylab, cex, cex.axis) csi(caseexp, controlex, casenonex, controlnonex, cctable = NULL, decimal = 2, method="Newcombe.Wilson") graph.casecontrol(caseexp, controlex, casenonex, controlnonex, decimal=2) graph.prospective(caseexp, controlex, casenonex, controlnonex, decimal=2) labelTable(outcome, exposure, cctable = NULL, cctable.dimnames = NULL) make2x2(caseexp, controlex, casenonex, controlnonex) } \arguments{ \item{cctable.dimnames}{Dimension names of the variables, usually omitted} \item{decimal}{number of decimal places displayed} \item{outcome, exposure}{two dichotomous variables} \item{cctable}{A 2-by-2 table. If specified, will supercede the outcome and exposure variables} \item{graph}{If TRUE (default), produces an odds ratio plot} \item{design}{Specification for graph; can be "case control","case-control", "cohort" or "prospective"} \item{caseexp}{Number of cases exposed} \item{controlex}{Number of controls exposed} \item{casenonex}{Number of cases not exosed} \item{controlnonex}{Number of controls not exposed} \item{original}{should the original table be displayed instead of standard outcome vs exposure table} \item{main}{main title of the graph} \item{xlab}{label on X axis} \item{ylab}{label on Y axis} \item{alpha}{level of significance} \item{fisher.or}{whether odds ratio should be computed by the exact method} \item{exact.ci.or}{whether confidence limite of the odds ratio should be computed by the exact method} \item{xaxis}{two categories of exposure in graph} \item{yaxis}{two categories of outcome in graph} \item{method}{method of computation for 95 percent limits of risk difference} \item{cex.axis}{character expansion factor for graph axis} \item{cex}{character expansion factor for text in the graph} } \details{'cc' usually reads in two variables whereas in 'cci' four number are entered manually. However, both the variables and the numbers should be omitted if the analysis is directly on a table specified by 'cctable'. From both functions, odds ratio and its confidence limits, chisquared test and Fisher's exact test are computed. The odds ratio calcuation is based on cross product method unless 'fisher.or' is set as TRUE. It's confidence limits are obtained by the exact method unless exact.ci.or is set as FALSE. 'cs' and 'csi' are for cohort and cross-sectional studies. It computes the absolute risk, risk difference, and risk ratio. When the exposure is a risk factor, the attributable fraction exposure, attributable fraction population and number needed to harm (NNH) are also displayed in the output. When the exposure is a protective factor, protective efficacy or percent of risk reduced and number needed to treat (NNT) are displayed instead. If there are more than 2 exposure categories and the sample size is large enough, a graph will be plotted. 'method' in 'csi' and 'cs' chooses whether confidence limits of the risk difference should be computed by Newcomb-Wilson method. Both this and the standard method may give non-sensible values if the risk difference is not statistically significant. 'make2x2' creates a 2-by-2 table using the above orientation. 'graph.casecontrol' and 'graph.prospective' draw a graph comparing the odds of exposure between cases and controls or odds of diseased between exposed and non-exposed. These two graphic commands are automatically chosen by 'cc' and 'cci', depending on the 'design' argument. Alternatively, a contingency table saved from 'make2x2' can be supplied as the 'cctable' argument for the 'cc' function and so on. } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'fisher.test', 'chisq.test' and 'mhor'} \examples{ data(Oswego) use(Oswego) cc(ill, chocolate) cc(ill, chocolate, design="case-control") cs(ill, chocolate) # The outcome variable should come first. # For the following table # chocolate # ill FALSE TRUE # FALSE 7 22 # TRUE 20 25 # cci(25, 22, 20, 7) graph.casecontrol(25, 22, 20, 7) graph.prospective(25, 22, 20, 7) # Each of the above two lines produces untitled graph, which can be decorated # additionally decorated #Alternatively table1 <- make2x2(25,22,20,7) cc(outcome=NULL, exposure=NULL, cctable=table1) cs(outcome=NULL, exposure=NULL, cctable=table1) agegr <- pyramid(age, sex, bin=30)$ageGroup cs(ill, agegr, main="Risk ratio by age group", xlab="Age (years)") } \keyword{array} epicalc/man/BP.rd0000644000176000001440000000073512026244665013321 0ustar ripleyusers\name{Blood pressure} \docType{data} \alias{BP} \title{Dataset on blood pressure and determinants} \description{ This dataset contains information on the records of 100 adults from a small cross-sectional survey in 2001 investigating blood pressure and its determinants in a community. } \usage{data(BP)} \format{A data frame containing 100 observations and 6 variables with variable descriptions.} \examples{ data(BP) use(BP) des() } \keyword{datasets} epicalc/man/be2ad.rd0000644000176000001440000000465112026244665013776 0ustar ripleyusers\name{BE to AD} \alias{be2ad} \title{Change year in B.E. to A.D.} \description{Convert Buddhist era date to Christian era date} \usage{be2ad(Date.in.BE) } \details{This function may be useful in countries where dates are (wrongly) commonly entered in the Buddhist Era (BE). The function subtracts 543 from the year component of the argument 'Date.in.BE'. See 'note' below.} \arguments{ \item{Date.in.BE}{an object of class Date} } \note{ Although this function is useful in converting dates in BE to AD, there is still a serious limitation. All computers validate a date field based on the Gregorian calendar (AD). Since AD is BE less 543 years and the leap year is always with AD being a multiple of 4 (and not a multiple of 100, except if it is a multiple of 400), the computer will return an invalid date for any record with 29 February and the year in BE. Thus, any candidate dataset for this function should not have any date of 29 February. The function be2ad \strong{cannot} retrospectively solve this problem. If a user wants to enter data using BE, the above limitation can only be overcome by separating the three fields of BE year, month and day during data entry and then using either the existing data entry software, such as Epidata, or a statistical software, such as R, to change BE years to AD years before incorporating them into a new date variable. Thus, this date variable would have year in AD only and will not need be2ad. In order to display the correct date variable in BE format, locale must be in Thai and appropriate format must be chosen. See example. Despite the above limitation, this function is kept in Epicalc. The reason is that there would still be a lot of (those type of faulty) datasets around in the countries that use BE that require changing BE to AD before any analysis of date variables can proceed. In doing so, the analyst must be aware of this potential problem in the dataset. It is advisable to check the data first to see whether there are any dates that fall on 29 February. } \author{Virasakdi Chongsuvivatwong \email{ } } \examples{ Date1 <- as.Date("2543-2-28") be2ad(Date1) ## Not run: ## One would never have to # be2ad(as.Date("2551-2-29")) ## because as.Date("2551-2-29") is an invalid Date ## End(Not run) # To display date and time in BE under Thai Window OS format(Sys.Date(), "\%x") format(Sys.time(), "\%c") } \keyword{database} epicalc/man/bang.rd0000644000176000001440000000220012026244665013714 0ustar ripleyusers\name{Bangladesh Fertility Survey} \alias{Bang} \docType{data} \title{ Dataset from 1988 Bangladesh Fertility Survey} \description{ The file consists of a subsample of 1934 women grouped in 60 districts. } \usage{data(Bang)} \format{ A data frame with 1934 observations on the following 7 variables. \describe{ \item{\code{woman}}{identifying code of each woman} \item{\code{district}}{identifying code for each district} \item{\code{user}}{\code{1} = using contraceptive \code{0} = not using} \item{\code{living.children}}{Number of living children at time of survey} \tabular{lll}{ \tab 1 \tab = none\cr \tab 2 \tab = 1\cr \tab 3 \tab = 2\cr \tab 4 \tab = 3 or more\cr } \item{\code{age_mean}}{age of woman in years, centred around the mean} \item{\code{urban}}{Type of region of residence: \code{1} = urban, \code{0} = rural} \item{\code{constant}}{constant term = 1} } } \source{Huq, N. M., and Cleland, J. 1990. Bangladesh Fertility Survey 1989 (Main Report). Dhaka: \emph{National Institute of Population Research and Training}} \keyword{datasets} epicalc/man/auc.rd0000644000176000001440000000163012026244665013563 0ustar ripleyusers\name{auc} \alias{auc} \title{Area under time-concentration curve} \description{Compute area under time-concentration curve for individuals} \usage{auc(conc, time, id=NULL) } \details{This function compute auc using simple trapezoid summation. id=NULL is used when concentration (conc) and time are from only one subject. } \arguments{ \item{conc}{concentration} \item{time}{time point where the concentration was measured} \item{id}{subject identification} } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'auc' in 'PK' package} \examples{ # Using 'by' and 'sapply' to compute individual auc of Indometh data tmp <- by(data=Indometh, INDICES = Indometh$Subject, FUN = function(x) auc(conc=x$conc, time=x$time, id=NULL)) sapply(tmp, as.numeric) # A better way to compute use(Indometh) auc(conc=conc, time=time, id=Subject) } \keyword{database} epicalc/man/Attitudes.rd0000644000176000001440000000343312026244665014764 0ustar ripleyusers\name{Attitudes dataset} \alias{Attitudes} \docType{data} \title{ Dataset from an attitude survey among hospital staff} \description{ Survey on attitudes related to services among hospital staff. Codes for the answers qa1 to qa18 are \tabular{lll}{ \tab 1 \tab = strongly disagree\cr \tab 2 \tab = disagree\cr \tab 3 \tab = neutral\cr \tab 4 \tab = agree\cr \tab 5 \tab = strong agree\cr } } \usage{data(Attitudes)} \format{ A data frame with 136 observations on the following 7 variables. \describe{ \item{\code{id}}{identifying code of repondent} \item{\code{sex}}{gender of respondent} \item{\code{dep}}{code of department} \item{\code{qa1}}{I have pride in my job} \item{\code{qa2}}{I'm happy to give service} \item{\code{qa3}}{I feel difficulty in giving service} \item{\code{qa4}}{I can improve my service} \item{\code{qa5}}{A service person must have patience} \item{\code{qa6}}{I would change my job if had the chance} \item{\code{qa7}}{Devoting some personal time will improve oneself} \item{\code{qa8}}{Hard work will improve oneself} \item{\code{qa9}}{Smiling leads to trust} \item{\code{qa10}}{I feel bad if I cannot give service} \item{\code{qa11}}{A client is not always right} \item{\code{qa12}}{Experienced clients should follow the procedure} \item{\code{qa13}}{A client violating the regulation should not bargain} \item{\code{qa14}}{Understanding colleagues will lead to understanding clients} \item{\code{qa15}}{Clients like this place due to good service} \item{\code{qa16}}{Clients who expect our smiling faces create pressure on us} \item{\code{qa17}}{Clients are often self-centered} \item{\code{qa18}}{Clients should be better served} } } \keyword{datasets} epicalc/man/ANCtable.rd0000644000176000001440000000214512026244665014426 0ustar ripleyusers\name{ANC Table} \docType{data} \alias{ANCtable} \title{Dataset on effect of new ANC method on mortality (as a table)} \description{ This dataset contains frequency of various combinations of methods of antenatal care in two clinics with the outcome being perinatal mortality. } \usage{ data(ANCtable) } \format{ A data frame with 8 observations on the following 4 variables. \describe{ \item{\code{death}}{a numeric vector: 1=no, 2=yes} \item{\code{anc}}{a numeric vector indicating antenatal care type: 1=old 2=new } \item{\code{clinic}}{a numeric vector indicating clinic code: 1=clinic A, 2=clinic B} \item{\code{Freq}}{a numeric vector of frequencies} } } \examples{ data(ANCtable) use(ANCtable) death <- death==2 anc <- factor(anc); levels(anc) <- c("old", "new") clinic <- factor(clinic); levels(clinic) <- c("A","B") glm1 <- glm(death ~ anc ,weights=Freq, family=binomial) logistic.display(glm1) glm2 <- glm(death ~ anc + clinic ,weights=Freq, family=binomial) logistic.display(glm2) lrtest(glm1, glm2) rm(death, anc, clinic) } \keyword{datasets} epicalc/man/ANCdata.Rd0000644000176000001440000000123012026244665014202 0ustar ripleyusers\name{Antenatal care data} \alias{ANCdata} \docType{data} \title{ Dataset on effect of new antenatal care method on mortality} \description{ This dataset contains records of high risk pregnant women under a trial on new and old methods of antenatal care in two clinics. The outcome was perinatal mortality. } \usage{data(ANCdata)} \format{ A data frame with 755 observations on the following 3 variables. \describe{ \item{\code{death}}{a factor with levels \code{no} \code{yes}} \item{\code{anc}}{a factor with levels \code{old} \code{new}} \item{\code{clinic}}{a factor with levels \code{A} \code{B}} } } \keyword{datasets} epicalc/man/alpha.rd0000644000176000001440000001004512026244665014100 0ustar ripleyusers\name{alpha} \alias{alpha} \alias{alphaBest} \title{Cronbach's alpha} \description{Calculate reliability coefficient of items in a data frame} \usage{ alpha (vars, dataFrame = .data, casewise = FALSE, reverse = TRUE, decimal = 4, vars.to.reverse = NULL, var.labels = TRUE, var.labels.trunc =150) alphaBest (vars, standardized = FALSE, dataFrame = .data) } \arguments{ \item{vars}{a vector containing at least three variables from the data frame} \item{dataFrame}{data frame where items are set as variables} \item{casewise}{whether only records with complete data will be used} \item{reverse}{whether item(s) negatively correlated with other majority will be reversed prior to computation} \item{decimal}{number of decimal places displayed} \item{var.labels}{presence of descriptions of variables in the last column of the output} \item{var.labels.trunc}{number of characters used for variable descriptions, long labels can be truncated} \item{vars.to.reverse}{variable(s) to reverse prior to computation} \item{standardized}{whether choosing the best subset of items is based on the standardized alpha coefficient, if FALSE then the unstandardized alpha coefficient is used} } \details{This function is based on the 'reliability' function from package 'Rcmdr', which computes Cronbach's alpha for a composite scale. There must be at least three items in 'vars' specified by their names or their index in the data frame. The argument 'reverse' (default = TRUE) automatically reverses items negatively correlated with other majority into negative and reports the activities in the first column of the last result section. This can be overwritten by the argument 'vars.to.reverse' Similar to the 'reliability' function, users can see the effect of removing each item on the coefficents and the item-rest correlation. 'alphaBest' is a variant of 'alpha' for successive removal of items aiming to reach the highest possible Cronbach alpha. The resultant values include variable indices of excluded and remaining items, which can be forwarded to 'tableStack' to achieve total and mean scores of the best selected items. However, there is no promise that this will give the highest possible alpha. Manual attemps may also be useful in making comparison. } \value{A list. 'alpha' returns an object of class "alpha" \item{alpha}{unstandardized alpha coefficient} \item{std.alpha}{standardized alpha coefficient} \item{sample.size}{sample size} \item{use.method}{method for handling missing values} \item{rbar}{the average inter-item correlation} \item{items.selected}{names of variables included in the function} \item{alpha.if.removed}{a matrix of unstandardized and standardized alpha coefficients and correlation of each item with the rest of the items} \item{result}{as above but includes a column showing the items that were reversed (if TRUE) and a column of item description. As a matrix, it could be sent to a spreadsheet software using 'write.csv'} \item{decimal}{decimal places} \item{item.labels}{a character vector containing descriptions of the items} 'apha.Best' returns a list of the following elements \item{best.alpha}{the possible highest alpha obtained from the function} \item{removed}{indices of items removed by the function} \item{remaining}{indices of the remaining items} \item{items.reversed}{names of items reversed} } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'cronbach' from 'psy' package and 'reliability' from 'Rcmdr' package and 'tableStack' and 'unclassDataframe' of Epicalc} \examples{ data(Cars93, package="MASS") use(Cars93) alpha(vars=c(Min.Price:MPG.highway, EngineSize)) data(Attitudes) use(Attitudes) alpha(qa1:qa18) # Needs full screen of Rconsole alpha(qa1:qa18, var.labels.trunc=30) # Fits in with default R console screen alpha(qa1:qa18, reverse=FALSE) alphaBest(qa1:qa18) -> best.alpha best.alpha # .7621 tableStack(best.alpha$remaining, reverse=TRUE) # Manual attempts by trial and error give the following alpha(c(qa1:qa9, qa15,qa18)) # .7644 } \keyword{database} epicalc/man/aggregate.plot.rd0000644000176000001440000001410312026244665015715 0ustar ripleyusers\name{aggregate plot} \alias{aggregate.plot} \title{Plot summary statistics of a numeric variable by group} \description{Split a numeric variable into subsets, plot summary statistics for each} \usage{ \method{aggregate}{plot}(x, by, grouping = NULL, FUN = c("mean", "median"), error = c("se", "ci", "sd", "none"), alpha = 0.05, lwd = 1, lty = "auto", line.col = "auto", bin.time = 4, bin.method = c("fixed", "quantile"), legend = "auto", legend.site = "topright", legend.bg = "white", xlim = "auto", ylim = "auto", bar.col = "auto", cap.size = 0.02, lagging = 0.007, main = "auto", return.output = FALSE, ...) } \arguments{ \item{x}{a numeric variable} \item{by}{a list of grouping elements for the bar plot, or a single numeric or integer variable which will form the X axis for the time line graph} \item{grouping}{further stratification variable for the time line graph} \item{FUN}{either "mean" or "median"} \item{error}{statistic to use for error lines (either 'se' or 'sd' for barplot, or 'ci' or 'none' for time line graph). When FUN = "median", can only be 'IQR' (default) or 'none'.} \item{alpha}{level of significance for confidence intervals} \item{lwd}{relative width of the "time" lines. See 'lwd' in ?par} \item{lty}{type of the "time" lines. See 'lty' in ?par} \item{line.col}{colour(s) of the error and time lines} \item{bin.time}{number bins in the time line graph} \item{bin.method}{method to allocate the "time" variable into bins, either with 'fixed' interval or equally distributed sample sizes based on quantiles} \item{legend}{presence of automatic legend for the time line graph} \item{legend.site}{a single character string indicating location of the legend. See details of ?legend} \item{legend.bg}{background colour of the legend} \item{xlim}{X axis limits} \item{ylim}{Y axis limits} \item{bar.col}{bar colours} \item{cap.size}{relative length of terminating cross-line compared to the range of X axis} \item{lagging}{lagging value of the error bars of two adjecant categories at the same time point. The value is result of dividing this distance with the range of X axis} \item{main}{main title of the graph} \item{return.output}{whether the dataframe resulted from aggregate should be returned} \item{...}{additional graphic parameters passed on to other methods} } \details{This function plots aggregated values of 'x' by a factor (barplot) or a continuous variable (time line graph). When 'by' is of class 'factor', a bar plot with error bars is displayed. When 'by' is a continuous variable (typically implying time), a time line graph is displayed. Both types of plots have error arguments. Choices are 'se' and 'sd' for the bar plot and 'ci' and IQR for both bar plot and time line graph. All these can be suppressed by specifying 'error'="none". 'bin.time' and 'bin.method' are exclusively used when 'by' is a continuous variable and does not have regular values (minimum frequency of 'by' <3). This condition is automatically and silently detected by 'aggregate.plot' before 'bin.method' chooses the method for aggregation and bin.time determines the number of bins. If 'legend = TRUE" (by default), a legend box is automatically drawn on the "topright" corner of the graph. This character string can be changed to others such as, "topleft", "center", etc (see examples). 'cap.size' can be assigned to zero to remove the error bar cap. } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'aggregate.data.frame', 'aggregate.numeric', 'tapply'} \examples{ data(Compaq) use(Compaq) aggregate.plot(x=year, by=list(HOSPITAL = hospital, STAGE = stage)) aggregate.plot(x=year, by=list(HOSPITAL = hospital, STAGE = stage), return = TRUE) aggregate.plot(x=year, by=list(HOSPITAL = hospital, STAGE = stage), error="sd") aggregate.plot(x=year, by=list(HOSPITAL = hospital, STAGE = stage), error="ci") # moving legend and chaging bar colours aggregate.plot(x=year, by=list(HOSPITAL = hospital, STAGE = stage), error="ci", legend.site = "topleft", bar.col = c("red","blue")) # manual creation of legend aggregate.plot(x=year, by=list(HOSPITAL = hospital, STAGE = stage), legend = FALSE) legend(x=7,y=6,legend=c("Public","Private"), fill=grey.colors(2), cex=1.3) aggregate.plot(x=year, by=list(HOSPITAL = hospital, STAGE = stage), FUN = "median", legend.site = "topleft") # Example with regular time intervals (all frequencies > 3) data(Sitka, package="MASS") use(Sitka) tab1(Time, graph=FALSE) # all frequencies > 3 aggregate.plot(x=size, by=Time) aggregate.plot(x=size, by=Time, cap.size = 0) # Note no cap on error bars aggregate.plot(x=size, by=Time, grouping=treat) # For with black and white presentation aggregate.plot(x=size, by=Time, grouping=treat, lty = 1:2, line.col = c(1,1)) aggregate.plot(x=size, by=Time, grouping=treat, FUN="median", line.col=3:4, lwd =2) # Compare with boxplot below boxplot(size ~ treat + Time, col = 3:4, las=3) # Example with irregular time intervals (some frequencies < 3) data(BP) use(BP); des() age <- as.numeric(as.Date("2008-01-01") - birthdate)/365.25 pack() tab1(age, graph=FALSE) aggregate.plot(x=sbp, by=age) aggregate.plot(x=sbp, by=age, grouping=saltadd) aggregate.plot(x=sbp, by=age, grouping=saltadd, bin.method="quantile") aggregate.plot(x=sbp, by=age, grouping=saltadd, lwd=3, line.col=c("blue","green")) aggregate.plot(x=sbp, by=age, grouping=saltadd, lwd=3, line.col=c("blue","green") , main = NULL) title(main="Effect of age and salt adding on SBP", xlab="years",ylab="mm.Hg") points(age[saltadd=="no"], sbp[saltadd=="no"], col="blue") points(age[saltadd=="yes"], sbp[saltadd=="yes"], pch=18, col="green") ## For a binary outcome variable, aggregrated probabilities is computed data(Outbreak) use(Outbreak) recode(vars = age, old.value = 99, new.value = NA) aggregate.plot(diarrhea, by=age, bin.time=5) diarrhea1 <- factor(diarrhea) levels(diarrhea1) <- c("no","yes") pack() aggregate.plot(diarrhea1, by=age, bin.time=5) } \keyword{database} epicalc/man/aggregate.numeric.rd0000644000176000001440000001243212026244665016404 0ustar ripleyusers\name{aggregate numeric} \alias{aggregate.numeric} \title{Summary statistics of a numeric variable by group} \description{Split the numeric variable into subsets, compute summary statistics for each, and return the results in a data frame.} \usage{ \method{aggregate}{numeric}(x, by, FUN=c("count","sum","mean","median","sd","se","min","max"), na.rm=TRUE, length.warning=TRUE, ...) } \arguments{ \item{x}{a numeric variable} \item{by}{a list of grouping elements, each as long as the variables in 'x'. Names for the grouping variables are provided if they are not given. The elements of the list will be coerced to factors (if they are not already factors).} \item{FUN}{scalar functions to compute the summary statistics which can be applied to all data subsets.} \item{na.rm}{whether missing values will be removed during the computation of the statistics.} \item{length.warning}{show warning if x has any missing values} \item{...}{additional arguments passed on to 'aggregate'} } \details{This is the 'aggregate' method for objects inheriting from class 'numeric'. If Epicalc is loaded, applying 'aggregate' to a numeric variable 'x' will call 'aggregate.numeric'. If 'x' is a data frame, 'aggregate.data.frame' will be called. If the Epicalc package is not loaded, 'aggregate', from the stats package, coerces numeric variables (including 'ts' objects) into a data frame and calls 'aggregate.data.frame'. The 'FUN' argument in 'aggregate.data.frame' can accept only one function. 'aggregate.numeric' takes a different approach. More than one function can be suppplied to the 'FUN' argument, however it can only be applied to one numeric variable. 'aggregate' in Epicalc is 'backward compatible' with the 'aggregate' function from the stats package. In other words, Epicalc users do not need to change basic syntax or arguments. However, the naming system of the returned object is slightly different. In addition to the ability to provide more statistics in one command, another useful feature of 'aggregate.numeric' in Epicalc is the default values of FUN. Without typing such an argument, 'aggregate.numeric' gives commonly wanted statistics in a shorter line of command. Note that 'na.rm' set to TRUE by default to allow computation of descriptive statistics such as 'mean', and 'sd', when they are in the FUN argument, and 'length' is computed with missing records included. In standard R functions, the equivalent argument is '"na.rm"=TRUE'. The default value of the argument 'length.warning' is TRUE. A condition where 'x' has any missing value will be noticed, which is useful during data exploration. In further analysis, after missing values have been recognized, users may change 'length.warning' to FALSE to make the output look nicer. Both 'na.rm' and 'length.,warning' will have no effect if there are no missing values in x. 'count' is an additional function specific to 'aggregate.numeric'. It displays the number of non-missing records in each subgroup. 'aggregate.plot' makes use of the above function in drawing bar plots with error lines computed from 'aggregate.numeric'. When 'FUN="mean"', the automactic choice of error values is "se". Users can also choose "sd" or "ci". 'alpha' is effective only for 'error="ci"'. If 'FUN="median"', the error values are inter-quartile range. } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'aggregate', 'summ' and 'tapply'} \examples{ data(Compaq) use(Compaq) ## If 'x' is a data frame, the default S3 aggregate method from the stats package is called. aggregate(data.frame(id,year), by=list(HOSPITAL=hospital, STAGE=stage), FUN="mean") # The two additional columns are means of 'id' and 'year' ## If 'x' is a numeric vector, 'aggregate.numeric' from Epicalc package is called. aggregate(year, by = list(HOSPITAL = hospital, STAGE = stage), FUN = mean) # The above command is the same as the one below. # However, note the difference in the name of the last column of the returned # data frame. aggregate.data.frame(year, by = list(HOSPITAL = hospital, STAGE = stage), FUN = mean) # aggregate in Epicalc can handle multiple functions aggregate(year, by = list(HOSPITAL = hospital, STAGE = stage), FUN = c("mean", "sd", "length")) ## Handling of missing values .data$year[8] <- NA use(.data) aggregate(year, by = list(STAGE = stage), FUN = c("length", "count")) # Note the difference between 'length' and 'count' in Stage 1 # Means of subsets in 'aggregrate.data.frame' # have 'na.rm' set to FALSE. aggregate.data.frame(year, by = list(STAGE = stage), FUN = "mean") ## The default value of 'na.rm' is TRUE in aggregate.numeric of Epicalc. aggregate(year, by = list(STAGE = stage), FUN = c("mean","median")) ## It can be set to FALSE though. aggregate(year, by = list(STAGE = stage), FUN = c("mean","median"), "na.rm"=FALSE) # Omitting the FUN argument produces various statistics. options(digits=3) aggregate(year, by = list(HOSPITAL = hospital, STAGE = stage)) # Warning of na.rm aggregate(year, by = list(HOSPITAL = hospital, STAGE = stage), length.warning=FALSE) # Newly defined functions can be used p05 <- function(x) quantile(x, prob=.05, na.rm=TRUE) p95 <- function(x) quantile(x, prob=.95, na.rm=TRUE) aggregate(year, by = list(HOSPITAL = hospital, STAGE = stage), FUN=c("p05", "p95")) } \keyword{database} epicalc/man/adjust.rd0000644000176000001440000001542712026244665014316 0ustar ripleyusers\name{adjust} \alias{adjust} \title{Adjusted and standardized mean, proportion and rate} \description{Computation of adjusted or standardized mean, proportion and rate after generalized linear modelling} \usage{adjust(adjust = NULL, by, model, standard=NULL, offset=FALSE, type = c("response", "link"), se.fit=TRUE, alpha=.05, ci=FALSE, ...) } \arguments{ \item{adjust}{expression, indicating independent variable(s) of the model to be adjusted for} \item{by}{a list of elements for the grouping variables. The elements of the list will be coerced to factors (if they are not already factors).} \item{model}{object of class 'glm' on which the adjustment computation is based} \item{standard}{a vector controlling standard values for coefficients in the model} \item{offset}{whether the predict results will include the offset term of the model being used for prediction} \item{type}{ the type of prediction required. The default is "response", which uses the scale of the original response variable. For a binomial model, the default estimates are predicted probabilities. For a Poisson model the default estimates are predicted incidence rates if 'offset=FALSE', and predicted counts otherwise. The alternative "link" transforms the estimates back to the same scale as the linear predictor.} \item{se.fit}{whether standard errors to the linear predictors should be returned} \item{alpha}{significance level} \item{ci}{whether the confidence intervals should be computed} \item{...}{additional arguments passed on to other methods} } \details{Crude means, proportions and rates among different groups are not readily suitable for comparison among subgroups due to potential confounding. Generalized linear modelling (glm) handles potential confounding and provides coefficients indicating the level of difference between the specific group and the referent group after adjustment for other independent variables in the model. The current function 'adjust' adds on information to an existing 'glm' model. It gives predicted values of subgroups specified in 'by' list. The returned predicted values, if type="response", reflect the magnitude (of mean, proportion and rate) of each subgroup after adjustment for the variable(s) specified in the 'adjust' argument. The estimated values are based on each adjusted variable being equal to its grand mean value in the dataset of the model. Variables not included in the 'adjust' argument are set to mean values of each subgroup. Standardization is meant to fix the variable(s) with value(s) specified in the vector 'standard' instead of subgroup mean (when 'adjust' is NULL) or grand mean (when 'adjust' is specified. If there is any conflict between 'adjust' and 'standard', the latter will override the former. For adjustment, simply give variable name(s) in the 'adjust' argument. For standardization, the argument must be a vector of the same length as the model coefficients less one (since the Intercept term is already standardized as 1). All elements of this vector except those to be standardized should be 'NA'.} \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'glm', 'predict.glm', 'confint'} \examples{ library(MASS) use(Cars93) des() model1 <- glm(Price ~ Origin + Horsepower + DriveTrain, family=gaussian) table(Origin, DriveTrain) # Crude mean price by Origin and DriveTrain Table.crude.means <- tapply(Price, list(Origin, DriveTrain), mean) # Adjusted mean price adjust(Horsepower, list(Origin, DriveTrain), model=model1) a <- adjust(Horsepower, list(Origin, DriveTrain), model=model1) Table.adjusted.means <- xtabs(mean ~ Origin + DriveTrain, data=a) # Compare crude means with adjusted means of subgroups Table.crude.means Table.adjusted.means # Price by category of DriveTrain adjusted for Horsepower & Origina adjust(c(Horsepower,Origin), list(DriveTrain), model=model1) ## Now for crude and adjusted probabilities of having manual transmission manual <- Man.trans.avail =="Yes" model2 <- glm(manual ~ Origin + Horsepower + DriveTrain, family=binomial) Table.crude.probabilities <- tapply(manual, list(Origin, DriveTrain), mean) adjust(Horsepower, by=list(Origin, DriveTrain), model = model2) b <- adjust(Horsepower, list(Origin, DriveTrain), model = model2) Table.adjusted.probabilities <- xtabs(probability ~ Origin + DriveTrain, data=b) # What is the breakdown of probability of having manual transmission # if all cars in each subgroup have 180 horse power? model2$coefficients # 'Horsepower' is the second variable. c <- adjust(by=list(Origin, DriveTrain), model=model2, standard=c(NA,180,NA,NA)) Table.standardized.probabilities <- xtabs(probability ~ Origin + DriveTrain, data=c) # Compare crude and adjusted probabilities Table.crude.probabilities Table.adjusted.probabilities Table.standardized.probabilities # Age-sex- standardized attack rate data(Oswego) use(Oswego) sex <- factor(sex, labels=c("famale","male")) pack() tabpct(sex, ill, percent="row") # Crude attack rate = 68.2 percent in males and 51.6 percent in females agegr <- pyramid(age, sex, bin=30)$ageGroup lr1 <- glm(ill ~ sex * agegr, family=binomial) # Assuming a standard population have equal number of male and female # and uniform distribution of agegr thus the probability is # .5 in each sex, 1/2 in each agegr and 1/6 in each age-sex group. lr1$coefficients # Coefficients of 'agegr' are 3 to 6 adjust(by=list(sex=sex), model=lr1, standard=c(.5,rep(1/3,2),rep(1/6,2))) # Age- & sex- standardized attack rate=59.9 percent zap() data(Montana) use(Montana) agegr <- factor(agegr, labels=c("40-49","50-59","60-69","70-79")) label.var(agegr, "age group") period <- factor(period, labels=c("1938-1949","1950-1959","1960-1969","1970-1977")) label.var(period, "period of working") start <- factor(start, labels=c("pre 1925", "1925 and after")) label.var(start, "starting year") model3 <- glm(respdeath ~ agegr + period + start, offset=log(personyrs), family=poisson) agg <- aggregate.data.frame(.data[,1:2], list(period=period, start=start), mean) crude.count <- agg[,3] Table.crude.count <- xtabs(respdeath ~ period + start, data=agg) crude.personyrs <- agg[,4] Table.personyrs <- xtabs(personyrs ~ period + start, data=agg) crude.rate <- agg[,3]/agg[,4] Table.crude.rate <- xtabs(crude.rate ~ period + start, data=agg) adjust(adjust=agegr, by=list(period, start), model3) c <- adjust(adjust=agegr, by=list(period, start), model3) Table.adjusted.rate <- xtabs(rate ~ period + start, data=c) d <- adjust(adjust=agegr, by=list(period, start), model3, offset=TRUE, ci=TRUE) Table.adjusted.count <- xtabs(count ~ period + start, data=d) # Compare crude and adjusted counts Table.crude.count Table.adjusted.count # Compare crude and adjusted rates Table.crude.rate Table.adjusted.rate } \keyword{database} epicalc/man/addMissingRecords.rd0000644000176000001440000000471012026244665016421 0ustar ripleyusers\name{addMissingRecords} \alias{addMissingRecords} \title{Add missing records to a longitudinal data set} \description{Add missing records to a longitudinal data set, complete the fixed parts of covariates those missings and add a variable to indicate whether the subject was present in that schedule visit} \usage{ addMissingRecords(dataFrame = .data, id, visit, outcome, check.present = TRUE, present.varname = "present", update.visit.related.vars = TRUE) } \arguments{ \item{dataFrame}{Source data frame} \item{id}{identification variable} \item{visit}{index visit} \item{outcome}{outcome variable(s)} \item{check.present}{whether a new variable should be added to indicate the presence of the subject in the particular visit} \item{present.varname}{name of the new variable indicating the presence of the subject} \item{update.visit.related.vars}{whether visit related variables among the added records should be updated} } \details{This function is used with a longitudinal data set where id, visit and outcome must be specified. If there is any duplicated visit, the function will prompt error and stop. The records of missing visits are added together with the fixed non-outcome covariates (which do not change over time in each subject) filled up. By default, a new variable "present" is annexed on the last column of the output data frame. Like all other Epicalc data management functions, variable descriptions are kept. } \author{Virasakdi Chongsuvivatwong \email{ } } \seealso{'fillin'} \examples{ data(bacteria, package="MASS") des(bacteria) head(bacteria, 10) # week 6 X01 and week 4 of X02 were missing addMissingRecords(dataFrame=bacteria, id=ID, visit=week, outcome=y) -> bacteria.new head(bacteria.new, 10) # Note that the missing weeks are now added 'ap', 'hilo' and 'trt' which are fixed to id # were automatically updated. # A variable 'present' is also added. # Columns are reordered to have ID and week leading others variables rm(bacteria.new) data(Xerop) Xerop$time[500:501] <- 5:6 # Correct the error in the dataset Xerop[1:25,] # Note Record 19 & 20, id 121140 had only two visits Xerop.new <- addMissingRecords(dataFrame=Xerop, id=id, visit=time, outcome=xerop) des(Xerop.new) Xerop.new[19:24,] rm(Xerop.new) # Note that 4 new records where this subject missed the followup were added. # Id relatee variable ie. 'sex', and visit related variable ie. 'season' are updated # and 'present; is addeded } \keyword{database}epicalc/DESCRIPTION0000644000176000001440000000077112026255064013417 0ustar ripleyusersPackage: epicalc Version: 2.15.1.0 Date: 2012-09-19 Title: Epidemiological calculator Author: Virasakdi Chongsuvivatwong Maintainer: Virasakdi Chongsuvivatwong Depends: R (>= 2.6.2), foreign, survival, MASS, nnet Suggests: Description: Functions making R easy for epidemiological calculation. License: GPL (>= 2) URL: http://CRAN.R-project.org/ Packaged: 2012-09-19 04:27:35 UTC; Virasakdi Repository: CRAN Date/Publication: 2012-09-19 05:37:56 epicalc/demo/0000755000176000001440000000000012026244665012635 5ustar ripleyusersepicalc/demo/Epicalc.features.r0000644000176000001440000000563312026244665016204 0ustar ripleyusers opar <- par(ask = dev.interactive(orNone = TRUE)) ### Reading and quick exploration data(Oswego) use(Oswego) codebook() # Same as 'codebook(.data)' and codebook(Oswego) # since 'use' has created .data as a copy of the data.frame des() summ() # Describe subset of variables des("c*") # Show all variables starting with 'c' des("?????") # Show all variables with 5 characters in the name ### Quick graphic exploration summ(age) summ(age, by=sex) dotplot(age) dotplot(age, by=sex) ### Creating as well as exploring age group pyramid(age, sex, binwidth=10) -> output agegr <- output$ageGroup # The above and this line created 'agegr' from the pyramid summ(agegr) ### Integrate a vector into the default data frame (.data) # The following line both labels and integrates 'agegr' into '.data' label.var(agegr, "Age group") des() tab1(agegr) tabpct(agegr, chocolate) # Note the label of age group des("age*") # Both 'age' and 'agegr' will be described ### Recoding variable tab1(chocolate) recode(chocolate, is.na(chocolate), TRUE) tab1(chocolate) ### Computing and graphing odds ratio cc(ill, chocolate) mhor(ill, chocolate, sex) ### Computing risk difference, relative, NNT for a protective factor cs(ill, chocolate) ### Computing attributable fraction of a risk factor cs(ill, vanilla) ### Display of logistic regression results model1 <- glm(case ~ induced + factor(spontaneous), data=infert, family=binomial) # Note that 'induced' and 'spontaneous' are both originally continuous variables logistic.display(model1) # Having two spontaneous abortions is quite close to being infertile! # This is actually not a causal relationship ### Likelihood ratio test model2 <- glm(case ~ factor(spontaneous), data=infert, family=binomial) logistic.display(model2) lrtest(model1, model2) # Number of induced abortions is associated with increased risk for infertility #### ROC curve lroc1 <- lroc(model1, table=TRUE) lroc1 # Note the returned list lroc2 <- lroc(model2, add=TRUE, line.col="black") legend("bottomright",legend=c(lroc1$model.description, lroc2$model.description), lty=1, col=c("red","brown"),bg="white") title(main="Comparison of two logistic regression models") ### ROC from a table of diagnostic test table1 <- as.table(cbind(c(1,27,56,15,1),c(0,0,10,69,21))) colnames(table1) <- c("Non-diseased", "Diseased") rownames(table1) <- c("(0,15]","(15,30]","(30,45]","(45,60]","60+") table1 roc.from.table(table1, graph=TRUE) ### Matched tabuation ever.induced <- infert$induced > 0 matchTab(infert$case, ever.induced, infert$stratum) ### Longitudinal plot use(Indometh) followup.plot(Subject, time, conc) library(MASS) use(Sitka) followup.plot(tree, Time, size) followup.plot(tree, Time, size, line.col = "brown") followup.plot(tree, Time, size, line.col = "multicolor") followup.plot(tree, Time, size, n.of.lines=20, line.col = "multicolor") par(opar) epicalc/demo/00Index0000644000176000001440000000007712026244665013773 0ustar ripleyusersEpicalc.features Demonstration of various features of Epicalc epicalc/data/0000755000176000001440000000000012026244670012616 5ustar ripleyusersepicalc/data/Xerop.rdata0000644000176000001440000001173612026244665014744 0ustar ripleyusers \guǿywkgmϤ&@Ll(EDѨM!"ԏԻ T**ZTTMAxG+U%+ ?QG^ɀ_TUfb@12O4Oܦ0%}WUs *GRx&J叀7Zg|3ހ+ndR!˸xUfտ)Pf:y2~媗3c@(. gȖ%5||3| ^ $ 2/yɂo \oS^—C^sqToikW+<,H'7B3yݐ݄q+3Z s2oZʼX Scϣ+`´6&6)QW;7>A'qWewݨC/y2qACC 29rq}KoFOG&qY(Uۦz;{TxCn=c»ޭpXH=OAs 2`9(Aޛd*1,tՕQH`'Sx>fhJ?*+e {)+DSo>0/[; ̃[>ܥQs!C`c2?ƫ;}/0( kmQ~r{?[:c:Gi R0`{S7[^s ?N<`sωCQN^؜|S +& Sx( E93uZuL㌩Vc56O߱:KE8tN1Mrn[t^⾟Dq'Y瘴^:No\{=Ec+>e9e,/Ҳھe2k`}8h9byyH8GzfָcB8Vz{7,-Wy[oTl֙Оiֲ|KYgb-y1; :e+@q+\6}-,ϱ\eZ3 }ԴT{Z6]4rro2l}bcc{kYf3+am~вh[h's ,ׂW͈6r76,8&| sQɷ[`8&Q]n~]t#ƞ ƶo@'~t/`-Zݱ"1w 5Sf/x8KV 13u=/'b,}--# Ϻ:vbm{񔽪Ҿj9rin?AhSt1dR1b3:|܄{ Kq(s~m]kikf -Gk9M1Ig7i}] 66q m+]≮4c k|p=̳<\I]Ӵ)0):L}"룟63aLo7znי(؄꺢cgN}?m, Ӟ#!1g85ujHzmukh$nmiR͋bqePb+O^|%i}~a5~,a|i,Υl?_{8J<,ּ,9g^ymA2toQZ()\ÿc=?RUHZ?i;Y,8c6$ygՆV/ӒRJVq1"ty.oEk6ϋCYmQB5g-bibȾvQ6~S/K9zUs[e_ͪky츋~/<睇7K~۲c| О=&̽V'ߺgb5q3܊X C'mgx [-h3Zܱ:7ܭKCX>xܭj6Qc FMjN--~-|B5\ÏqM1:_Ωvp;+2up^XZdh,pB_s~4/ػAE}ǠW55cF{_a}aiǛ ̃XGg-so3ϴ7>VL_:_&nOOf.HۗbGpsX&xǼ?Kt"㩑9ܰoԢx _GA[KMXxypAO|B?ʂZL&ooV̹\ 0;Qfaաm0Yy@>U+g0WTHL4oW} u62d#֫d ca'X]x[zM RH,|񌾣~6 6s1Q/͚phxzZk6 d|-/mڠE{~Lt^dϋK?IC+`of:} C&\/I};crĄ s6[bD-Bpi=J4pkZR(=Nu61|lݏ@"<ϻ2R.}߸16Uv۔~fK\ ss?lf NvҔ4"yo/iY$]eKkleiKׇKB?H'^w{<^7\CϏs^\;bqYIuK:AXk0rZ:֞&$]U4R:_x~cqş!I6eI^Ӝ'JcYz^xtOwX\i|^^:g:6yCn ﵷO6zn^w۟q:XJSsq#i.'Z4i9o]8yb^9&Q'^/96&G$`NxOHT8 m+%NPLxO0_FU^s^U]BB ~酟}_"@8BaPmɚ'"H~6{x!JZJ=D-XN:}b@P%ژqfLԗ]cU -h11<*м5&)\ Y&.cϰ~;1J1ϸZL=&aM9Cx ~GnZt5 Z*yt<7I| H1g>Es ZM3,E@Mk9Hʑmh%Z}BE]<ً8а2. >}b bA;_WVK'G4bm{){U;0P<7>shG„ d'1OiyEu|1ڵkr4x>h1=ml|&^5&#ZSiH|\N1cYr^?rA^klIEt:>/*$Y#%m$橭A!y Mv 3=7m|NN{u[m}8dr}SMl>{/5vds}MR}h91ȁ؊vS}qOΉL΢MwL܊qL63 $epicalc/data/VCT.rdata0000644000176000001440000000650612026244665014302 0ustar ripleyusers Zylg]ۉ6Niw%Q*Z=nvn*"Z(! GAB$(H G A!{}(~|ݗ8vs!2@f=:0fN|Veaы@OU0#@ 0 `߀&A'0>ƿ~0 `'ເೀ?^WwsC|ht-n-Y<x0|g(S/q@Ox`;ZQ@ ")X ^ߌq#5JQ1<( X^y'k@{ #ୀn|> o~ ~p { 'Wo>4Ԁ>*A _yǝW 0ox0X>}j΁zq_ x ӀpQp;݀7=#K| cp:C]hmo>qi>8S\hJ'(HW5#Ghn'4Fie8]{WPAZQ6k/%{ xS6 X WCU$q%/$ٻcʿI Ucٰ|a=$=BnSy=LyZA{uYQ{z}:{T^ZK\w\mGs"y<<j̨yx.5bګuiyk- lvj{}:fZljXs%;):7ZG~صYkO49O٥eܦXi{lܸ)h4v= ֢ըOҙj,]n5֢f+e}=ژj9fsQѤFoFZo.[ 2p`Vm}\;{7!&XI$W֣]YΥWIWҗu$'X۶ ;`c?n3#fIO:zv$6?)Z#]V>n'9f{1jzs4sj kM_|v{IG+} ߭Ds}4ڇ #[ tENقBJG9YD]X;I TcVn<ɗaCs7* #9ɜ"ί>\ZBk!ىvn!Iqx-ٷO,+ Tq=bR"z''ɶ1u~tƵőS=O9\Yvf YI9Z#^%C'ȿCΟOp>ec'aZOwUzr5q.O6;Z^Z;$#tdٸOXAg]ıÞL}޸6ꓓ SOi'1$ ۵QxNw>dH]IbK5'{?!whocF1r}X~g_X6pugM~vM{_鵖ΒIKW/|dFKs#^:{dܜ|iS#~{S휍ZoF3pfv~Fm&xiƟo5xmR%vN IS6*AXz]%7u%ctt'jNg(^l>kۻNOµk'P6Pʾu} ~ٚdg6EVI6[~&pWkgukwnu.}Sڟ=\,g.l݀-˳dd;{$;l;$7i_^sK\n^zs<'ѮAͭ)`-jKeo4˻_Z-%ӫOk=:v{F%fFtZ))O;ʇ~ڹQ9IQZe.:%΅kɷ$uNe߳JMXл~νFKuw. ێŅئ|<q8߻آyso3`+?6so *o6TPe}S0-dIȲefcmJ8y " ϓAΐalbYY27E#(3=IYh& B[ D6ǬX0dVO +UPtNˬTx֛.ɂ ph4f5(&&@tBެ+ ^,điٕ*蒈*.JFOW2·1]RU hԡD$0rY 9e5$.F|PR+Sx4-/%*-+*ER,JT%aQ%rsڊV$=jȲ:_9fԶjevA3%'c$%a^YeVBʪPaSlOOߠAȦ@)Kb͉䚓%/GkEA^AŸGeW,2r&-)3>"*'b0 A(>3ʪτʛWQ-Ijit/TUI}Q_EGb"/%ި7=[ҤA-c"VQRwhqKyPS MxGpVj%6}Q[ͳ͍z+ee<]zqQ?Dr=aMS vZQ1{,>lxvпlʍLP r_kGЉҙ:~翌'L1ٶdBg!00-sY\. \JSF%.hDc1ÈzSٴz۶:^k\>@ŵluUػ^5MÜH=ϝ tqquRK]F%)g` epicalc/data/VC1to1.rdata0000644000176000001440000000067312026244665014662 0ustar ripleyusers OO0'3B:wE,ꖨ+ KK\V;]PGc u`h@gs`ؙ%47yHk<<= 8uOJ҇WFyDy<2§CoWQߎڲ️ ^M,IzEsͦg &cԏc)D=T{uF- QC|N1z3aMht-0Pl-׹:)eZi$(S(Fp2,iZLQ_o50Gl;G[ epicalc/data/Timing.rdata0000644000176000001440000000137312026244665015072 0ustar ripleyusers VKo@ެhB4XJ\* jCoѦ4V(?_ڳzIJ(7볣vBsS^xnwE*`3a]+]AU{X68G:rsVlr'+R*28≔+\:,n.#?O o'Ѫۈ}>ڠ896QneZzeA`4јajH׻'t~OxToi-\ #JZcɓb6D)W$A:` 0v1 @O 1ّIw!y tSHRL$7$o$oIށ[y[Qkt^ )x+~8B'/R_:Wߋ8 iL&dՏL>v8P E9v P}hc4r_YjV4('@Hݦ!5qKWq4oyl+Źe<:9aN+q0AHs%P5h [9-kjlBquX4T4ßRk8ZŤA4Bvi{7O$Nepicalc/data/SO2.rda0000644000176000001440000000057412026244665013723 0ustar ripleyusers ];LAPAhCWAҨ EΘ(΄Z[iPjb|56&Gghef#n|;;% AXb`cՆ̃A3e̛h46¾%2T`;h F6腼SJ6q5u29<;ڲ2EWXW⍩+ec&ߩ3Ɨ>weuf_v\5H CR7i~ߊ=z1\[9B \v6w Ze: W -F&H   xrVSR))IKpnepicalc/data/Sleep3.rdata0000644000176000001440000000132112026244665014767 0ustar ripleyusers Un@8iӦ--bͦ;dD-JE0'UO[ ĪH|'d̸4},t|{}gxXUV*! Y`,^(O7L$"U*-( `e:bTxZG=ܥ u<BJ: ;BWe#d,Y8-mݔ2E%HCmv+rgOϯepicalc/data/Planning.rda0000644000176000001440000000632412026244665015065 0ustar ripleyusers ͜o\Ư);X @à$˒m^JEQo.oR;TpTX*0o99{ip73gfιr\}oEWJwW{(_?ggv[[Eq#gG~yOQ|г~9[з_C/@-AE%e{+Wנ@?~c'КhCo߀ _o7GGMQQ11qq II))iiT:t,Y!C>[o!| "!!G#1ȗ/ @[ZtC[[[[[[[[/_ ~2eW_~ +W_ ~*U_~ 5k_~:u7o~ 7o ~&Mo~ -[o ~6mۇe~;w.]w ~={~>} '\z룮{t}}Z w*+^=׻lry^~>/?7Qɥݨty]%Gf8ƕMz0ktx08>^t_Woxz^@W^1ub8(oQ^UȎׅ#[~?1!?(^~'&}=~dKvدzWI)nNMUV<=qYix9xh׫Z/~8O~/:_UUQ}T]"5=$?kn;?ptMߨۋm\\Rg.ngDSDrSܞy?7׋=F~sqy_G׹4wZ}Wꓓ{?y}~qF1'])_d/'?-] vWI箯\hDO ۟'k<}މk]z}Q0h7GvBA%io46MWޯWL_y,^?2|w"^7y>uq{:8^WŻ__Q^=μ܎5<{h}EHzA}q_۠Q߷=_:tu]5hxww_/UD|.ϫE{<Ȫ|yZߓ>_>8i]O{UGUqU{^Mu>ijg{'i=?_{Is~+7=q*Y=}_/_0={EȟOs"u };7n?^O8d//_yF9kE9'įPi9wHP[ò^rCmxx?o|h1ߛ(2e_NV 3ʻ#:+)yj\(Srk18ԗuV+YXGs _(M냺M<+GT7 {k+q3}OuT+܀.6=Ʌ⑾ΝJ~xJqYKƣ8)&W\ό?4^\~5ҹpS^yp,ٵފg?,i\rQK"OVw+;͋*/[|]m=\<.wC/ =׷dR給y/}]wҹ\Z7`|Kv,砬[j('k|Dϡwx;ӣ H_kLh|!NݜVФC1s? wg^?5-?{w/SL֧z)7V[]o?'{~~{YſXepicalc/data/Outbreak.rdata0000644000176000001440000002075112026244665015420 0ustar ripleyusers 9p]GvHjD=STS*JIQJR$AܱHbyޮ*(p(p0p\w@]ܮ{9s{z.8?aF0?aF0G?#AG?#AG?QE(G?QE(?1 cC?1 cC?qG8?qu`&dvN`vN`$vNb$&Y7ɺ)Mn /`{{Ⱥ{Ⱥ 'qMo|d$&Y7)d_?i{Ǻ{Ǻ{蹇{/3șfe>z>z>zٗ29퇢gE(^ws@c<sנyn :Ůy{(kXE,g?y?@?@?@q0'M̗OwAybG_? v. ػPb_@EYĞEY$AEpUFN9e*cWصD|/%{|Kr^x39̺2ʬ+,8e؇%a=798y΃w'| - _@пGPoAOpep]we)cO{(,6f?؏k \KZe,#g9YF2rEY *sx ~ ~ r*i@97m-˜9(~\fT ?>K>o.w ]xпEp,c;c;c;J^ɾٷ2V~eQƞ%Y]KYBrde,#g,e  rV "rk*[b o_r?][a xW䬰+Ass=]aWߕGP=XŏX9(~ U}`_*W U"?geV*~\UW*W U_*W U_*W UUW_UW_UW_UW_UW_UW_UW_UW_5_ 5_ 5_ 5_ 5_ 5_ 5_ 5_ u_u_u_u_u_u_u_u_ 7 7 7 7 7 7 7 7M7M7M7M7M7M7M7M7- - - - - - - - mGM=m6~i/ASU(jP>z](l Pܾ 1(~oBe(ЮC#? >}h?~+((q;(h7[vmY#}3S?4yG.YAAks=?0援]^$yIe퇤W^'dv]T7_fjy;Ga-j;ڒ}bԲOۖ}qiԶ΍/{mDmq&<7t~G;?&>x%o%_mkjqoܼˮӤ[™8ڲ{cV~5j?~odH55.#"ңyn_UT~jЗUuZMWE봝/T~OETGOۧ^Ei^>O }C͋<'"#x_Q/'{ߥs5zLqZWO9y}" } =Y.)>gr*>E_W2P"OESѣU_X`'}EKGߍyM5j5sEǫGgZ~[77Mq'rt:G:uLqkSnQMQ}ܚ7S=Fuiroj8yS?Kk{t^%>Luqez^6=ߛ~OgYԤG{Fǽ'}M"WȽz>u,~s%~d'vzA:^%?zKǟۃj߅\bIן75=s/u]0H+yMMN苊O{?TΣUϚ'u<9 {77˸3+yUWzlTnu)k;$_'@>|@|j-%Ou/Z/#~Ϫa]ÞcޗJ_ESDT|QLu=}.d\΃=fN?<^/'yRSBȿC!i9:94ŭgS7tgyPKsX>eϭw]w7Q 9z\O} T=J{od/{u=s{?ǵ[5WݩE|[TM|0e4OXo.5@o C*j y(5!Xh|X߮b-FF3vў@mIUC.k-   ~GT(:8U`=ݦ r3!{NQO`˃~O;]L,%=m8Cw]*$܎yvߓyF][셯,FѼﮃ;[kwm-F3C q&zߞgJ^90:dwl? nG}Ӥql-hAèG/hA =jBhvI:_P7*-k; kY۹[emWmY<+;t.;}Kʮ4m|Ƴ7Ss7]vt*-/r֣қ6B'-WP7*-}05_—y;_Aw&Fv+z<~/hA ZP-hAд7"-.nYqSiYmUN]q۶egaZ6W Zo{KgyMm#9}injaLqd_kZޖ8Ta}Lj4Ǥm^zQ^Riؽ>p[_쵵'j<Faږ`ȫx*7iz||/T?$fvmPm=j7_a붜yHk \o*[?wp }3-BXol7ЍyC33붱NS=gw z/u]/~Ι~.Qz_Tmj/_|w^||_45^uč+ͯC571SFඡOoĕzo\|F ZНDemGA ZЂiм;5-hA ZНIM-k ;MJڎ,*-k; umI9)y;_r-_A yҲcRi??=}PooZ[ZKiݴG ie/oYy7ם1k9vV!5Og]cЕ5s3</g%t=l[Z.n}@v>Nr""Ugø۝os2y7R؊v5ѐg;oq=#sw^>;8];I3Z* d}kQm >2 k<f\=G;ƣ ĹS;ι%{OL+*.Gd'nm'>beswo٧=G^2Ղ=.rx*DmfNw?pB*u&ywܸ6[)omηB?<3xQmͳo:s޽0.*N~tC0ihg0wӳyȚf ^l*ϙW Zݯw䵎;xW: O 1VE/5T2KN,5mo- ۠`Ov=4o3u8uI/̟'s v7d9ڶ[qE#)|fs;什|dw9OD=}Vzjx#,L]lsr.=}vwVf{dCq-ɖ˭jv=Z˞ }MXl{qAR{¾=ҞukaվcGO{V-U.ި|a)}i_Q6[?UOZ?%|qma|fRdoZqUK_äW5{,zI\;]0IqݢCuQeղ\0lUn<7oض%n>\QԖqcڒLxVwEگ iGQyΤu]t<E[z:?-G+[7ŭ6_kfi%:URN[mEs:y_֯q9doXK:>ޯwuZ]y{1E͟vji煝Wσk⵽][]V_wu7skV^\|o[|1~u|7_0/>5%|ū^*׾寨vD ӗqc/&)uz<^JeoԼuOӸK>[Wkʹ9?-ܺ*/Vܺ&yYg_m\ik\>']=[|qjkmRa-OZve_Q^K;}=;{#׶e]>O@R-sݚ8ǵE=EےwyɿqM\Õ/1%*^WqMW{Ҫ{|M5nӺCmmm%%'U{֞WmORu/nʱm'}YGzl5n}.jT+>8} Q[~J>zm'.ި-oujz|-7nӺOޛs:׽W_doXK:_avy-j2-@O.7w}X:8@oĝ[CcCEs/-ӗFF/; u@{~=3偱׮ $깻#wn[i:}B:{αS')]'x{2']o<Ϝɚ=w)tcޮO;TϞ>{ N;' uccgμδvcc7}l\mFfD?ل٧<4lB_xn3O0~?s0Qepicalc/data/Oswego.rdata0000644000176000001440000000316712026244665015111 0ustar ripleyusers ZRG^BJ!U*"ծ}H  a r\WJp99%W ʓ1|r2nά*==}3K Z}=4-%f,Qnj--9;Ǟ%{s| (lRSd"_R{ΟPY* Q9Y/R |  \>bjZx?x|ΟPEehyJC 7;3OAP?S/y*ׁ7 ^M*ԩG5#l߾(UrC{󙎘Jn u'xKFpH85N}䧖z]+Z_Ck2h$E8yR|(<{>qEهo;k8_Tl񼽰C?Nwdh3\5=‰8d"VF)sLq\\a4Q*ďPzLjo`Ut;.˷!k~r[_xwWyظp^pk#&\fZq_.>_8<(_|p!~ڛO.'#`pbؓf^~ޚ8:j/mf<.ex}jʋS=oLsODuVyUt6V5csEGa|Dyd6ѺuY{6eg*m*Sؒ Ҩ`*;F g%WZɔH ςօ*AB߼,ppo++k֨TZXשnWvn%dCEkRް_RڶUڀ Q)4w-nIf^o¤լxzvUp':tRZa [H+Ȓzfm-FԬ_)]m=>cwY^&epicalc/data/Montana.txt.gz0000644000176000001440000000150312026244670015372 0ustar ripleyuserseKT1 E"+x/0TvO>N켒}׾N>?=_dzןx~o!j?/ǿ/HWqr# s>N"yǤ.t`; }tEGdI&Ӄ4 L䪎X$! \y7T]A"spG0Bw=pG|"+$/ްv2~#p,ۣQ!7u); Ԣ荻z Į$4VFKgV%ksU.f( fB a<׼<4pfpu#,SF=ȡg+ӝH*opkv½VT2Z cQmMFJ;rq2-SesoF&W\ͪzn8Mwx憻w͞[?yy>Vww}_z7tL))6Qϔfgɔed˔_)ř%{v37/O2+3eȔw?)"S.aDL"~)_GF=4y27)?xLLĉI{!2Q~D#vȏ̔ȏΔ)?6S~\|jD~BĉiLd{&yk"gfOϔʔNg쐟9Q>'S>7G>om=s23 2 32Z}俚(0S~DřKD%'O_)rLD~uLLL_gʯ#o(~'oʔ߼GL-/#u|EoϔߑLL]=D̔߿C;Ȕ?G俟((xUGw+Sgʟ#L2b^hG'ʣr(LɔwN?9QD;3{?G?{)q=Ldf_!mL)̔)S=ɔ&͔%S^f?(po}?22!.g?(4SY/vȿ̔G)./p+W8ȔMJ[j{I]p)yR|}IM4]ί.e/WgM<)t9ϓMiRvr'e/Ӥ|R?[ӤaOCpH'{~9\Yʾ:]L9IsÉrCW _.'y.eG.3xw=S^Ȕwd!S^ʔww=Ȕg3LyDy8Qޒ)oϔ2rȔ3LyWl<)oʔLy>Sޖ)Ly!SbȻ$y.Sޔ)3-r)o#/d;2)/fKy&ʳ\"oʔL3mr3LyG2=RgwsLyCޒ)gy=S^Ȕwda)/Iޕ'Ly6SKMpe=LyG2ʼnDy4dʳ幉LyCޒ)OeDy{)Ȕyik[A"fs0Sjmr3=L9L3]v)fs|-S3LyG)/eʻy.Sޔ)yKSޖ)Lya#S=DyW,_\i<̔dL9ϔg L9dʋ;LyWT|ty6S˔7eÉLy>Sޖ)Ly!Sޑ)Ly1S^ʔwI埘.fsLy)oɔ3m;B#SR/]Y*ty6S˔Ly>S3{LyG2Ly)Sޕ'Ly.Sޔ)3-|-S3B#S{Lyi+Ok9l<)oʔLy>Sޖ)牼=S^Ȕwd!S^!/wȃ}ppKu[I\=?s^*Or(ɃQ܆VOir]WzťT*9::gyRu=u\ɏxŹL:|xw*<:9:OvDV:wy@:_zycvkZ D|Qߴ$II\+[qV{n"s)hR^ :xй$KZ?WWC9<(__دu ρ1)O{T^qϩʇڤԾY_(d ][$uZ~\?7_Jy)z~%9Ir7nʫZsaxYR^yV:{/{8_Yɾ#;|Az3uSO}.+79 6.@ʮnWW{WzoW/pKOai[^a}gɗ;̓Z/ܻHjuJSP<ըy<ěk_Pn7Hps?Q~߼@9n5+o(?aVN8RA(g>b}_h޿iGru>( m>Vu~]ST^y7чHz'>zGK{k^˱^ng:z:q[*]8~zA ź}{7ުzBi|V9Z/l]6P0i/|v5*_}Xg}7ߺoS9Zg`[%}۠ί9;$^qHϗԺYZ?]Gzx"zBG.{5%7<8~ƍyC:ԮZVۗp>-ؠ/[/.w1޴|ʿ[R?swS牣ϹV?]Agjh0>h}7} ]uWH94l-̑u G:'i O'ߧz yGu=39G6./t݇ͧ/6?zsg5sGR"<5ρ-G_=O=п?2~Ϲv}I~E&} A|8}I;n:}(ғigT܇#JZwq?#5=?Ao7RWymr~W>1>|Kڸeޗ}s7ἐ;Y_WQ^Xe߶nҺs6ZGٺ-nη}Q{#J} Ok _ѷ}if[2G?>u^z#gGxysWnɏQ==zsٺ7<dk܏=~3 W>+m?+N2ϘT$#Ǎ:Sg=ݡ5Oa7>syKr.Svޕ8ƃ^mCdE_bF gb4dηڽѹGt8Xڡ9(xm? ^ץOZkkvm0h=j=¾}/wXOKS?rXX~~{>D5++v# -~|ٵG/4>Gp+y/ӟ_ieZk}m ﷮9i]84#ܼGAAu5.>sp?M?s]f?~ky-iE\oh>7}%׺8usGպ{֯ڮϞӨs6FC_%{7d<3oW #~`z8~H?_G{[ٗև#лr5C:z=FmF^ } wپ؎V_t3vɯ}WFђ:c'ނ )??_}꾰Ih]m?cBo?̫G9z{cQ"yY0#a>o_~3}9O/gm߉Or]2vߡ?%9}=sMsǮqgi] ~f/i9p;+xbƏ~xGO IycG7?8먜yf]WȎz⺍;8cZW3D݄qxns}̾WA~VЇ4ߌ+6/Wy0}s"qN%߳gi>S{v-('<n?f>v?1u=[h;ߧ_7_m_GڍO0/q]P??EOʣ Usj]9cr=mn'HO7웉y7gA9m'2>Oo0>Xw+ #~~Nu7=Q85GG?k@oH=8|n~ޚg,.q'6Je|}Ol]OT^j刯"^(+X}WHXćj7~9i3H_>Ȏ9Ngi=j`?EI]]|1ߥ:7y]k+;&qH>Hi<{}?o#?z/~!N.5\hOx-o^[h>Yh|/ I'\Y]0|<޷/8guZ|Yh[,$lIg9h-[JOoyl!%yKHϽ ^RcMܞ+֍ Zw,叺>};&nM5=vfΤm(`

eҧ]~{)MÑxF$!_ua0y7xP{P9siZǏO/b?!K5~;+AĻcL=<Qi_bK6k^tOPwd>JzKcI_ >ʉkGZA qkě}93;=%-> n_Egt}y'`Ǒ8V'_ C2!K15UK?g '5ȞB>l~M =(dw *Ǿyvm`~{Y7oWoG6Lo-^^Qoz77<=*1}A{̎yFDkzMO6';)gggO _)=S|H>d7'qdc(N ; GG;s')YH{Z UkL5.}១Owm#C2W|߃FQJ_bw_W܆\{*?m0VO{s4str'A3Vo?7CyHzጮ54Ή]7~3i+`>}s?#_ϋKȾOCOg^k,WWiyL*={ɵη• q=Nenyؗ;þg㏋=5Zi{oy~Jj_кiXjFuaR%q{gA~Nӗs>Xe!zcj\^ESX'HWzE'Z ɾ^t淥Isx[H߱=iR/vʎm\oCOH" K*5McӾ}G)X7&!߁3σ8Ӿ&!~~_|CM ׬1N%Î$pv?ľڱyI9$ ^+G'~Mwzڇ=G_H?>)O\,B<}GZ 8EaG{}S?$0{?ooyY_'Ώ=8#'=ǫCi#~\}XR7x?N|hk}mI^p~==/kah?aI mzd`kcŸoQ&qhG>9ʑ/ohYeo G w*zP >⧓v]a/>Ij~OsaGfT˩̏gxRZqĭ[CcG2 n|Goγyc''/9}`1gpqzl,?:;>A|Zz'sr⯣~#.}!ǐr?]?K>x2J>N-ʑxxS^q ~d"'؃nKA q-K8 Y^hx??I "o1uC@W} !U ?@\ό} 7o_I`V̬$'n~?? ȿ"SY1o2_A'?Kǒ[yrlO O/~iBAZZ|.&*Š8F{Oќ3@},V039;eN~,q1ᇉ>8;OKd<<炥w[_@|3&\v]t}=yg{`agC ">@+`Yz9/#AV|$_(uL<>rpqy7bE#g|ң..2K)UG G/ٰ珟~¥7' zI▴'O=9HvQ5s%C?kz}q e?I?Q=߁<RXvn8ͧk۾?=O@ &{WÚ'- g1u q!_7g=<<oP}/#_Ag'Iqev  s9_G{7t^Rq#2㇏?6oo77ǀ%E1W$?rXΏ$t?`g^>xD;ZQ_9GEaΩisT#I~\$Ί8"P[p<~ܳ{s}s{޸ǿqޖJ罒p?iC3499$ᴊҀd\dտ$ByNxi_G)ԒҞ'?1)OR%-b0Z9$ȶ([IRgeNE=xe=<3)E=G&f30e^zEt~AC-n}B_Py-ZtI@GX'2X2P/|y2H+u%e) iff$HrGKo0/w،|܎\%e) 9 eId[6iOhU0=>'x0"6$g|2$L.ifXKIب,VB b}sG$Aן%3T3pp˼o#(H3e=ɗ Zsqyͽ~y>eyN^hJ^찡C'CJf'ن6Ip'0wVd֜; 1'np&6\ǒ|݇%Sr,2JT9gm4lxOqo-**3-ɹͪ6i(4U7$g8q/؇}O+)g ]ʓ\dw8a c\vtuIK>kWmм 0 ֏9[Ijg 8&'#?0+7c=$8ʤVn;Iw` KI= sM?2??b^ҡ'^[8bTgj9g8e>%F&O~lAUѿJlw2 oCH!.aę~}||ӂ:X+ 7i9W#HE0fr%Xтh΁pqwZ[RBS%NE̓kbqƼ}KΡFIyrɏrI]#uϩܖ';QvH^yߙAϺ~CPz?ph4/h/,v Iٟg1ΘK!Fy?-?^wWz-b"8kzkWIyNq6ȉւF)/`7'dZܳHBHe\/%Iú5I'Z8@h;V!Я$LKp=奇_'%S?r_( &!NFgE )Q .Jbh'=<&9죷[ñgqKMIdIB󒮧yku ܨ5gKx )Qrt Ve}g]Br Qϣ>*% ;"M'$I''Ev/$"(85Kn٧Op#8k$g "'}=/ $"C&lHH;Ư䛏ˏz-zb__z K)ca=^*oX2Hn繰VzȒqO/.o44}l/eհ"8C\t_gIb޽QR|eN$Cߋ~rI0;4{I[>]JՆ$?WhP1`Wdw> 'M<=˒Xi~8pr?$|mW/O,6v[ѻ<o'!oawfg} w#cI_9t-6_9A<'_SUw| KS?χv`'^׽XnH~LQH@r% -}IHBb6s`4ٕ>!3<@Nw=dZ4L'.[2CI_K.&xZ4h?.Dz=1)ϡ=.o(ɜ`H#I{ǁ$NPXJk;:Lq'zOapR}QعIn팮%o_~GS!gcaO/^)9%o/fq?c4 ;_} (K)S/|i~`Eu؏=G9z\w _7KrFO]=:bڐĂo.Ǿþs]OMkþ$O !Mf 5ole>'aa۰o ":پި.tJ~f GsU&KF7Kbn}&՟r8 v/&J=~cK9loiK.oCl>Buf~\7[餼]3+mwZI8]}]\֣jqG?c~򤿘Oa7ax^{[I8OzyHY$8 /Xb>T`8xI;B̷eɈez~}Cw N{siT?W9iɿKafpȓ cij'y9܎@uBFaJ/Z_VxZo]ÿ~׼5)!E_^qe{U(?mҤj[a-QC\CxU]R9;E"Cdv!gpe=yyClz(zCg$e&Nͺ 1cJ ľ!#vsW%c }=~mgGSG%/>۰H2E57$$-%skֹe͓A屿(nFk{NC@{OŹM:%> I$ǩO0`_޿;Z}@D;* 7*#Q%m$ލ%ԫ=Ơ|vF;5'q`mѯ.G'9,ugqa}Ρ^HK7+VX2v/[Dx9IfqA9PY?h5jFh,`FM'MoJAod=qWoOlg+>qHɯ^Y^0F%;[,+4?mω|T@RwɷD3Ո_:_]n+o7:q}Eܣl<kn>+w'<p IWݺq넟Sy,'yȳ9Ĉo>]I{^K Kqm%bܯA{3GaZ^ys_*B9+?.1i~aZ_Y|}fa17оm)eI:{I>s5/9,> "^xY~o:ʣ/Z-*z8yľiM9A,=QNvu'>?4>C~/ϾTv+݇!,p-Τ<ӓQny jˎ;~vy˻Ji3wN(,WrKhIܴ90.Ǐ,^'Go!qS;tW.o $xa<[yc<)Bwqc|[ngo:/8Mo7G5vAd">ʿzzgl\_E>9Iq=OQw;ԍy4 ?Mʾ͏ 7 )z3OyD*:yO{\4G]PWo߳+Y>/7hyaWbE^I'5IyaYO7w= '^ ~_*?-ϾAp!o0/=} ~m2/m}7qI^V2.+pF&!i{ =\_~ui?P=gaŏO9`e8Xb˼{xg'//ߥm7QWgٳg,qa;?;3^^p7@a߉J0l: Fiub9FR;+Cpvu̮'3⯁Xz 3vv]Υc^Z<+wҤl<`?$; A_/{gME}9϶ǿ}4fBq߶q>6G9 -Gn{xv;,~;wg?ΟxOoIyX\P9}G_++[E?~}/,+ޓ=<3j'v$_7r0{B~/`z0iy{yO7{3fqr!~iy]Kgþ?sa8 YRZ;KoAC88#{='˙ܷ'}S~A}ٸWxOOxMF~ |nX?-Ι0o!N=;s_}pF׵x IQZR}08gE^^}^=>-?mG{rܽNgAzqញO= ֿ?8ٗos9~N?s9~N? ' s9~N?|n8|xÎǿ֔2ab]}ڵK;>{?Sތs:N?Csʶϵn~OZ;~N?s9σu`mI{ߝ~;~g%ՎrݷN?8>>zj_zݓŝG'u7s9{O?X:=r݇,z}z8}G_IkӔq`h;i`w<u=+WI{f'M'9>}@NҺ~Ns< mx|8<{N礮_O,}ztm(ę_賞{ϾU?ɋn} A̢̒Js*zC{?PC5?4C~av4 *:((((((((((ꨬꨬꨬꨬꨬꨭꨭꨭꨭꨭhhhhhhhhhh謎謎謎謎謎譎譎譎譎譎:nt8 +;kym3mͼ6f^kym3 JJJJJ*****jjjjjZZZZZ:::::zzzzڜ%pΒYR8K gI,)%pΒYR8K gI,)%pΒYR8K gI,)%pΒYR8K gI,)%pΒYR8K gI,)%pΒYR8K gI,)%pΒYR8K gI,)%pΒYR8K gI,)%pΒYR8K gI,)%pΒYR8K gI,)%pΒYR8K gI,)%pΒYR8K gI,)%pΒYR:KJgI,)%tΒYR:KJgI,)%tΒYR:KJgI,)%tΒYR:KJgI,)%tΒYR:KJgI,)%tΒYR:KJgI,)%tΒYR:KJgI,)%tΒYR:KJgI,)%tΒYR:KJgI,)%tΒYR:KJgI,)%tΒYR:KJgI,)%tΒYR:KJgI,)%tΒYR:KJgI,)%rTΒYR9K*gI,%rTΒYR9K*gI,%rTΒYR9K*gI,%rTΒYR9K*gI,%rTΒYR9K*gI,%rTΒYR9K*gI,%rTΒYR9K*gI,%rTΒYR9K*gI,%rTΒYR9K*gI,%rTΒYR9K*gI,%rTΒYR9K*gI,%rTΒYR9K*gI,%rTΒYR;KjgI,%vΒYR;KjgI,%vΒYR;KjgI,%vΒYR;KjgI,%vΒYR;KjgI,%vΒYR;KjgI,%vΒYR;KjgI,%vΒYR;KjgI,%vΒYR;KjgI,%vΒYR;KjgI,%vΒYR;KjgI,%vΒYR;KjgI,%vΒYR;KjgI,%q4ΒY8KgI,i%q4ΒY8KgI,i%q4ΒY8KgI,i%q4ΒY8KgI,i%q4ΒY8KgI,i%q4ΒY8KgI,i%q4ΒY8KgI,i%q4ΒY8KgI,i%q4ΒY8KgI,i%q4ΒY8KgI,i%q4ΒY8KgI,i%q4ΒY8KgI,i%q4ΒY:KZgI,i%uΒY:KZgI,i%uΒY:KZgI,i%uΒY:KZgI,i%uΒY:KZgI,i%uΒY:KZgI,i%uΒY:KZgI,i%uΒY:KZgI,i%uΒY:KZgI,i%uΒY:KZgI,i%uΒY:KZgI,i%uΒY:KZgI,i%uΒY:KZgI,i%stΒY9K:gI,%stΒY9K:gI,%stΒY9K:gI,%stΒY9K:gI,%stΒY9K:gI,%stΒY9K:gI,%stΒY9K:gI,%stΒY9K:gI,%stΒY9K:gI,%stΒY9K:gI,%stΒY9K:gI,%stΒY9K:gI,%stΒY;KzgI,%wΒY;KzgI,%wΒY;KzgI,%wΒY;KzgI,%wΒY;KzgI,%wΒY;KzgI,%wΒY;KzgI,%wΒY;KzgI,%wΒY;KzgI,%wΒY;KzgI,%wΒY;KzgI,%wΒY;KzgI,%wΒY;KzgI,%gf7Ly~.e ?&܆swꝅzgYwꝅzgYwꝅzPo-BE"[zPo-Ce 2[zPo-Ce V*[zPoBU V:[zPoCu֡:[zPomBM 6&ۄzPomCm 6ۆzPomCm v.ۅzPoB] v>ۇzPoC}>x5 ^fWY,jx5 ^fWY,jx5 ^fWY,jx5 ^fWY,jx5 ^fWY,jx5 ^fWY,jx5 ^fWY,jx5 ^fWY,jx5 ^fWY,jx5 ^fWY,jx5 ^fWY,jx5 ^fWY,jx5 ^fWEUxU^WEUxU^WEUxU^WEUxU^WEUxU^WEUxU^WEUxU^WEUxU^WEUxU^WEUxU^WEUxU^WEUxU^WEUxU^WEUxU^WEUxU^WEUxU^WEUxU^WEUxU^WEUxU^WEUxU^WEUxU^WEUxU^WEUxU^WEUxU^WEUxU^WeUxU^WeUxU^WeUxU^WeUxU^WeUxU^WeUxU^WeUxU^WeUxU^WeUxU^WeUxU^WeUxU^WeUxU^WeUxU^WeUxU^WeUxU^WeUxU^WeUxU^WeUxU^WeUxU^WeUxU^WeUxU^WeUxU^WeUxU^WeUxU^WeUxU^WUUxU^UWUUxU^UWUUxU^UWUUxU^UWUUxU^UWUUxU^UWUUxU^UWUUxU^UWUUxU^UWUUxU^UWUUxU^UWUUxU^UWUUxU^UWUUxU^UWUUxU^UWUUxU^UWUUxU^UWUUxU^UWUUxU^UWUUxU^UWUUxU^UWUUxU^UWUUxU^UWUUxU^UWUUxU^UWuUxU^ՁWuUxU^ՁWuUxU^ՁWuUxU^ՁWuUxU^ՁWuUxU^ՁWuUxU^ՁWuUxU^ՁWuUxU^ՁWuUxU^ՁWuUxU^ՁWuUxU^ՁWuUxU^ՁWuUxU^ՁWuUxU^ՁWuUxU^ՁWuUxU^ՁWuUxU^ՁWuUxU^ՁWuUxU^ՁWuUxU^ՁWuUxU^ՁWuUxU^ՁWuUxU^ՁWuUxU^ՁWMUx^5WMUx^5WMUx^5WMUx^5WMUx^5WMUx^5WMUx^5WMUx^5WMUx^5WMUx^5WMUx^5WMUx^5WMUx^5WMUx^5WMUx^5WMUx^5WMUx^5WMUx^5WMUx^5WMUx^5WMUx^5WMUx^5WMUx^5WMUx^5WMUx^5WmUx^WmUx^WmUx^WmUx^WmUx^WmUx^WmUx^WmUx^WmUx^WmUx^WmUx^WmUx^WmUx^WmUx^WmUx^WmUx^WmUx^WmUx^WmUx^WmUx^WmUx^WmUx^WmUx^WmUx^WmUx^W]Ux^uW]Ux^uW]Ux^uW]Ux^uW]Ux^uW]Ux^uW]Ux^uW]Ux^uW]Ux^uW]Ux^uW]Ux^uW]Ux^uW]Ux^uW]Ux^uW]Ux^uW]Ux^uW]Ux^uW]Ux^uW]Ux^uW]Ux^uW]Ux^uW]Ux^uW]Ux^uW]Ux^uW]Ux^uW}Ux^W}Ux^W}Ux^W}Ux^W}Ux^W}Ux^W}Ux^W}Ux^W}Ux^W}Ux^W}Ux^W}Ux^W}Ux^W}Ux^W}Ux^W}Ux^W}Ux^W}Ux^W}Ux^W}Ux^W}Ux^W}Ux^W}Ux^W}Ux^W}Ux^"Eo/{ۋ^"Eo/{ۋ^"Eo/{ۋ^"Eo/{ۋ^"Eo/{ۋ^"Eo/{ۋ^"Eo/{ۋ^"Eo/{ۋ^"Eo/{ۋ^"Eo/{ۋ^"Eo/{ۋ^"Eo/{ۋ^"Eo/{ۋ^"Eo/{ۋ^"Eo/{ۋ^"Eo/{ۋ^"ڽ%GQ3 !H'|9ȱ}yk0s< Vu.÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷>|÷=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o=|{÷o~÷o?|~÷o?|~÷o?|~÷o?|~÷o?|~÷o?|~÷o?|~÷o?|~÷o?|~÷o?|~÷o?|~÷o?|~÷o?|~÷o?|~÷o?|~÷o?|~÷o?|~÷o?|~÷o?|~÷o?|~÷o?|~÷o?|~÷o?|~÷o?|~÷o?|~÷o?|~÷o?|~÷o?|~÷o?|~÷}G/>?<7O>xzo}ƿ"zտK}7o'}xsw%?~W~}Mzw3񟭿߭Ǘ_՟/_|ӻǝgOO_~w?Iz|77gO/?7>`}?}^'OE/~voƟ_߯-IxW_?HO):>cKepicalc/data/IudDiscontinue.rdata0000644000176000001440000000714412026244665016573 0ustar ripleyusers p]U_hiR' K4BEk 4/e#( VYJi })K$[6YD-0,"0Bys&Ӧ$w߹{ 5X3QD.Q7w}Vu}%c 2eJkR{Wkb"Qc_i}.j^D_Cѩ4dBOCB^^^.B.EB}} } 6AWCЯ@/#PW1qwQgtZ@3Gv=U:9(W Llt.z.#y({/Qʯ_̇%(r9z:eTW ѫk%uM-m(r7]2O+=h/ZACt%<<>2+DVU'ѧQ<} *:w[;?u臱֡qx1z ʼ  {/"^^k%(#'(#)/#e߇2n2•NчЇGh1-|>>z[$1.|>K̼ '^Aע/%◉_qJ93|yF:oI&17|]=ߋ* cC+XP (OUk*Ҟy[]DE/r_LbSμ^C= K(_B{y:ʯ= 7RSo"AfoqJ;8Z[)6KTI;]|UQS݃.|9E}ԯ@qU;mmF)_^[u1iiU̫U̫.EXiFi"u_ہR/c;q (Gc&㧢P;h?v;qO M`DOx&Q?}j]#57|3ܟ&$>I$I򹒌y=ۀ6U4_5Eh{%j5oɷ&ﺵ-⳶_#wc¾!_=O_cp>p,y#Gb_'99eOƿyԟ;$1߷{O=QN`OzDݯ &sExtby,sb]2nyzYO.x w(?|V_[']@|~ʇ0q}N3y}Ov')NaV\_ ?| /+o?rE?-2nvGoڱ]59|rs~n,%߮Kq+:<'џ{ڟD}8W7gf}{x'f} |_㾗v.bwoӎ}reGq%\uKF3j$8 G8˺=rQyE1\hM޿ F~3Ŵg?}wADǑ|)9ߛosĝ}\Dy*n?ŹRȺB|<n{Ts!ϐYy ޿gba ;O &9U->Eעmxt-|9NJ8<1< ` }]S!W7#,rCI~40<-< #p՝RhW)DZqŭߚ{;;=sz΁bw> z48qux`"tɃ]8Wʿ~%Wg:kD&j[M)tVs}+jZ6gԼoAa 5C}?kKۖ6H\} ?%퇚?k6Cư!>~cܘ7vc~[nKÛ=TsppMy}Zn3y7u/m96AȃNZjwSœ 3N`byf\RGgZl*5,Nz^j(ך[ :XVQ¿ڙ]ڒlo^UtcեݦsFK{?o1vPҩd*%݅q]E]dE]EdJ+㯬J+a{a{a{Xa{Xa{X)))))iiiiiYYYYY99999yyyyyQljeRFV)]ueV9]-)ܒrK-)ܒrK-)܌܌܌܌܌܌܌܌܌܌ܬܬܬܬܬܬܬܬܬܬRrK-%RrK-%RrK--rK--rK--2r-#2r-#2r-+ܲr-+ܲr-+rr-'rr-'rr-/r-/r-/7Ĉ%F,1bKXb#Ĉ%F,1bKXb#Ĉ%F,1bKXb#Ĉ%F,1bKXb#Ĉ%F,1bKXb#Ĉ%F,1bKXb#Ĉ%F,1bKXb#Ĉ%F,1bKXb#Ĉ%F,1bKXb#Ĉ%F,1bKXb#Ĉ%F,1bKXb#Ĉ%F,1bKXb#Ĉ%F,1bKXb+XĊ%V,bKXb+XĊ%V,bKXb+XĊ%V,bKXb+XĊ%V,bKXb+XĊ%V,bKXb+XĊ%V,bKXb+XĊ%V,bKXb+XĊ%V,bKXb+XĊ%V,bKXb+XĊ%V,bKXb+XĊ%V,bKXb+XĊ%V,bKXb[cFLF 3˅Yb[bF6=5nPQs m=68in|syλPG(*Oo( Gn*Lou;Uu?9$1k~ m@DBAǢщh#FC}%;èYm?rWkŭsJmۻ|=l..ǧk}Cmv-raۋŖGlqvI/ԾW~6`nԪ@b4epicalc/data/IudAdmit.rdata0000644000176000001440000001642012026244665015342 0ustar ripleyusers %U}ȑ Gb0!I3/* T C& 51hF\d}~Zq75K239{~zyap{bU=o{Ǫm[Omoy<7n);omXwa= H (x |-<7 7wwY\^-8 =𳰂¯γss!gy9Kqt^ __ 9n/+WAsãzx4| l/ Qxx<r~u^O@λΩ &fyy+6+7yy'w.=qy/~|~~2n:39~g^/CeRx2^;W«Րqܹ^΍&x3dwn!> Otڰ8KQ1W:wC|4 C/@ԙ__xeU:_߀A<יsp.ooo;A]=}|>  ??  __YTEF{7ګh;i.?.噴YٴGh3sh3si3h3i3 ho6(/ʋhb6(//hr6)Oʫhj6)ohz6*oʛhf6*ohv6+懶ʻhr6~+'i㹲MߕmWvhOў˒6>,?J/ˏƓ'hfy7mYCOOƫghl9Yy hSoҦߢM](MPO:Q>@zQ~6u|6.mH=ԓ+hS_ʇhSgʇiSoҦ?M)M*LzT6u)mS(mT3ԫ紩[/hS"}ux:~_K?u:~Auԅ<S'^TOݨ. [觎T[觞TO].R]D?u~Mu1ԝb?%_B%SK.UO}.:U]F?~Vu9ԯ cSϪ+駮UWO}:W]E?~^u5Կ5Sk.VO}:Y]G?~fu= SO駮V7O}n:[D?~nu3-S[.WO}n:]F?~vu;Sϫ;駮WwO}:_E?_MO&:끪M?U~?n\NN?׵ӧs;}\NI?׽gYs<}\OM?g4ƟsNi9?4ƟsNi9?/~oS EkV^8#Q5!o yk[C֒%o-yk[KړfHZג%-}G~}G~}G~}G~O~?O~?O~?O~??@?@?@?@?H ?H ?H ?H C?DC?DC?DC?D?L0?L0?L0?L0#䏐?B#䏐?B#䏐?B#䏐?B䏒?J(䏒?J(䏒?J(䏒?J(c䏑?Fc䏑?Fc䏑?Fc䏑?F䏓?N8䏓?N8䏓?N8䏓?N8n1}a/(x O[ p Vp.o~q 3ϐ?C 3ϐ}gȟ!gȟ!ӭϒ?K,ϒ?K>[gɟ%Ygɟ%|Α?Gsϑ?GGo#9ȟ#9:O<ϓ?O:l3N )^nJWjC 5d~NqP0xso1dL3{Ey^0`LC \?\/6yi^l/)u=|,;T'e롯O4u׵߅.C~á Cu >Pu;λ0|iGhywvޝOǽ8 _ohٺeyꞭo~oyRNnG`c\M<\GMEo;g]אŰaW`j<Ԃyuag]'|}`~2s4<\\mxte}l_}oO Ў;K?'|H?? A?5L=1@OyS?Lht9S2阮 K3h? YJMO1y OUS<ߘbb뿇 O 5lN *@ο6p>(@ioLp1q9kxr2ȅK2`' 2ld#kkeCq6̫j>sԷ"6u"3].x'OO{8iCݲ(>O庸F O1dp #wnC{l鯟.쒗^fH}o2>4fc_ʺ'q>; 9 9;}l?w _NA.\5s3\2v]Cw)OߙEc>5ǭ?e^f78lg4#硋gXwi o=mLrzK?>g{tm~cCӮo踙[/g?n\~8Cܟ Ge:&i}3a`CZr{L;t~7}0-Xe)=vBߴݡq״_C֍ >p^7xw/|η4|~|zmZ<( ]~v0}aS~ozdͷŮW~h -?>^υ#t6]φ>{:C><|>|lǙ=>´4ޗO+pzn!=v|9HhqsnK~kOq~ڌeccM®yۿ< Ofu^9N|:]޸~z?]S-|Az۳2o<3Zy@f>gC=29v=2j>ρBzއZchTK3>4gM7=y=izv{{.?km}og;;˲ݝmJl+寴ag\黡Bc+i9ߺ9^.۬͹tu;vx4m{vw]ٷ}v4-i]ՕΕnί]++MǡXiv+-iy+fBǾq>fg݌nγ+it3V=ֻr=.M9ҾZi5]+1{:զcrWھngcbqմ}ݮ߮nG(x4N]6ǓyѴV:vMcK'ў ~j1{1;hMnv~Ǭߴ~ؓoTt"Ḟ˽zN9S6l7 L0N^y nkxlNp'@>Gn<~C)Ox͆snzI?]eepicalc/data/HW93.rdata0000644000176000001440000000747412026244665014345 0ustar ripleyusers w|^U9颌x٣%$-yт, 4)ITVUfYRe(` FD<ܓ{&P'99yyv;hcqqu49cY~)LAvk.Ko2v_ޯ^o;ϙډ6-h_˘J?3_aqvQ'@;I詛6n|1n셇hdyނ n}?,r:O{%s7|Љ"BW< Fģ߆@NO;݀t.e?@'"y *&^ VO X!mӽ1gcڛjgn̝ 7F{_O-wT黌͂rG\ۙ'йP`7F{a%57J^r- D@> '_qjV/ݛh]9|ÜĘPė ǹP֡'MLۭx Wa_џ;2`= Nd<ےDg?ɢ#ýw1'c3#>GͰ_MN2N^2=G;8eW1mjK=f9=֑S-;d|I={\:4'aaMFl^af$%~eNW|6>`SNs`ijScF(qlDv`$7G3-qc9C> 'yNNLK~5N%yQ{ 5ђK-XfgC5Ė9+o%'~/,GgӗXFX{9r|_j!8gAwص2O7 J W͒s$ypG'18ɣR+7EIJ-aĪ\8|IEO8y{9k)n2Y+w 5Q h$={ᓖlqbs椎ˎa_~ҟ;>wnLO9<=`%&'4د-|&.Ko:':;_42͉V/#]~ "ј~WӐ^wŰB>ɺ _NC?iY\oIyy<]rHLg}OMxQ{]t{s}gucz{k|&:Ӻ*@sVNOk6_gq]XJ嘘j]}+y:}?kkG4︘7Ӄx-O?P/hIx{LLχGu3S$q=.|,OJ8T>WrF L{>]??'__Og/?V?ɟ 멷WEռz/+O?̟׼~+NO{$SJC@Ͽ߄AXUwO"9d=_2\ă_!OOA3o2?;CI}P;l95W=FEeUUC坟[/>z1"OFO8IrQTu5%j?'ɺ9>OhQ?u&wczRWg r=>'|뽂^Ṅ0ϩ?6xGy~zwPߣMOh> SDPj߇wLVL'yVAC{[X4И}^]cqzYkַK}>*]AtQ.|z=0|B_^eR}wi~Zr'r/8<{Ը[8Ͼ?=ן}TM==8[::}E7cze)^ \xjݲW*G>t?s4S\_]b$[i\vOF7SO_OEpgGJ^~_TuOy;=U_yՇֻEyy~\G])e>ɽ4o]7/sM^>A-A 10°K})b ,jX+W*XV9XXX :5bݏ P*Ԉ sI4fE1c%y$m PGDl1&csM 0c>;Ԉld} ]`w=r0C~,sõN~vKʣ?:ޟG)[ϓ/o_\޼"Kjkwdg˺w5 ?Ej٠'|Q^TQ괖鿚jrX5߫Ʒ]άuM_'c/!--2Z|nf#2xrKS~ݐ)M;䷝^nX j,U9+]2UL-+QKov=õ,!/_g|y{6M+SKy-P(Fw ܉vT["!A4Zu`BYtT#:ވ^8]8PAW`خAXNIw8ܮNtqņߡ; ɂwfe J'}1ZŢtL>JUCVP;Kؼi"vrdlݪ!;EgSCГ?uM@E;;וsd:@™\`PFS.Cuy=wBÏіg|vGOc,Ok12)ȹ}8,6G!6wvrNBB1 taSr}ThiHh%y:[lr2j2 CAlU'gd' &Bߺ~a0+tJ]Li{:׸I@(wU[׼Xk: 9v:͐s$0S{kZT0055qsO9NT|rNNI_9YHd8:ɨoW\ۘ>ߌ"'gV~RBOm_ cW[e`mqjh2o#杉'Ԕʾb#w\2(;{ZfAbLrW1UŹJ؈* $. 7Aɓ6!|[@wQepicalc/data/Familydata.rda0000644000176000001440000000107712026244665015372 0ustar ripleyusers Ao0'mV$ιL*c *$1&.N͉G>8 !>G> sZB~{K^QB u,BmEH{!BMb؛0R@ 3OQ Q(P8Dnʥpc*T [@o) |>r s m.d[ʩ'7Mg^,+7ZۮH]i=s# bUF+e,^/_Nxm6EIg )Z$calό7y WR̩\)afˈ$]O YL:˕Y6jUp׹Y**͍5r;now1RL"L+{)ZuNzf*W~ꅴc \jj &=s䂭;?kY)duyULnX'\yQuqbIʸ@Ri ($Ze]~st#_:V2V[[pepicalc/data/Ectopic.rdata0000644000176000001440000000514112026244665015226 0ustar ripleyusers xqIiC7;3hڤ:HJ7ڊ!{{=IgK~[ <ϟEm;7ݹh5ukslgh^,mҨ6m_A+]h5UW>._t)ZGGѥ:erty]+ѕ*tU]FtM]uzt}ݐnDinL㴁6&LMh G tSݜNh+L[6NSt*Ft:;tGݙBwt7;݃I{}Lj.bnԦݴ΢ݗGSif4Gԥ}@g9@у!P:FGyt>=Ecqxz=DOSitz=EϦsy|z^D/Kerz^EkuzzDo[mvzE{}~}>DGcq}>Egsy}D_W5:}Iߢow=>~H?O39~I_o;=Hҟ+Nҿ/%_¿/ ¿/ ¿/ ¿/ ¿/ ¿/ ¿/ ¿Q¿/ ¿/ ¿/ ¿/ ¿/ ¿/ ¿/ ¿/k+________u&________u.________________________________z`ƿoƿoz߀7777777777777777777777777777777777777777777777777tȁTY{oбT~|B:v(&uǨ?V#|]#mlKt`\jNSchMwu8ǶKork6vØO{J언IHKRcrqnj}vر)˒u[;)%ܺ)>t̒Vة5qq>4~mܚ 0g|Z;q(W 3kk𚆹 kdZkWsc;}7sH|rО>\;B?:ޣmNmSmrwk;S}oCZ?cυ:NnnbB/]:K^?9nAJosRlja?u؜AM {Z([ckS0]CjS[{kb%J-]#uqKfͥ3v8fcۥƬd]^3r;dNCga'uìXnKdҵ*]IVܘKo}zz׽z7soW-YmoFMzlB;FSO%A(4ic ȭ알ih oㅮ'4JWcyʭ"uXxlRv sL9w熽ƨ>CdJkC|ߝ%[ϡ?}~{.5s~긡*'JW%עڛ 7nZ'n.y~'ӭ'#u&{Ffu'tV{b\k!~% "gvmcLvj4jv滭-4>zھэǎnr¦ _=3խ_c߳/ ~qfwW~C|WS_hM-^c?WU?S pϙmugV/Nd{Ce}!>z\{3o~3=o=953L6XsJG痶;7jx&c֮7zCk|.?v)ZЋjw,OS}_>Pۯ?+L4d2epicalc/data/DHF99.rda0000644000176000001440000000277212026244665014105 0ustar ripleyusers t's|/7{g_~"|I'!|I'!CI'!|I'!|I'!|I'!|I'I|I'!|I'!|IU_'!|I1䕐WB 1+ĬBJ vbW]!vbW]!vbW]!vbW]!vbW]!vbW]!vbW]qcET LM 2-hAD"̈&j&i&hwXDmhYDNDFThb|_=j|>ʱoZ?~_,嚩SYV2 Z}=o9[J;x:pl*u-L,丿5sc Ac \OzyK4j˨Wm1Gؚq,}u]mJu\X>}Sc2uUϫEȚd7o4+ ]֭vZ/ʹ'-|hB ޹W֖];dMR*yܗ棕o^g[ + }ff9gREm#l m3:7 ()/3_ ѷ>&un/j@nCV텭BL[Q_,:W2P_|OE_oxwQy"s׬V*Uh;x1ەԊxa>ϘIݙlns:'b2yz@Kv)MY]!1wkl8]MWvժZR&$%;שؘXt&RY)jmkKXSf'Sm[OLilT/k69ӪO&˳ehx[Nk-7jvkz~D5Ż0zr"KN:6+##&t*4һAZ&Kvsڦ5Xl6 M#$喭ûZL~ksu Aepicalc/data/Decay.rdata0000644000176000001440000000223512026244665014666 0ustar ripleyusers YnG*J(*TmZ븄1%ǛġHvKPQ<G;.]+9c=w>lBn5=:J 8z:3~m;J9)ug{??,o|N x5UoTax0^9s5)θ3=QU:Qyo77)<>'}=*QIRu:&9nq/_Go}}\WKaF=q? >Zh;@~'$/fmOSqG`<哺^V5VA~6m3?o_!ˮ<2`q+_,B) od_<pCG`,)+ }!Ao4,9SF7/}jpu@e>!c q7 AR~UwW_j>1Nݠ,MΗA!q,I)p]_Νd||gJUe>od?~lC>J+2r맰ېG N*]yC=|OrZ"ς!_ 㖀M(e $)䊥qC~r=~u+<8H?YwI62 _~&﷋dn~$R# ׎ݧ}H~χu~ᅤ4CF}/ZG\y?Pdy,[AYjPL'(! OǶ=Qko;8-Vmm5%e7:{]w!'wIz9nRwju¼'7Z:}N[O֭t*5cfMO3Vq}m6zMBpSϮ8W'PR3{m6ݿa4PVY%ʃZ9C.缤I٪!!?~ԟk_s >0epicalc/data/Compaq.rdata0000644000176000001440000002003112026244665015053 0ustar ripleyusers TEֆԹC ( QVATD1$)bk#k`8aU kFP Asz޲npe󛪮:ߪ;sJ>Lx3o=P,VT ^G^q}BPKJ ]:SJNGzP Ճq@ bj5P397*/? j BЁP#tt0t :: :::: J@c.cqP7;:  NzCAC}33ss$T A@h4 Aá Hk@cqExh'RePrh"tt%tt5t t-t4 ]MnBӠ-Эm Н]P9tt/tt? 40(4 ;h68$4z z =̓C/@Ћh!2 *O5u h&6/]=}Ch1och Z} g h%9  Z B;h#  mB?A?C@}'O? 'O? 'O? 'O?C? 'O? 'O? 'O?  'O? 'O? 'O? 'O?JB? 'O? 'O? 'O? 2'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O?ڦ׾ߤ2oooooooooooooo32`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ- 2`ˀ-6};`#`-[ l1b`-[ lq=}`-[ l1b`-[ l1b`-[ l1b`-[ l1b`-[ l1b`q2Vʸ[w+neܭq2Vʸ[w+neܭq2Vʸ[w+neܭq2Vʸ[w+neܭq2Vʸ[w+neܭq2V 3g? 9y 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g?oӏ$.=!={K&={={={>={={={={={KNQ)c3Rd)Oى!ߘ;~/o?&;D\^rʼnZ-Ύ|Ƕ3k{w?}vd۟˵򝋨aG֧lcwPT]0˜͇|6Z糦#wɎw\ϾNg}g_2i3۞w_,eCa3"sgGlvV庾o9Z٣%lfk#϶r='sK,l?^e5s\-٘^ugr\b؀q"_)έsؾÆ1z12E'2t_~ XAa+cQRƌH?\3]ڥKYk׮]w_޿d{ߓ#W]_e[krO^Ft*d52jk:s?1*V|{sZ{>Wό{V9Ϸn]ϠkzY(^w:{Vl{8Q+y*wuڱ:{}jϥ"]{4a<=>GU&q`vy1X]}w1i%Wv̕9,fXFj5Wamyka gl:vx|K?soȶVa<[ɥ\J6lg`͵|kX}fgvze :_9GMTݰю=Whÿ^;n.g^ّm?ƛmDݾe|a ~OΗ8v{ [sҮksgW.~ڏZYe͕92v3 O"o7.KE^cJ &4WƢ7OE`bOl >ŵ\{ijzw?wי:칷 gr3:7]}kꧽ֮u}c^g?fk+g?̶'+fυ߾}w[vl"׾s9ٌ:cø]~еYckQ{fʼn]E>te:Wqʄ]d;K\㊺\e\}'U7l?{?jl~ga{˵\gk,3ͪ묰ug̺OΧ"|xo :mݡSec+|Pc> qXag>5ӿiWqkSo?vaN0\ucO_ש" ^tՏO1hϭ* ;98}>}\cOsdOLr티zc~v<{{Վ=_azpXtͣ͝`1;{/ܵ\\b6\\ڌk:g\g}m׻w3>]mױYr5.옮=mV^'W;V]{rqa:5.?69t5c캯\{_׿olb l){csleϱ.;nߞW?<;W?\g]?q}\LغwӾ?8. :{_3żk}?ٟ|;u:עk{ӵafS2{sտa牫g}oضxiߧՆݿs5ga?'ls E߮ksf7 RŽx3RA?H.抿t$˧$W/Dƍ~K$.}^oM~ۿ,x ]1]ߛ5Bʽp銀OI>L/g').iQ,޼HK&MK2Iwi2-rZ#.yOMxCҩZ/ ^sI-p{Š/%vzHʱ5/Y%^mՏ%UG/U}[n-5~}}lwI$w-IzI['׷O /I}`d[Ւk>FYA;wnl׺VICWI-j ͐$7Bmi<*v;]RocluW)qzW7 ](QS֒~A ߿B?;Yk撿JN͛JE04-2e%q)w*J?Mj/t'I=./%WH_꡾B"zuW^y2)2_۾1n"Gxqy__;sIE?\ޚR!'(9[^Jz=V&|'h)Rԟ"iFM}kI\3!4W~gto%iN]{Iޞ:_TC%3%\$jԓ|x5+y=L_8%Ji[l)4=FS|YY[N-N=9YG(/,~:W7$*|$UTiYԗV9NI*}?[ ߪU7z͟WK i^V$]K%ngi?տi k՜+uR֓kE+{.kZ#qkOmQr'j_ֻ3Ϳh~F_uڜ~TSɯӣĭ{'h7aWGVJj{_T*moLǸǞ_d*r򋛥>2OX[ܕxlpД&Ŝ~y'7OE_AX?|[Eg L;ĝ>2?}ƛ{gb١HHy^bd+"e_Z'ڗ>]˗wp+Vu<_|Z/MFWNϼ'8mwCq2'ߨ'|-͏U|eeG cM^Cey^^TW"aњxՔykX^הOK7{Aǟ\[\wzɣ s/7_K]ަaۮ~|>ZuuGSUڿse;VG6z}u"|7Ѱ3)r;>{"=;g?g~3߷{3RoJ VDh[q?~qc7rOB;9}~NW5- ԧ\Uvg<>P>|Cg?H|+>wzl?W-Z~~>/_M{m`y_,:h?;H}|ܭ\6\0GT|Go\qe8VO_l>~̒vk'qVj=oz/nyit;tp}^U| >]&޵P[|ʟ^&qJ˟KN<5^?gķwܺTKK3T'N)W rYrӓ6׵?iYwh?g8"O$>=y>_Y_{ wK㋴KnkCJP5*ODV+ϗ:P?-Bר$~ 5޳R~Z-KnM[J];JΫ.6>~I7<'jC(vr|>iG~1컽2뒉7~E[VwǤ\S|#lR)8-}wz'^i/k3nLEZnA^4޻~R}"5U}[BU~ޛ()Qʏ赠y-i2C{j^mVK$nI9@Iǵ%)9zﶧM^PSUy?XҿB}hS5}fMOrڟh''j+%}b֟Ut?Et?]WZS:fL`tQFefm#uuw;(޾mێmѪZuQKTPrH*gA/'PN.И#OS-סxǕk#c;#OXفUe߷+lnǕnH1˫u4 >hԈ#[ =d!m+P͘Ҿ_22u:4(xQ&CTN*T[;vwWl*WjP{_>U1 _7lVV ÖGepicalc/data/BP.rdata0000644000176000001440000000264312026244665014145 0ustar ripleyusers klULJiiCAXVZ^ZCTf86;BH#Ƅ(BET(MD7?v]{{iM岊e%^O ,_?M<@gWkZP ,J/75SEq-V0 v0 #HpF`{}~0x2P*D0 LST0 < 8 f xs@%x<U`.`!x< s,<% ^+J`9 1Sg˴gv?~l|_ѼԿ?Fkϱ}ޤ"JXFδ-"_k7_լucqh^zM4o0H 6- @/8FQe\UFBȼ93hgOwtyRwm`5״lY[/^hcKN֬jupAײP\yneMfuuM*[*XL{3)K{Q׈z>ŽP{Ui<6kf*\J{sop*͠T[5y }+yn8^3WceW>kzur <&ߦx9v^^G=k2]]{U*hq*^K# VLJ+;L4AhIDhO*m_A{{:EуE2[.KcD;DONxH$ѶW3D)9su]Bί-E;zGqoam߉~Q%~1㧌ؿe]d?\񢻇sX=*o~MԱ2Ƴ?[/~?#\ю-\籅9 9=uMJ3Z-ln{dNJGPhHЯ 1/=s|h*Me} +MW}\ԛuRDg=f֥N7vͰ? ©\} \pK DFl3dپ)j1ǙXn4Voچ&X1kģk(/fk5j,4FeőXt{ؿtZKrvV#%L;-gl| .M;v<{OE3eT5Hx:: '枨3+ L`D:Yy-5z?U%Ġ7@?R_>N?IG25 N epicalc/data/Bang.txt.gz0000644000176000001440000002321312026244670014646 0ustar ripleyusersu]ۮmSl}~HDJOSi@ײ$˖ffēeo?ǿ?ןHX7A|<18Σ{xyۍֈsZ7E~Utg?/</\oy7XFe}xrʿN}ON眊Y")`/nO^--_suCnOsL!̖s.ah_Ox^.?U}_8#x~ٓǹ/5xY8a.O5~{x8yb3=?r'{g]/8 mQ_񖷮Η8| 3| ȗj8B?n0o%֕|G牳0?9Yuxc\}4Ѿ;8%׾ν_uִXK`X<C\O-ĻulrX7B?/֪~iϭ}|x`lЇ=׫z1~ؿ:r{W;^uw PX\89^^APgֈ!Joڱoi+YqyNC_W4Ι8;?e }%sOh+95^7%w(ulxD;^Dyu/>! +ׅ?@qX9Y>&|293C'/W;EfA?CaPIzxׅ>x$SJOz.PD8-S9zUWUCܡ*sG?K:s%+C}c>,/S|¾g{bhx5[C\J_R}s }˟WzS:p!?C_a }igKC_1 yP&x<ި8'G<#f+ԑs1?cp|P_𿻟=.ωKBݩ>9TOȇz 5#EW}p߃i8x}x W=x諎U'ޖ=%sK2~y˅,.a s5.u%s~tcMsx<͓~}x`>}5}sq}yb}Z8. M=^,.>ꖒۇuK" x牗O7ֽPfx1?%'s>/g6U;Yz>3e諛'e-x=WW; U?ΙBb85{;^[/{?\qqu~/'{}9X5o}T]m+x1{W\ Op諽n*5-N*=Ns[5qUV?dCW KsvK~ +xz~bI)noL탧Qly9x`>׋?K/>ƹQsީ}M<q?x\_EYM_uS->>ϣok(^O*VgP6O1k 3?O}Ro}U׺~>[_՟o}U_Q䏿gZ<={G&^?>׭*wU/t?^VMfuR*<Vnx}ݪ#^s|+yϟ[_W''y뫓}uﭯp[_MZ+kcryx}]{Y99]ks>{s.~O%R_|Aɭ&jq>˭W_!Z~Yn}u/ ̓Hǫ[^=Nj-=x)ٺC":utr|Tn}5W En}l~$j?O*puߓ׈{}z}n3*z}aPp^Hx_BG৐G/s[%+ |uԽ_n}W¾Uy*'^?>[_u3WϘ[_}oUۖܟl8ԥ4~m/٪h #ҚmxOwgpxv+qա(?C_-xC%po9~oz?8);O|hc)T=^*U[`]q؇O|~㹦:g~p>~. ~`}z?;zt諅oKZS qg+&WK[i~+7ۡ6Oۡ\[Z8T _W4Se__ M|<@݅?Gϡ}RG{^u+fW4>ں x?=zX{=x^{7\jOY8A{W#x֮}ޛ'Γޝ?엖-!aKއ-`_>jx\^9qo}ǼպV_ G7mڭ?[_)yWWW W扄x㾓xi};*yb?=^3ZyP\i џdЇW&^) jlyy_ykb@[7ht9gWá^=sÜ){~qAgãj?jպ/o}^j= Wﭯ1oW'{2{XfgǺȯ s[9yӢp~[_2gc},0Rx"n. l}/#xaj|غxӶ/ޒџ^`O싡8ՍlWgԋWOGC_y}ދE|ثc7~UŃL֍J==?^WоSyqqn[Jmȥ=Ϋ 'a)xgd/>^] g999?}s(ymD}bxnEꇽŋ@ovў9l߳e^ˇ>//ֽdCc=ǰ^Px3sxxp8rqB8>Gȩ&jJy'UOo=ׅ&I![{|. ߗj8Myo[>!j|ο uWuE9*zm=?Z6hwJSþ=̷V G4gg=I%yz1|r+/ϘKl{X7}O8 \yx8wu SG7.7 W3.>y/Cdpc_\6W݅c-\=6.C_jyZ=O7'(}U"ӊxF+ނԌ?iyx8˴?x^a_'_,[m}}%\շ#uDK=U >-㹐ﻁ~C_;y3<~KѾ}uy ]Lq^ }Uߺ4}ƿ%_\8Y\hx_tt3iq5[ϕ=e/'zh}o<zzEg/f_n~;{_x}M]x6<֑C:W\x1ߏp1 }poϔ>yL++yGlW4RCCo,6?4~#ؗ? B/-}w}*4>]xÞ6 }g p+$@C_]x3{ t/C_)pW83i\2y' j>_{w}7UyǠN-7UI0'~髅g} P xq痾קtm۞6qzۍ'sji ޅ8[V πWOd|h¼m}Ku ;yecZ`w1+󽷝oڼ>?=8g8y}xpg\.'n3~+yWg_nn¹Ô6=1o}\'2xC' <^\wAo05^t,s2OV_ЍV߆'yu/}U}cϥ 7p྾ղ'Ʊ^*|+K\-Ǻ/;,Y>Mra̓D~[^Gi]n~>Rf_7%1eU-u*W^6\F^џyn9ΝV d nџnpd0χZ9U9̥߯qC_Nٶ=C_mJǸJ"M%xr=؇%xw }U l+^|?O.Ibt)օ}Z>-n59f¾(^&[L N{ϵ֍WWkw'N|=ƸZ8y_{+jpb\Mcnþd7!nEXY<?7C_ww.9u諅 nC>g+=엡'C_˾p{ZN_^xWp}7Ggմl@*mx_m]byjyxU1?\Pu?9ڷx^S}'-}R#oЇY87Zu3+RSskP/[`g齃Nϩ/Y8G3j)yr?x} x}nq RӶw^_/ux-#Z}po\!jy$Y`~KuUNf}u3O1K_Uy=?K_uIʥ*~_wy}w]x6a_h7q>hy+g\*`]#6+ }ղ42u^ϨC՝g<|'gkC[} |dqixz']aÅgܸ[+4hþAIuפVwi_s8G9ߠ4[3?3z>C_q7Do9C_KwWk]}Uj nblwe]l.R^;Ǻb<9ezW}u+.yWy+ke:Ṙ};kx7q3*t^W);o̓|'iX8׃/ת쓅 z} jpĭU<~OKO3,ފtoo~VЬp] 췅j?su+{| ix@.N:]O|ޡC_Mӡ[/;?-xz%u^lnǺ+ɖtonn~}r2gZg2iyfuo^x|C?1|nU߅{} _'_$e+ ix8[MWop_ }w^=?U/O]-B~:7Wv+p]8Mq_]jþgrnloh&NOoW2Ãnw\ٔ̓u狮xaQoG7ے1a:nE? j8&jO[yu]w[\ŋp~]J}?.\ p.}u^O\_i~+9<闾Z¹O~COuoO+[0zj9S~f x6Nxg8yYd%>po{J;y}!dΓ#3טgq ;9ϴg\\wNg~f_>콟{:_wg!epicalc/data/Attitudes.rdata0000644000176000001440000000520312026244665015605 0ustar ripleyusers [ߓFd.$pH $pYKy#>QEU^k"ۋ-1.jz}U*h_OOOXkɝAѭ0ZlG_wNM~H^"|u-T(Bpp\5P)b3{^&P}}#kx6 ?!S›1g&pK;_%7 GDŽ.!!OaLx@[9{G   |BxDGŸN6~mah! pD{߄o2; V_e:;u,_dE\;:"ۘalM՚ZyǧEp:*wpIGI/>/uȗeU/UzJ_e8 d$ms}%iȣrw|[.\s=d>r3v'f'z.ߠmmG{of>F>NO]_\1_=$[v1R\cc(Mr!HAF3eښC;]Iͷh+>y>Wnusi cg!m{s>#3eh7s쓵@/ËAhKG2vZ}rҟ63Y/:=C9_Xvly/GЍk,k6S_;Ľokʉ\ohEk9\~yZn\Cr1`WM1ZS>r,s_`hw)#d/'o]y?#jro߻RmWlk1}pCqH|q}gC9I{~rk r8>ns .ks+7ȶj<ȹ[+_;Z><[iGg@0/ nGk|`_< y}ل~s :%-GƉZΑ kgM yԉpNm}=rȣͲ_A\='ACuI9\OyH>-7b}(풟}0^֞j2-GnmbL7-`g!k>1XAƉ}stQuWJZMw'qZbr=}W˧Zr#vr8 cﹽƍg\gCFJrڻ֚^o}a|\+؍'Aqs 2}[d<v)oPf X7p% ig'i}hP.]\Z-55Cql= W[!٫&N|"sѣc a~-'~\GC!/p=\VSRbcbCH9yk"ϓ~';|vՕ3=hqكuP}u=<[)`[Ӭ̊4/ \5E~)H?O89>AoC;l/tFi3ɿ4i~aȺfj=69qlűhwE;T{hE{=[Y)Qvϴ[n/yqn_fQ#p$$`(fUyYoʽLKMϽ<|ex}e; q8.Wٜ7r>OYt>'ۢ|\ D_;'2/.+Cf[NceV&Ēgg|sjդRצ5*1͏v-tסZM̐UӤx8{F7dge5|[CѐU7f%EFjO3_Skpӿ$j*Һ^]U'4&4U&4%&4%4%4%4e%4,4,2qE\"._KWą+ꎸ s$̑0G s$̑0G s$̑2G)s̑2G)s̑2G=1G9zcs=1G9g>s}3G91`s c0ǀ91`s cC2ǐ91d!s c#1Lj9F1bsc#1ǘ91f1scc3ǘ9Ɔ=>ͮm&f69͡mlӲu-[ײu-[ײu-[ײu-[ײu-[ײ%-leK,[b˖XIJ%-leK-[jR˖ZԲU`}I%Wp}>QV?qF5;3_sFַWJ DxG}o!vz{AJdbäqk +ի'HJ  ηӪo(_'YE6]%(~&>S|[yem`upI]b-Ahi73\Ԣpj7uկg.U{Չ'N;Nr*g` Xİ8v=;fiQX٥|\GG'ٰAS~K'ϩ:1zNYaHj.t/NGj>_niirT n+Bwk斚^i$snX/ylXQ$}2km'